MED fichier
Unittest_MEDstructElement_4.f
Aller à la documentation de ce fichier.
1 C* This file is part of MED.
2 C*
3 C* COPYRIGHT (C) 1999 - 2017 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 * Tests for struct element module
20 C *
21 C *****************************************************************************
23 C
24  implicit none
25  include 'med.hf'
26 C
27 C
28  integer cret
29  integer*8 fid
30  character*64 fname
31  parameter(fname = "Unittest_MEDstructElement_4.med")
32  character*64 mname2
33  parameter(mname2 = "model name 2")
34  integer dim2
35  parameter(dim2=2)
36  character*64 smname2
37  parameter(smname2="support mesh name")
38  integer setype2
39  parameter(setype2=med_node)
40  integer sgtype2
41  parameter(sgtype2=med_no_geotype)
42  integer mtype2
43  integer sdim1
44  parameter(sdim1=2)
45  character*200 description1
46  parameter(description1="support mesh1 description")
47  character*16 nomcoo2D(2)
48  character*16 unicoo2D(2)
49  data nomcoo2d /"x","y"/, unicoo2d /"cm","cm"/
50  real*8 coo(2*3)
51  data coo / 0.0, 0.0, 1.0,1.0, 2.0,2.0 /
52  integer nnode
53  parameter(nnode=3)
54  integer nseg2
55  parameter(nseg2=2)
56  integer seg2(4)
57  data seg2 /1,2, 2,3/
58  character*64 aname1, aname2, aname3
59  parameter(aname1="integer constant attribute name")
60  parameter(aname2="real constant attribute name")
61  parameter(aname3="string constant attribute name")
62  integer atype1,atype2,atype3
63  parameter(atype1=med_att_int)
64  parameter(atype2=med_att_float64)
65  parameter(atype3=med_att_name)
66  integer anc1,anc2,anc3
67  parameter(anc1=2)
68  parameter(anc2=1)
69  parameter(anc3=1)
70  integer aval1(3*2)
71  data aval1 /1,2,3,4,5,6/
72  real*8 aval2(3)
73  data aval2 /1., 2., 3. /
74  character*64 aval3(3)
75  data aval3 /"VAL1","VAL2","VAL3"/
76  character*64 pname
77 C
78 C
79 C file creation
80  call mfiope(fid,fname,med_acc_creat,cret)
81  print *,'Open file',cret
82  if (cret .ne. 0 ) then
83  print *,'ERROR : file creation'
84  call efexit(-1)
85  endif
86 C
87 C
88 C support mesh creation : 2D
89  call msmcre(fid,smname2,dim2,dim2,description1,
90  & med_cartesian,nomcoo2d,unicoo2d,cret)
91  print *,'Support mesh creation : 2D space dimension',cret
92  if (cret .ne. 0 ) then
93  print *,'ERROR : support mesh creation'
94  call efexit(-1)
95  endif
96 c
97  call mmhcow(fid,smname2,med_no_dt,med_no_it,
98  & med_undef_dt,med_full_interlace,
99  & nnode,coo,cret)
100 c
101  call mmhcyw(fid,smname2,med_no_dt,med_no_it,
102  & med_undef_dt,med_cell,med_seg2,
103  & med_nodal,med_full_interlace,
104  & nseg2,seg2,cret)
105 C
106 C struct element creation
107 C
108  call msecre(fid,mname2,dim2,smname2,setype2,
109  & sgtype2,mtype2,cret)
110  print *,'Create struct element',mtype2, cret
111  if ((cret .ne. 0) .or. (mtype2 .lt. 0) ) then
112  print *,'ERROR : struct element creation'
113  call efexit(-1)
114  endif
115 C
116 C write constant attributes
117 C
118  call mseiaw(fid,mname2,aname1,atype1,anc1,
119  & setype2,aval1,cret)
120  print *,'Create a constant attribute : ',aname1, cret
121  if (cret .ne. 0) then
122  print *,'ERROR : constant attribute creation'
123  call efexit(-1)
124  endif
125 c
126  call mseraw(fid,mname2,aname2,atype2,anc2,
127  & setype2,aval2,cret)
128  print *,'Create a constant attribute : ',aname2, cret
129  if (cret .ne. 0) then
130  print *,'ERROR : constant attribute creation'
131  call efexit(-1)
132  endif
133 c
134  call msesaw(fid,mname2,aname3,atype3,anc3,
135  & setype2,aval3,cret)
136  print *,'Create a constant attribute : ',aname3, cret
137  if (cret .ne. 0) then
138  print *,'ERROR : constant attribute creation'
139  call efexit(-1)
140  endif
141 C
142 C
143 C close file
144  call mficlo(fid,cret)
145  print *,'Close file',cret
146  if (cret .ne. 0 ) then
147  print *,'ERROR : close file'
148  call efexit(-1)
149  endif
150 C
151 C
152 C
153  end
154 
subroutine mficlo(fid, cret)
Definition: medfile.f:80
subroutine mmhcow(fid, name, numdt, numit, dt, swm, n, coo, cret)
Definition: medmesh.f:299
subroutine msecre(fid, mname, mdim, smname, setype, sgtype, etype, cret)
subroutine mseiaw(fid, mname, aname, atype, anc, setype, val, cret)
subroutine msesaw(fid, mname, aname, atype, anc, setype, val, cret)
subroutine mmhcyw(fid, name, numdt, numit, dt, entype, geotype, cmode, swm, n, con, cret)
Definition: medmesh.f:578
subroutine mfiope(fid, name, access, cret)
Definition: medfile.f:41
subroutine mseraw(fid, mname, aname, atype, anc, setype, val, cret)
program medstructelement4
subroutine msmcre(fid, maa, sdim, mdim, des, atype, aname, aunit, cret)
Definition: medsupport.f:20