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 - 2019 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 
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 
subroutine mserar(fid, mname, aname, val, cret)
subroutine mseiar(fid, mname, aname, val, cret)
subroutine mseasz(atype, size, cret)
Cette routine renvoie la taille en octets du type élémentaire atttype.
subroutine msesin(fid, mname, mgtype, mdim, smname, setype, snnode, sncell, sgtype, ncatt, ap, nvatt, cret)
subroutine mfiope(fid, name, access, cret)
Definition: medfile.f:42
subroutine msecni(fid, mname, aname, atype, anc, setype, pname, psize, cret)
program medstructelement5
subroutine msesar(fid, mname, aname, val, cret)
subroutine mficlo(fid, cret)
Definition: medfile.f:82