MED fichier: Fichier source de UsesCase_MEDmesh_6.f

MED fichier

UsesCase_MEDmesh_6.f
Aller à la documentation de ce fichier.
1 C* This file is part of MED.
2 C*
3 C* COPYRIGHT (C) 1999 - 2023 EDF R&D, CEA/DEN
4 C* MED is free software: you can redistribute it and/or modify
5 C* it under the terms of the GNU Lesser General Public License as published by
6 C* the Free Software Foundation, either version 3 of the License, or
7 C* (at your option) any later version.
8 C*
9 C* MED is distributed in the hope that it will be useful,
10 C* but WITHOUT ANY WARRANTY; without even the implied warranty of
11 C* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 C* GNU Lesser General Public License for more details.
13 C*
14 C* You should have received a copy of the GNU Lesser General Public License
15 C* along with MED. If not, see <http://www.gnu.org/licenses/>.
16 C*
17
18 C******************************************************************************
19 C * How to create an unstructured mesh
20 C *
21 C * Use case 6 : a 2D unstructured mesh with the following features
22 C * computing steps, profiles and nodes coordinates evolution.
23 C *
24 C *****************************************************************************
25 program usescase_medmesh_6
26 C
27 implicit none
28 include 'med.hf77'
29 C
30 C
31 integer cret
32 integer*8 fid
33
34 C
35 character (MED_NAME_SIZE) mname
36 character (MED_NAME_SIZE) fname
37 character (MED_COMMENT_SIZE) cmt1,mdesc
38 integer sdim, mdim
39 C axis name
40 character (MED_SNAME_SIZE) axname(2)
41 C unit name
42 character (MED_SNAME_SIZE) unname(2)
43 real*8 inicoo(30)
44 integer nnodes, ntria3, nquad4
45 C tria connectivity
46 integer triacy(24)
47 C quad connectivity
48 integer quadcy(16)
49 C new_coordinates_step1
50 real*8 nwcos1(6)
51 C profile1name
52 character (MED_NAME_SIZE) prof1n
53 C profile1
54 integer profi1(3)
55 C profile1size
56 integer pro1sz
57 C new_coordinates_step2
58 real*8 nwcos2(6)
59 C profile2name
60 character (MED_NAME_SIZE) prof2n
61 C profile2
62 integer profi2(3)
63 C profile2size
64 integer pro2sz
65
66 parameter(fname = "UsesCase_MEDmesh_6.med")
67 parameter(cmt1 = "A 2D unstructured mesh : 15 nodes, 12 cells")
68 parameter(mdesc = "A 2D unstructured mesh")
69 parameter(mname="2D unstructured mesh")
70 parameter(sdim=2, mdim=2)
71 parameter(nnodes=15,ntria3=8,nquad4=4)
72
73 data axname /"x", "y"/
74 data unname /"cm", "cm"/
75 data inicoo /2.,1., 7.,1., 12.,1., 17.,1., 22.,1.,
76 & 2.,6., 7.,6., 12.,6., 17.,6., 22.,6.,
77 & 2.,11.,7.,11.,12.,11.,17.,11., 22.,11./
78 data triacy /1,7,6, 2,7,1, 3,7,2, 8,7,3,
79 & 13,7,8, 12,7,13, 11,7,12, 6,7,11/
80 data quadcy /3,4,9,8, 4,5,10,9,
81 & 15,14,9,10, 13,8,9,14/
82
83 C new coordinates (step 1) for nodes 13, 14 and 15
84 data nwcos1 /12.,15., 17.,15., 22.,15./
85 parameter(prof1n="UPPER_QUAD4_PROFILE")
86 data profi1 /13, 14, 15/
87 parameter(pro1sz=3)
88
89 C new coordinates (step 2) for nodes 8, 9 and 10
90 data nwcos2 /12.,10., 17.,10., 22.,10./
91 parameter(prof2n="MIDDLE_QUAD4_PROFILE")
92 data profi2 /8, 9, 10/
93 parameter(pro2sz=3)
94 C
95 C file creation
96 call mfiope(fid,fname,med_acc_creat,cret)
97 if (cret .ne. 0 ) then
98 print *,"ERROR : file creation"
99 call efexit(-1)
100 endif
101 C
102 C write a comment in the file
103 call mficow(fid,cmt1,cret)
104 if (cret .ne. 0 ) then
105 print *,"ERROR : write file description"
106 call efexit(-1)
107 endif
108 C
109 C create the profiles in the file
110 call mpfprw(fid,prof1n,pro1sz,profi1,cret)
111 if (cret .ne. 0 ) then
112 print *,"ERROR : create profile"
113 call efexit(-1)
114 endif
115 C
116 C create the profiles in the file
117 call mpfprw(fid,prof2n,pro2sz,profi2,cret)
118 if (cret .ne. 0 ) then
119 print *,"ERROR : create profile"
120 call efexit(-1)
121 endif
122 C
123 C mesh creation : a 2D unstructured mesh
124 call mmhcre(fid, mname, sdim, mdim, med_unstructured_mesh, mdesc,
125 & "", med_sort_dtit, med_cartesian, axname, unname, cret)
126 if (cret .ne. 0 ) then
127 print *,"ERROR : mesh creation"
128 call efexit(-1)
129 endif
130 C
131 C
132 C initial nodes coordinates in a cartesian axis in full interlace mode
133 C (X1,Y1, X2,Y2, X3,Y3, ...)
134 call mmhcpw(fid, mname, med_no_dt, med_no_it, 0.0d0,
135 & med_compact_stmode, med_no_profile,
136 & med_full_interlace, med_all_constituent,
137 & nnodes, inicoo, cret)
138 if (cret .ne. 0 ) then
139 print *,"ERROR : nodes coordinates"
140 call efexit(-1)
141 endif
142 C
143 C
144 C cells connectivity is defined in nodal mode
145 call mmhypw(fid, mname, med_no_dt, med_no_it, 0.0d0,
146 & med_cell, med_tria3, med_nodal,
147 & med_compact_stmode, med_no_profile,
148 & med_full_interlace, med_all_constituent,
149 & ntria3, triacy, cret)
150 if (cret .ne. 0 ) then
151 print *,"ERROR : triangular cells connectivity"
152 call efexit(-1)
153 endif
154 C
155 C
156 call mmhypw(fid, mname, med_no_dt, med_no_it, 0.0d0,
157 & med_cell, med_quad4, med_nodal,
158 & med_compact_stmode, med_no_profile,
159 & med_full_interlace, med_all_constituent,
160 & nquad4, quadcy, cret)
161 if (cret .ne. 0 ) then
162 print *,"ERROR : quadrangular cells connectivity"
163 call efexit(-1)
164 endif
165 C
166 C
167 C Mesh deformation (nodes coordinates) in 2 steps
168 C The nodes modified are identified by a profile
169 C
170 C STEP 1 : dt1 = 5.5, it = 1
171 call mmhcpw(fid, mname, 1, 1, 5.5d0,
172 & med_compact_stmode, prof1n,
173 & med_full_interlace, med_all_constituent,
174 & nnodes, nwcos1, cret)
175 if (cret .ne. 0 ) then
176 print *,"ERROR : nodes coordinates"
177 call efexit(-1)
178 endif
179 C
180 C
181 C STEP 2 : dt2 = 8.9, it = 1
182 call mmhcpw(fid, mname, 2, 1, 8.9d0,
183 & med_compact_stmode, prof2n,
184 & med_full_interlace, med_all_constituent,
185 & nnodes, nwcos2, cret)
186 if (cret .ne. 0 ) then
187 print *,"ERROR : nodes coordinates"
188 call efexit(-1)
189 endif
190 C
191 C
192 C create family 0 : by default, all mesh entities family number is 0
193 call mfacre(fid, mname,med_no_name, 0, 0, med_no_group, cret)
194 if (cret .ne. 0 ) then
195 print *,"ERROR : create family 0"
196 call efexit(-1)
197 endif
198 C
199 C
200 C close file
201 call mficlo(fid,cret)
202 if (cret .ne. 0 ) then
203 print *,"ERROR : close file"
204 call efexit(-1)
205 endif
206 C
207 C
208 end
209 C
mmhcpw
subroutine mmhcpw(fid, name, numdt, numit, dt, stm, pname, swm, dim, n, coo, cret)
Cette routine permet d'écrire dans un maillage le tableau des coordonnées des noeuds,...
Definition: medmesh.f:340
usescase_medmesh_6
program usescase_medmesh_6
Definition: UsesCase_MEDmesh_6.f:25
mpfprw
subroutine mpfprw(fid, pname, psize, profil, cret)
Cette routine permet d'écrire un profil dans un fichier MED.
Definition: medprofile.f:21
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
mficow
subroutine mficow(fid, cmt, cret)
Ecriture d'un descripteur dans un fichier MED.
Definition: medfile.f:99
mficlo
subroutine mficlo(fid, cret)
Fermeture d'un fichier MED.
Definition: medfile.f:82
mmhypw
subroutine mmhypw(fid, name, numdt, numit, dt, entype, geotype, cmode, stmode, pname, swm, dim, n, con, cret)
Cette routine permet d'écrire dans un maillage le tableau des connectivités pour un type géométrique ...
Definition: medmesh.f:621
mfacre
subroutine mfacre(fid, name, fname, fnum, ngro, gname, cret)
Cette routine permet la création d'une famille portant sur les entités d'un maillage.
Definition: medfamily.f:19
mfiope
subroutine mfiope(fid, name, access, cret)
Ouverture d'un fichier MED.
Definition: medfile.f:42