MED fichier
usecases/f/UsesCase_MEDmesh_6.f
1 C* This file is part of MED.
2 C*
3 C* COPYRIGHT (C) 1999 - 2021 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
mficlo
subroutine mficlo(fid, cret)
Fermeture d'un fichier MED.
Definition: medfile.f:82
usescase_medmesh_6
program usescase_medmesh_6
Definition: UsesCase_MEDmesh_6.f:25
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
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
mfiope
subroutine mfiope(fid, name, access, cret)
Ouverture d'un fichier MED.
Definition: medfile.f:42
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
mpfprw
subroutine mpfprw(fid, pname, psize, profil, cret)
Cette routine permet d'écrire un profil dans un fichier MED.
Definition: medprofile.f:21
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
mficow
subroutine mficow(fid, cmt, cret)
Ecriture d'un descripteur dans un fichier MED.
Definition: medfile.f:99