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 - 2016 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 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  integer itsize,ftsize,stsize
77  parameter(itsize=4)
78  parameter(ftsize=8)
79  parameter(stsize=64)
80 c
81  integer mgtype,mdim,setype,snnode,sncell
82  integer sgtype,ncatt,nvatt,profile
83  character*64 pname,smname
84  integer atype,anc,psize,tsize
85  integer val1(2*3)
86  real*8 val2(3)
87  character*64 val3(3)
88 C
89 C
90 C file creation
91  call mfiope(fid,fname,med_acc_rdonly,cret)
92  print *,'Open file',cret
93  if (cret .ne. 0 ) then
94  print *,'ERROR : file creation'
95  call efexit(-1)
96  endif
97 C
98 C read information about struct model
99 C
100  call msesin(fid,mname2,mgtype,mdim,smname,
101  & setype,snnode,sncell,sgtype,
102  & ncatt,profile,nvatt,cret)
103  print *,'Read information about struct element (by name)',cret
104  if (cret .ne. 0 ) then
105  print *,'ERROR : information about struct element (by name) '
106  call efexit(-1)
107  endif
108 C
109 C read constant attribute
110 C with a direct access by name
111 C
112  call msecni(fid,mname2,aname1,atype,anc,
113  & setype,pname,psize,cret)
114  print *,'Read information about constant attribute: ',aname1,cret
115  if (cret .ne. 0 ) then
116  print *,'ERROR : information about attribute (by name)'
117  call efexit(-1)
118  endif
119  if ( (atype .ne. atype1) .or.
120  & (anc .ne. anc1) .or.
121  & (setype .ne. setype2) .or.
122  & (pname .ne. med_no_profile) .or.
123  & (psize .ne. 0)
124  & ) then
125  print *,'ERROR : information about struct element (by name) '
126  call efexit(-1)
127  endif
128 c read size of attribute type
129  call mseasz(atype,tsize,cret)
130  print *,'Read information type size: ',tsize,cret
131  if (cret .ne. 0 ) then
132  print *,'ERROR : information about type size'
133  call efexit(-1)
134  endif
135 
136 c read values
137  call mseiar(fid,mname2,aname1,val1,cret)
138  print *,'Read attribute values: ',aname1,cret
139  if (cret .ne. 0 ) then
140  print *,'ERROR : attribute values'
141  call efexit(-1)
142  endif
143  if ((aval1(1) .ne. val1(1)) .or.
144  & (aval1(2) .ne. val1(2)) .or.
145  & (aval1(3) .ne. val1(3)) .or.
146  & (aval1(4) .ne. val1(4)) .or.
147  & (aval1(5) .ne. val1(5)) .or.
148  & (aval1(6) .ne. val1(6))
149  & ) then
150  print *,'ERROR : attribute values'
151  call efexit(-1)
152  endif
153 c
154  call msecni(fid,mname2,aname2,atype,anc,
155  & setype,pname,psize,cret)
156  print *,'Read information about constant attribute:',aname2,cret
157  if (cret .ne. 0 ) then
158  print *,'ERROR : information about attribute (by name)'
159  call efexit(-1)
160  endif
161  if ( (atype .ne. atype2) .or.
162  & (anc .ne. anc2) .or.
163  & (setype .ne. setype2) .or.
164  & (pname .ne. med_no_profile) .or.
165  & (psize .ne. 0)
166  & ) then
167  print *,'ERROR : information about struct element (by name) '
168  call efexit(-1)
169  endif
170 c read size of attribute type
171  call mseasz(atype,tsize,cret)
172  print *,'Read information type size: ',tsize,cret
173  if (cret .ne. 0 ) then
174  print *,'ERROR : information about type size'
175  call efexit(-1)
176  endif
177  if (tsize .ne. ftsize) then
178  print *,'ERROR : information about type size'
179  call efexit(-1)
180  endif
181 c read values
182  call mserar(fid,mname2,aname2,val2,cret)
183  print *,'Read attribute values: ',aname2,cret
184  if (cret .ne. 0 ) then
185  print *,'ERROR : attribute values'
186  call efexit(-1)
187  endif
188  if ((aval2(1) .ne. val2(1)) .or.
189  & (aval2(2) .ne. val2(2)) .or.
190  & (aval2(3) .ne. val2(3))
191  & ) then
192  print *,'ERROR : attribute values'
193  call efexit(-1)
194  endif
195 c
196  call msecni(fid,mname2,aname3,atype,anc,
197  & setype,pname,psize,cret)
198  print *,'Read information about constant attribute:',aname3,cret
199  if (cret .ne. 0 ) then
200  print *,'ERROR : information about attribute (by name)'
201  call efexit(-1)
202  endif
203  if ( (atype .ne. atype3) .or.
204  & (anc .ne. anc3) .or.
205  & (setype .ne. setype2) .or.
206  & (pname .ne. med_no_profile) .or.
207  & (psize .ne. 0)
208  & ) then
209  print *,'ERROR : information about struct element (by name) '
210  call efexit(-1)
211  endif
212 c read size of attribute type
213  call mseasz(atype,tsize,cret)
214  print *,'Read information type size: ',tsize,cret
215  if (cret .ne. 0 ) then
216  print *,'ERROR : information about type size'
217  call efexit(-1)
218  endif
219  if (tsize .ne. stsize) then
220  print *,'ERROR : information about type size'
221  call efexit(-1)
222  endif
223 c read values
224  call msesar(fid,mname2,aname3,val3,cret)
225  print *,'Read attribute values: ',aname3,cret
226  if (cret .ne. 0 ) then
227  print *,'ERROR : attribute values'
228  call efexit(-1)
229  endif
230  if ((aval3(1) .ne. val3(1)) .or.
231  & (aval3(2) .ne. val3(2)) .or.
232  & (aval3(3) .ne. val3(3))
233  & ) then
234  print *,'ERROR : attribute values |',aval3(1),'|',aval3(2),
235  & '|',aval3(3),'|'
236  print *,'ERROR : attribute values |',val3(1),'|',val3(2),
237  & '|',val3(3),'|'
238  call efexit(-1)
239  endif
240 C
241 C
242 C close file
243  call mficlo(fid,cret)
244  print *,'Close file',cret
245  if (cret .ne. 0 ) then
246  print *,'ERROR : close file'
247  call efexit(-1)
248  endif
249 C
250 C
251 C
252  end
253 
subroutine mficlo(fid, cret)
Fermeture d'un fichier MED.
Definition: medfile.f:80
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...
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...
program medstructelement5
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...
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 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 mfiope(fid, name, access, cret)
Ouverture d'un fichier MED.
Definition: medfile.f:41
subroutine mseasz(atype, size, cret)
Cette routine renvoie la taille en octets du type élémentaire atttype.