MED fichier
Unittest_MEDstructElement_5.f
Aller à la documentation de ce fichier.
1C* This file is part of MED.
2C*
3C* COPYRIGHT (C) 1999 - 2020 EDF R&D, CEA/DEN
4C* MED is free software: you can redistribute it and/or modify
5C* it under the terms of the GNU Lesser General Public License as published by
6C* the Free Software Foundation, either version 3 of the License, or
7C* (at your option) any later version.
8C*
9C* MED is distributed in the hope that it will be useful,
10C* but WITHOUT ANY WARRANTY; without even the implied warranty of
11C* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12C* GNU Lesser General Public License for more details.
13C*
14C* You should have received a copy of the GNU Lesser General Public License
15C* along with MED. If not, see <http://www.gnu.org/licenses/>.
16C*
17
18C******************************************************************************
19C * Tests for struct element module
20C *
21C *****************************************************************************
23C
24 implicit none
25 include 'med.hf'
26C
27C
28 integer cret
29 integer*8 fid
30
31 character*64 fname
32 parameter(fname = "Unittest_MEDstructElement_4.med")
33 character*64 mname2
34 parameter(mname2 = "model name 2")
35 integer dim2
36 parameter(dim2=2)
37 character*64 smname2
38 parameter(smname2="support mesh name")
39 integer setype2
40 parameter(setype2=med_node)
41 integer sgtype2
42 parameter(sgtype2=med_no_geotype)
43 integer mtype2
44 integer sdim1
45 parameter(sdim1=2)
46 character*200 description1
47 parameter(description1="support mesh1 description")
48 character*16 nomcoo2d(2)
49 character*16 unicoo2d(2)
50 data nomcoo2d /"x","y"/, unicoo2d /"cm","cm"/
51 real*8 coo(2*3)
52 data coo / 0.0, 0.0, 1.0,1.0, 2.0,2.0 /
53 integer nnode
54 parameter(nnode=3)
55 integer nseg2
56 parameter(nseg2=2)
57 integer seg2(4)
58 data seg2 /1,2, 2,3/
59 character*64 aname1, aname2, aname3
60 parameter(aname1="integer constant attribute name")
61 parameter(aname2="real constant attribute name")
62 parameter(aname3="string constant attribute name")
63 integer atype1,atype2,atype3
64 parameter(atype1=med_att_int)
65 parameter(atype2=med_att_float64)
66 parameter(atype3=med_att_name)
67 integer anc1,anc2,anc3
68 parameter(anc1=2)
69 parameter(anc2=1)
70 parameter(anc3=1)
71 integer aval1(3*2)
72 data aval1 /1,2,3,4,5,6/
73 real*8 aval2(3)
74 data aval2 /1., 2., 3. /
75 character*64 aval3(3)
76 data aval3 /"VAL1","VAL2","VAL3"/
77 integer itsize,ftsize,stsize
78 parameter(itsize=4)
79 parameter(ftsize=8)
80 parameter(stsize=64)
81c
82 integer mgtype,mdim,setype,snnode,sncell
83 integer sgtype,ncatt,nvatt,profile
84 character*64 pname,smname
85 integer atype,anc,psize,tsize
86 integer val1(2*3)
87 real*8 val2(3)
88 character*64 val3(3)
89C
90C
91C file creation
92 call mfiope(fid,fname,med_acc_rdonly,cret)
93 print *,'Open file',cret
94 if (cret .ne. 0 ) then
95 print *,'ERROR : file creation'
96 call efexit(-1)
97 endif
98C
99C read information about struct model
100C
101 call msesin(fid,mname2,mgtype,mdim,smname,
102 & setype,snnode,sncell,sgtype,
103 & ncatt,profile,nvatt,cret)
104 print *,'Read information about struct element (by name)',cret
105 if (cret .ne. 0 ) then
106 print *,'ERROR : information about struct element (by name) '
107 call efexit(-1)
108 endif
109C
110C read constant attribute
111C with a direct access by name
112C
113 call msecni(fid,mname2,aname1,atype,anc,
114 & setype,pname,psize,cret)
115 print *,'Read information about constant attribute: ',aname1,cret
116 if (cret .ne. 0 ) then
117 print *,'ERROR : information about attribute (by name)'
118 call efexit(-1)
119 endif
120 if ( (atype .ne. atype1) .or.
121 & (anc .ne. anc1) .or.
122 & (setype .ne. setype2) .or.
123 & (pname .ne. med_no_profile) .or.
124 & (psize .ne. 0)
125 & ) then
126 print *,'ERROR : information about struct element (by name) '
127 call efexit(-1)
128 endif
129c read size of attribute type
130 call mseasz(atype,tsize,cret)
131 print *,'Read information type size: ',tsize,cret
132 if (cret .ne. 0 ) then
133 print *,'ERROR : information about type size'
134 call efexit(-1)
135 endif
136
137c read values
138 call mseiar(fid,mname2,aname1,val1,cret)
139 print *,'Read attribute values: ',aname1,cret
140 if (cret .ne. 0 ) then
141 print *,'ERROR : attribute values'
142 call efexit(-1)
143 endif
144 if ((aval1(1) .ne. val1(1)) .or.
145 & (aval1(2) .ne. val1(2)) .or.
146 & (aval1(3) .ne. val1(3)) .or.
147 & (aval1(4) .ne. val1(4)) .or.
148 & (aval1(5) .ne. val1(5)) .or.
149 & (aval1(6) .ne. val1(6))
150 & ) then
151 print *,'ERROR : attribute values'
152 call efexit(-1)
153 endif
154c
155 call msecni(fid,mname2,aname2,atype,anc,
156 & setype,pname,psize,cret)
157 print *,'Read information about constant attribute:',aname2,cret
158 if (cret .ne. 0 ) then
159 print *,'ERROR : information about attribute (by name)'
160 call efexit(-1)
161 endif
162 if ( (atype .ne. atype2) .or.
163 & (anc .ne. anc2) .or.
164 & (setype .ne. setype2) .or.
165 & (pname .ne. med_no_profile) .or.
166 & (psize .ne. 0)
167 & ) then
168 print *,'ERROR : information about struct element (by name) '
169 call efexit(-1)
170 endif
171c read size of attribute type
172 call mseasz(atype,tsize,cret)
173 print *,'Read information type size: ',tsize,cret
174 if (cret .ne. 0 ) then
175 print *,'ERROR : information about type size'
176 call efexit(-1)
177 endif
178 if (tsize .ne. ftsize) then
179 print *,'ERROR : information about type size'
180 call efexit(-1)
181 endif
182c read values
183 call mserar(fid,mname2,aname2,val2,cret)
184 print *,'Read attribute values: ',aname2,cret
185 if (cret .ne. 0 ) then
186 print *,'ERROR : attribute values'
187 call efexit(-1)
188 endif
189 if ((aval2(1) .ne. val2(1)) .or.
190 & (aval2(2) .ne. val2(2)) .or.
191 & (aval2(3) .ne. val2(3))
192 & ) then
193 print *,'ERROR : attribute values'
194 call efexit(-1)
195 endif
196c
197 call msecni(fid,mname2,aname3,atype,anc,
198 & setype,pname,psize,cret)
199 print *,'Read information about constant attribute:',aname3,cret
200 if (cret .ne. 0 ) then
201 print *,'ERROR : information about attribute (by name)'
202 call efexit(-1)
203 endif
204 if ( (atype .ne. atype3) .or.
205 & (anc .ne. anc3) .or.
206 & (setype .ne. setype2) .or.
207 & (pname .ne. med_no_profile) .or.
208 & (psize .ne. 0)
209 & ) then
210 print *,'ERROR : information about struct element (by name) '
211 call efexit(-1)
212 endif
213c read size of attribute type
214 call mseasz(atype,tsize,cret)
215 print *,'Read information type size: ',tsize,cret
216 if (cret .ne. 0 ) then
217 print *,'ERROR : information about type size'
218 call efexit(-1)
219 endif
220 if (tsize .ne. stsize) then
221 print *,'ERROR : information about type size'
222 call efexit(-1)
223 endif
224c read values
225 call msesar(fid,mname2,aname3,val3,cret)
226 print *,'Read attribute values: ',aname3,cret
227 if (cret .ne. 0 ) then
228 print *,'ERROR : attribute values'
229 call efexit(-1)
230 endif
231 if ((aval3(1) .ne. val3(1)) .or.
232 & (aval3(2) .ne. val3(2)) .or.
233 & (aval3(3) .ne. val3(3))
234 & ) then
235 print *,'ERROR : attribute values |',aval3(1),'|',aval3(2),
236 & '|',aval3(3),'|'
237 print *,'ERROR : attribute values |',val3(1),'|',val3(2),
238 & '|',val3(3),'|'
239 call efexit(-1)
240 endif
241C
242C
243C close file
244 call mficlo(fid,cret)
245 print *,'Close file',cret
246 if (cret .ne. 0 ) then
247 print *,'ERROR : close file'
248 call efexit(-1)
249 endif
250C
251C
252C
253 end
254
program medstructelement5
subroutine mfiope(fid, name, access, cret)
Ouverture d'un fichier MED.
Definition medfile.f:42
subroutine mficlo(fid, cret)
Fermeture d'un fichier MED.
Definition medfile.f:82
subroutine msesin(fid, mname, mgtype, mdim, smname, setype, snnode, sncell, sgtype, ncatt, ap, nvatt, cret)
Cette routine décrit les caractéristiques d'un modèle d'élément de structure à partir de son nom.
subroutine msesar(fid, mname, aname, val, cret)
Cette routine lit la valeur d'un attribut caractéristique constant d'un modèle d'éléments de structur...
subroutine mseasz(atype, size, cret)
Cette routine renvoie la taille en octets du type élémentaire atttype.
subroutine msecni(fid, mname, aname, atype, anc, setype, pname, psize, cret)
Cette routine décrit les caractéristiques d'un attribut constant de modèle d'élément de structure à p...
subroutine mseiar(fid, mname, aname, val, cret)
subroutine mserar(fid, mname, aname, val, cret)