MED fichier: Fichier source de Unittest_MEDstructElement_5.f

MED fichier

Unittest_MEDstructElement_5.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 * Tests for struct element module
20 C *
21 C *****************************************************************************
22 program medstructelement5
23 C
24 implicit none
25 include 'med.hf'
26 C
27 C
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)
81 c
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)
89 C
90 C
91 C 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
98 C
99 C read information about struct model
100 C
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
109 C
110 C read constant attribute
111 C with a direct access by name
112 C
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
129 c 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
137 c 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
154 c
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
171 c 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
182 c 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
196 c
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
213 c 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
224 c 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
241 C
242 C
243 C 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
250 C
251 C
252 C
253 end
254
mseiar
subroutine mseiar(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...
Definition: medstructelement.f:415
msesin
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.
Definition: medstructelement.f:90
msesar
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...
Definition: medstructelement.f:434
mficlo
subroutine mficlo(fid, cret)
Fermeture d'un fichier MED.
Definition: medfile.f:82
mserar
subroutine mserar(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...
Definition: medstructelement.f:396
msecni
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...
Definition: medstructelement.f:357
medstructelement5
program medstructelement5
Definition: Unittest_MEDstructElement_5.f:22
mseasz
subroutine mseasz(atype, size, cret)
Cette routine renvoie la taille en octets du type élémentaire atttype.
Definition: medstructelement.f:206
mfiope
subroutine mfiope(fid, name, access, cret)
Ouverture d'un fichier MED.
Definition: medfile.f:42