f/test10.f
C* This file is part of MED.
C*
C* COPYRIGHT (C) 1999 - 2021 EDF R&D, CEA/DEN
C* MED is free software: you can redistribute it and/or modify
C* it under the terms of the GNU Lesser General Public License as published by
C* the Free Software Foundation, either version 3 of the License, or
C* (at your option) any later version.
C*
C* MED is distributed in the hope that it will be useful,
C* but WITHOUT ANY WARRANTY; without even the implied warranty of
C* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C* GNU Lesser General Public License for more details.
C*
C* You should have received a copy of the GNU Lesser General Public License
C* along with MED. If not, see <http://www.gnu.org/licenses/>.
C*
C ******************************************************************************
C * - Nom du fichier : test10.f
C *
C * - Description : ecriture de champs de resultats MED
C *
C ******************************************************************************
program test10
C
implicit none
include 'med.hf'
C
integer*8 fid
integer ret,USER_INTERLACE,USER_MODE
integer FTYPECHA
real*8 a,b,p1,p2,dt
character*64 maa1,maa2,maa3
character*13 lien_maa2
character*16 nomcoo(3)
character*16 unicoo(3)
C CHAMP N°1
character*64 nomcha1
character*16 comp1(2), unit1(2)
character*16 dtunit1, nounit
integer ncomp1
C MODEL N°1 DE LOC. DES PTS DE GAUSS PR CHAMP1
integer ngauss1_1
character*64 gauss1_1
real*8 refcoo1(12), gscoo1_1(12), wg1_1(6)
integer nval1_1, nent1_1
real*8 valr1_1(1*6*2)
C MODEL N°2 DE LOC. DES PTS DE GAUSS PR CHAMP1
integer ngauss1_2
character*64 gauss1_2
real*8 gscoo1_2(6), wg1_2(3)
integer nval1_2, nent1_2
real*8 valr1_2(2*3*2)
real*8 valr1_2p(2*3)
C MODEL N°3 DE LOC. DES PTS DE GAUSS PR CHAMP1
integer ngauss1_3,nval1_3, nent1_3
real*8 valr1_3(2*3*2)
real*8 valr1_3p(2*2)
C CHAMP N°2
character*64 nomcha2
character*16 comp2(3), unit2(3)
integer ncomp2, nval2
integer valr2(5*3), valr2p(3*3)
C CHAMP N°3
character*64 nomcha3
character*16 comp3(2), unit3(2)
integer ncomp3, nval3, nent3
integer valr3(5*4*2), valr3p(3*4*2)
C PROFILS UTILISES
character*64 nomprofil1
integer profil1(2) , profil2(3)
parameter(user_interlace = med_full_interlace)
parameter(user_mode = med_compact_stmode )
parameter(ftypecha = med_double )
parameter( a=0.446948490915965d0, b=0.091576213509771d0 )
parameter( p1=0.11169079483905d0, p2=0.0549758718227661d0 )
C MAILLAGES
parameter( maa1 = "maa1", maa2 = "maa2", maa3 = "maa3" )
parameter( lien_maa2= "./testfoo.med" )
C CHAMP N°1
parameter( nomcha1 = "champ reel" )
parameter( ncomp1 = 2 )
parameter( dtunit1 = " ")
parameter( nounit = " ")
C MODEL N°1 DE LOC. DES PTS DE GAUSS PR CHAMP1
parameter( gauss1_1 = "Model n1" )
parameter( ngauss1_1 = 6 )
C MODEL N°2 DE LOC. DES PTS DE GAUSS PR CHAMP1
parameter( gauss1_2 = "Model n2" )
parameter( ngauss1_2 = 3 )
C MODEL N°3 DE LOC. DES PTS DE GAUSS PR CHAMP1
parameter( ngauss1_3 = 6 )
parameter( nval1_3 = 6 )
C CHAMP N°2
parameter( nomcha2="champ entier")
parameter( ncomp2 = 3, nval2= 5 )
C CHAMP N°3
parameter( nomcha3="champ entier 3")
parameter( ncomp3 = 2, nval3= 5*4 )
C PROFILS
parameter( nomprofil1 = "PROFIL(champ(1))" )
C CHAMP N°1
data comp1 /"comp1", "comp2"/
data unit1 /"unit1","unit2"/
C MODEL N°1 DE LOC. DES PTS DE GAUSS PR CHAMP1
data nval1_1 / 1*6 /
data nent1_1 / 1 /
data refcoo1 / -1.0,1.0, -1.0,-1.0, 1.0,-1.0, -1.0,0.0,
1 0.0,-1.0, 0.0,0.0 /
data valr1_1 / 0.0,1.0, 2.0,3.0, 10.0,11.0, 12.0,13.0,
1 20.0,21.0, 22.0,23.0/
C MODEL N°2 DE LOC. DES PTS DE GAUSS PR CHAMP1
data nent1_2 / 2 /
data valr1_2 / 0.0,1.0, 2.0,3.0, 10.0,11.0,
1 12.0,13.0, 20.0,21.0, 22.0,23.0 /
data valr1_2p / 12.0,13.0, 20.0,21.0, 22.0,23.0 /
C MODEL N°3 DE LOC. DES PTS DE GAUSS PR CHAMP1
data nent1_3 / 6 /
data valr1_3 / 0.0,1.0, 2.0,3.0, 10.0,11.0, 12.0,13.0,
1 20.0,21.0, 22.0,23.0 /
data valr1_3p / 2.0,3.0, 10.0,11.0 /
C CHAMP N°2
data comp2 /"comp1", "comp2", "comp3"/
data unit2 /"unit1","unit2", "unit3"/
data valr2 / 0,1,2, 10,11,12, 20,21,22, 30,31,32, 40,41,42 /
data valr2p / 0,1,2, 20,21,22, 40,41,42 /
C CHAMP N°3
data nent3 / 5 /
data comp3 /"comp1", "comp2"/
data unit3 /"unit1","unit2"/
data valr3 / 0,1, 10,11, 20,21, 30,31,
1 40,41, 50,51, 60,61, 70,71,
1 80,81, 90,91, 100,101, 110,111,
1 120,121, 130,131, 140,141, 150,151,
1 160,161, 170,171, 180,181, 190,191 /
data valr3p / 0,1, 10,11, 20,21, 30,31,
1 80,81, 90,91, 100,101, 110,111,
1 160,161, 170,171, 180,181, 190,191 /
C PROFILS
data profil1 /2,3/
data profil2 /1,3,5/
data nomcoo /"x","y","z"/, unicoo /"cm","cm","cm"/
ret = 0
gscoo1_1(1) = 2*b-1
gscoo1_1(2) = 1-4*b
gscoo1_1(3) = 2*b-1
gscoo1_1(4) = 2*b-1
gscoo1_1(5) = 1-4*b
gscoo1_1(6) = 2*b-1
gscoo1_1(7) = 1-4*a
gscoo1_1(8) = 2*a-1
gscoo1_1(9) = 2*a-1
gscoo1_1(10) = 1-4*a
gscoo1_1(11) = 2*a-1
gscoo1_1(12) = 2*a-1
wg1_1(1) = 4*p2
wg1_1(2) = 4*p2
wg1_1(3) = 4*p2
wg1_1(4) = 4*p1
wg1_1(5) = 4*p1
wg1_1(6) = 4*p1
nval1_2 = 2*3
gscoo1_2(1) = -2.0d0/3
gscoo1_2(2) = 1.0d0/3
gscoo1_2(3) = -2.0d0/3
gscoo1_2(4) = -2.0d0/3
gscoo1_2(5) = 1.0d0/3
gscoo1_2(6) = -2.0d0/3
wg1_2(1) = 2.0d0/3
wg1_2(2) = 2.0d0/3
wg1_2(3) = 2.0d0/3
C ** ouverture du fichier **
call mfivop(fid,'test10.med', med_acc_rdwr,
& med_major_num, med_minor_num, med_release_num, ret)
print *,ret
if (ret .ne. 0 ) then
print *,'Erreur à l''ouverture du fichier : ','test10.med'
call efexit(-1)
endif
C ** creation du maillage maa1 de dimension 3 **
call mmhcre(fid,maa1,3,3,
& med_unstructured_mesh,'Maillage vide',
& "",med_sort_dtit,med_cartesian,nomcoo,unicoo,ret)
print *,ret
if (ret .ne. 0 ) then
print *,'Erreur à la création du maillage : ', maa1
call efexit(-1)
endif
C ** creation du maillage maa3 de dimension 3 **
call mmhcre(fid,maa3,3,3,
& med_unstructured_mesh,'Maillage vide',
& "",med_sort_dtit,med_cartesian,nomcoo,unicoo,ret)
print *,ret
if (ret .ne. 0 ) then
print *,'Erreur à la création du maillage : ', maa3
call efexit(-1)
endif
C ** creation du champ réel n°1 **
call mfdcre(fid,nomcha1,ftypecha,ncomp1,comp1,unit1,
& dtunit1,maa1,ret)
print *,ret
if (ret .ne. 0 ) then
print *,'Erreur à la création du champ : ', nomcha1
call efexit(-1)
endif
C ** creation du champ entier n°2 **
call mfdcre(fid,nomcha2,med_int32,ncomp2,comp2,unit2,
& dtunit1,maa1,ret)
print *,ret
if (ret .ne. 0 ) then
print *,'Erreur à la création du champ : ', nomcha2
call efexit(-1)
endif
C ** creation du lien au fichier distant contenant maa2 **
call mlnliw(fid,maa2,lien_maa2,ret)
print *,ret
if (ret .ne. 0 ) then
print *,'Erreur à la création du lien : ', lien_maa2
call efexit(-1)
endif
C ** creation de la localisation des points de Gauss modèle n°1 **
call mlclow(fid,gauss1_1,med_tria6,2,refcoo1,user_interlace,
& ngauss1_1,gscoo1_1, wg1_1,med_no_interpolation,
& med_no_mesh_support, ret)
print *,ret
if (ret .ne. 0 ) then
print *,'Erreur à la création du modèle n°1 : ', gauss1_1
call efexit(-1)
endif
C ** creation de la localisation des points de Gauss modèle n°2 **
call mlclow(fid,gauss1_2,med_tria6,2,refcoo1,user_interlace,
& ngauss1_2,gscoo1_2, wg1_2,med_no_interpolation,
& med_no_mesh_support, ret)
print *,ret
if (ret .ne. 0 ) then
print *,'Erreur à la création du modèle n°2 : ', gauss1_2
call efexit(-1)
endif
C ** Ecriture du champ n°1
C ** - enregistre uniquement la composante n°2 de valr1_1
C ** - pas de pas de temps, ni de numero d'ordre
dt = 0.0
call mfdrpw(fid,nomcha1,med_no_dt,med_no_it,dt,med_cell,
& med_tria6,user_mode,med_allentities_profile,
& gauss1_1,user_interlace,2,nent1_1,valr1_1,ret)
print *,ret
if (ret .ne. 0 ) then
print *,'Erreur à l''écriture du champ : ', nomcha1,'et.1'
call efexit(-1)
endif
C ** Nouvelle Ecriture du champ reel en mode remplacement
C ** - complete le champ precedent en enregistrant les composantes 1
C ** - pas de pas de temps, ni de numero d'ordre
call mfdrpw(fid,nomcha1,med_no_dt,med_no_it,dt,med_cell,
& med_tria6,user_mode,med_allentities_profile,
& gauss1_1,user_interlace,1,nent1_1,valr1_1,ret)
print *,ret
if (ret .ne. 0 ) then
print *,'Erreur à l''écriture du champ : ', nomcha1,'et.2'
call efexit(-1)
endif
C ** Ecriture sur le champ reel
C ** - De la 1ere composante du tableau valr1_2
C ** - Avec un pas de temps égal a 5.5
C ** - Pas de numero d'ordre
C ** - maa2 est distant
dt = 5.5
call mfdrpw(fid,nomcha1,1,med_no_it,dt,med_cell,med_tria6,
& user_mode,med_allentities_profile,gauss1_2,
& user_interlace,1,nent1_2,valr1_2,ret)
print *,ret
if (ret .ne. 0 ) then
print *,'Erreur à l''écriture du champ : ', nomcha1,'et.3'
call efexit(-1)
endif
C ** Ecriture sur le champ reel
C ** - De la 2ere composante du tableau valr1_2
C ** - Avec un pas de temps égal a 5.5
C ** - Pas de numero d'ordre
C ** - maa1 est local
call mfdrpw(fid,nomcha1,1,med_no_it,dt,med_cell,med_tria6,
& user_mode,med_allentities_profile,gauss1_2,
& user_interlace,2,nent1_2,valr1_2,ret)
print *,ret
if (ret .ne. 0 ) then
print *,'Erreur à l''écriture du champ : ', nomcha1,'et.4'
call efexit(-1)
endif
C ** Ecriture sur le champ reel
C ** - De la 1ere composante du tableau valr1_1
C ** - Avec un pas de temps égal a 5.5
C ** - Numero d'ordre egal a 2
call mfdrpw(fid,nomcha1,1,2,dt,med_cell,med_tria6,
& user_mode,med_allentities_profile,gauss1_1,
& user_interlace,1,nent1_1,valr1_1,ret)
print *,ret
if (ret .ne. 0 ) then
print *,'Erreur à l''écriture du champ : ', nomcha1,'et.5'
call efexit(-1)
endif
C ** Creation de profil
C ** - qui selectionne uniquement le 2e element du tableau valr1
call mpfprw(fid,nomprofil1,1,profil1,ret)
print *,ret
if (ret .ne. 0 ) then
print *,'Erreur à la création du profil : ', nomprofil1
call efexit(-1)
endif
C ** Ecriture du champ reel
C ** - Toutes les composantes du 2e element de valr1_1 (MED_ALL)
C ** - Extrait a partir du profil de nom "profil1(1)"
C ** - Pas de temps = 5.6
C ** - Numero d'ordre = 2
dt = 5.6
call mfdrpw(fid,nomcha1,2,2,dt,med_cell,med_tria6,
& user_mode, nomprofil1, med_no_localization,
& user_interlace,med_all_constituent,
& nval1_3,valr1_3p,ret)
print *,ret
if (ret .ne. 0 ) then
print *,'Erreur à l''écriture du champ : ', nomcha1,'et.6'
call efexit(-1)
endif
C ** Ecriture du champ reel
C ** - Toutes les composantes du 2e element de valr1_2p (MED_ALL)
C ** - Extrait a partir du profil de nom "profil1(1)"
C ** - Pas de temps = 5.6
C ** - Numero d'ordre = 2
call mfdrpw(fid,nomcha1,2,2,dt,med_cell,med_tria6,
& user_mode, nomprofil1, gauss1_2,
& user_interlace,med_all_constituent,
& nent1_2,valr1_2p,ret)
print *,ret
if (ret .ne. 0 ) then
print *,'Erreur à l''écriture du champ : ', nomcha1,'et.7'
call efexit(-1)
endif
C ** Ecriture du champ reel
C ** - 2e composante du 2e element du champ
C ** - Extrait a partir du profil de nom "profil1(1)"
C ** - Pas de temps = 5.7
C ** - Numero d'ordre = 2
dt = 5.7
call mfdrpw(fid,nomcha1,3,2,dt,med_cell,med_tria6,
& user_mode, nomprofil1, med_no_localization,
& user_interlace,2,
& nent1_3,valr1_3p,ret)
print *,ret
if (ret .ne. 0 ) then
print *,'Erreur à l''écriture du champ : ', nomcha1,'et.8a'
call efexit(-1)
endif
C ** Ecriture du champ reel
C ** - 1e composante du 2e element du champ
C ** - Extrait a partir du profil de nom "profil1(1)"
C ** - Pas de temps = 5.7
C ** - Numero d'ordre = 2
dt = 5.7
call mfdrpw(fid,nomcha1,3,2,dt,med_cell,med_tria6,
& user_mode, nomprofil1, med_no_localization,
& user_interlace,1,
& nent1_3,valr1_3p,ret)
print *,ret
if (ret .ne. 0 ) then
print *,'Erreur à l''écriture du champ : ', nomcha1,'et.8b'
call efexit(-1)
endif
C ** Ecriture du champ entier n°2
C ** - 1ere composante des éléments de valr2
C ** - pas de pas de temps, ni de numero d'ordre
dt = 0.0
call mfdivw(fid,nomcha2,med_no_dt,med_no_it,dt,
& med_descending_edge,med_seg2,user_interlace,
& 1,nval2,valr2,ret)
print *,ret
if (ret .ne. 0 ) then
print *,'Erreur à l''écriture du champ : ', nomcha2,'et.1'
call efexit(-1)
endif
C ** Ecriture du champ entier n°2
C ** - 2ere composante des éléments de valr2
C ** - pas de pas de temps, ni de numero d'ordre
C ** - pour des raisons de complétude des tests on change
C ** le type d'élément (aucun sens phys.))
call mfdivw(fid,nomcha2,med_no_dt,med_no_it,dt,
& med_node,med_none,user_interlace,
& 2,nval2,valr2,ret)
print *,ret
if (ret .ne. 0 ) then
print *,'Erreur à l''écriture du champ : ', nomcha2,'et.2'
call efexit(-1)
endif
C ** Ecriture du champ entier n°2
C ** - 3ere composante des éléments de valr2
C ** - pas de pas de temps, ni de numero d'ordre
C ** - pour des raisons de complétude des tests on change
C ** le type d'élément (aucun sens phys.))
call mfdivw(fid,nomcha2,med_no_dt,med_no_it,dt,
& med_descending_face,med_tria6,user_interlace,
& 3,nval2,valr2,ret)
print *,ret
if (ret .ne. 0 ) then
print *,'Erreur à l''écriture du champ : ', nomcha2,'et.3'
call efexit(-1)
endif
C ** Creation de profil
C ** - selectionne les elements 1,3,5 du tableau valr2
call mpfprw(fid,"PROFIL(champ2)",3,profil2,ret)
print *,ret
if (ret .ne. 0 ) then
print *,'Erreur à l''écriture du profil : ',
1 'profil2(champ2)'
call efexit(-1)
endif
C ** Ecriture du champ entier n°2
C ** - 3eme composante des éléments de valr2
C ** - pas de pas de temps, ni de numero d'ordre
C ** - profils
C ** - pour des raisons de complétude des tests on change
C ** le type d'élément (aucun sens phys.))
call mfdipw(fid,nomcha2,med_no_dt,med_no_it,dt,
& med_cell,med_tria6,user_mode,"PROFIL(champ2)",
& med_no_localization,user_interlace,3,
& nval2,valr2p,ret)
print *,ret
if (ret .ne. 0 ) then
print *,'Erreur à l''écriture du profil : ',
1 'profil2(champ2)'
call efexit(-1)
endif
C ** creation du champ entier n°3 **
call mfdcre(fid,nomcha3,med_int32,ncomp3,comp3,unit3,
& dtunit1,maa1,ret)
print *,ret
if (ret .ne. 0 ) then
print *,'Erreur à la création du champ : ', nomcha3
call efexit(-1)
endif
C ** Ecriture du champ entier n°3
C ** - 1ere composante des éléments de valr3
C ** - pas de pas de temps, ni de numero d'ordre
C ** - pour des raisons de complétude des tests on change
C ** le type d'élément (aucun sens phys.))
call mfdivw(fid,nomcha3,med_no_dt,med_no_it,dt,
& med_cell,med_quad4,user_interlace,
& 1,nval3,valr3,ret)
print *,ret
if (ret .ne. 0 ) then
print *,'Erreur à l''écriture du champ : ', nomcha3,'et.1'
call efexit(-1)
endif
C ** Ecriture du champ entier n°3
C ** - les composantes des éléments de valr3
C ** - pas de pas de temps, ni de numero d'ordre
C ** - pour des raisons de complétude des tests on change
C ** le type d'élément (aucun sens phys.))
call mfdivw(fid,nomcha3,med_no_dt,med_no_it,dt,
& med_node_element,med_quad4,user_interlace,
& med_all_constituent,nent3,valr3,ret)
print *,ret
if (ret .ne. 0 ) then
print *,'Erreur à l''écriture du champ : ', nomcha3,'et.2'
call efexit(-1)
endif
C ** Ecriture du champ entier n°3
C ** - les composantes des éléments de valr3
C ** - pas de pas de temps, ni de numero d'ordre
C ** - profils
C ** - pour des raisons de complétude des tests on change
C ** le type d'élément (aucun sens phys.))
c call efchae(fid,maa3,nomcha3,valr3p,USER_INTERLACE,nval3,
c 1 MED_NOGAUSS,MED_ALL,"PROFIL(champ2)",USER_MODE,
c 1 MED_NOEUD_MAILLE,
c 1 MED_QUAD4,MED_NOPDT,nounit,dt,MED_NONOR,ret)
call mfdipw(fid,nomcha3,med_no_dt,med_no_it,dt,
& med_node_element,med_quad4,user_mode,
& "PROFIL(champ2)",med_no_localization,
& user_interlace,med_all_constituent,
& nent3,valr3p,ret)
print *,ret
if (ret .ne. 0 ) then
print *,'Erreur à l''écriture du profil : ',
1 'profil2(champ2)'
call efexit(-1)
endif
C ** Fermeture du fichier *
call mficlo(fid,ret)
if (ret .ne. 0 ) then
print *,'Erreur à la fermeture du fichier : '
ret = -1
endif
print *,"Le code retour : ",ret
call efexit(ret)
end
mficlo
subroutine mficlo(fid, cret)
Fermeture d'un fichier MED.
Definition: medfile.f:82
mfdivw
subroutine mfdivw(fid, fname, numdt, numit, dt, etype, gtype, swm, cs, n, val, cret)
Cette fonction permet d'écrire les valeurs d'un champ définies sur des entités d'un maillage pour une...
Definition: medfield.f:63
med_double
double med_double
Definition: med.h:338
mmhcre
subroutine mmhcre(fid, name, sdim, mdim, mtype, desc, dtunit, stype, atype, aname, aunit, cret)
Cette routine permet de créer un maillage dans un fichier.
Definition: medmesh.f:20
mlclow
subroutine mlclow(fid, lname, gtype, sdim, ecoo, swm, nip, ipcoo, wght, giname, isname, cret)
Cette routine permet l'écriture d'une localisation localizationname de points d'intégration dans/auto...
Definition: medlocalization.f:22
mlnliw
subroutine mlnliw(fid, mname, lname, cret)
Cette routine permet d'écrire un lien dans un fichier MED.
Definition: medlink.f:21
test10
program test10
Definition: test10.f:24
mfdrpw
subroutine mfdrpw(fid, fname, numdt, numit, dt, etype, gtype, stm, pname, lname, swm, cs, n, val, cret)
Cette fonction permet d'écrire les valeurs d'un champ définies sur des entités d'un maillage pour une...
Definition: medfield.f:87
mfdcre
subroutine mfdcre(fid, fname, ftype, ncomp, cname, cunit, dtunit, mname, cret)
Cette fonction crée un champ dans un fichier.
Definition: medfield.f:22
mpfprw
subroutine mpfprw(fid, pname, psize, profil, cret)
Cette routine permet d'écrire un profil dans un fichier MED.
Definition: medprofile.f:21
mfivop
subroutine mfivop(fid, name, access, major, minor, rel, cret)
Ouverture d'un fichier MED en indiquant la version du modèle à utiliser en cas de création d'un nouve...
Definition: medfile.f:20
mfdipw
subroutine mfdipw(fid, fname, numdt, numit, dt, etype, gtype, stm, pname, lname, swm, cs, n, val, cret)
Cette fonction permet d'écrire les valeurs d'un champ définies sur des entités d'un maillage pour une...
Definition: medfield.f:111
med_int32
int32_t med_int32
Definition: med.h:343