MED fichier
Unittest_MEDstructElement_8.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_7.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*64 aname1, aname2, aname3
48  parameter(aname1="integer constant attribute name")
49  parameter(aname2="real constant attribute name")
50  parameter(aname3="string constant attribute name")
51  integer atype1,atype2,atype3
52  parameter(atype1=med_att_int)
53  parameter(atype2=med_att_float64)
54  parameter(atype3=med_att_name)
55  integer anc1,anc2,anc3
56  parameter(anc1=2)
57  parameter(anc2=1)
58  parameter(anc3=1)
59  integer aval1(2*2)
60  data aval1 /1,2,5,6/
61  real*8 aval2(2*1)
62  data aval2 /1., 3. /
63  character*64 aval3(2*1)
64  data aval3 /"VAL1","VAL3"/
65  character*64 pname
66  parameter(pname="profil name")
67  integer psize
68  parameter(psize=2)
69  integer profil(2)
70  data profil / 1,3 /
71 c
72  integer mgtype,mdim,setype,snnode,sncell
73  integer sgtype,ncatt,nvatt,profile
74  character*64 rpname,smname
75  integer atype,anc,rpsize
76  integer val1(4)
77  real*8 val2(2)
78  character*64 val3(2)
79 C
80 C
81 C file creation
82  call mfiope(fid,fname,med_acc_rdonly,cret)
83  print *,'Open file',cret
84  if (cret .ne. 0 ) then
85  print *,'ERROR : file creation'
86  call efexit(-1)
87  endif
88 C
89 C read information about struct model
90 C
91  call msesin(fid,mname2,mgtype,mdim,smname,
92  & setype,snnode,sncell,sgtype,
93  & ncatt,profile,nvatt,cret)
94  print *,'Read information about struct element (by name)',cret
95  if (cret .ne. 0 ) then
96  print *,'ERROR : information about struct element (by name) '
97  call efexit(-1)
98  endif
99 C
100 C read constant attribute
101 C with a direct access by name
102 C
103  call msecni(fid,mname2,aname1,atype,anc,
104  & setype,rpname,rpsize,cret)
105  print *,'Read information about constant attribute: ',aname1,cret
106  if (cret .ne. 0 ) then
107  print *,'ERROR : information about attribute (by name)'
108  call efexit(-1)
109  endif
110  if ( (atype .ne. atype1) .or.
111  & (anc .ne. anc1) .or.
112  & (setype .ne. setype2) .or.
113  & (rpname .ne. pname) .or.
114  & (rpsize .ne. psize)
115  & ) then
116  print *,'ERROR : information about struct element (by name) '
117  call efexit(-1)
118  endif
119 c read values
120  call mseiar(fid,mname2,aname1,val1,cret)
121  print *,'Read attribute values: ',aname1,cret
122  if (cret .ne. 0 ) then
123  print *,'ERROR : attribute values'
124  call efexit(-1)
125  endif
126  if ((aval1(1) .ne. val1(1)) .or.
127  & (aval1(2) .ne. val1(2)) .or.
128  & (aval1(3) .ne. val1(3)) .or.
129  & (aval1(4) .ne. val1(4))
130  & ) then
131  print *,'ERROR : attribute values'
132  call efexit(-1)
133  endif
134 c
135  call msecni(fid,mname2,aname2,atype,anc,
136  & setype,rpname,rpsize,cret)
137  print *,'Read information about constant attribute:',aname2,cret
138  if (cret .ne. 0 ) then
139  print *,'ERROR : information about attribute (by name)'
140  call efexit(-1)
141  endif
142  if ( (atype .ne. atype2) .or.
143  & (anc .ne. anc2) .or.
144  & (setype .ne. setype2) .or.
145  & (rpname .ne. pname) .or.
146  & (rpsize .ne. psize)
147  & ) then
148  print *,'ERROR : information about struct element (by name) '
149  call efexit(-1)
150  endif
151 c read values
152  call mserar(fid,mname2,aname2,val2,cret)
153  print *,'Read attribute values: ',aname2,cret
154  if (cret .ne. 0 ) then
155  print *,'ERROR : attribute values'
156  call efexit(-1)
157  endif
158  if ((aval2(1) .ne. val2(1)) .or.
159  & (aval2(2) .ne. val2(2))
160  & ) then
161  print *,'ERROR : attribute values'
162  call efexit(-1)
163  endif
164 c
165  call msecni(fid,mname2,aname3,atype,anc,
166  & setype,rpname,rpsize,cret)
167  print *,'Read information about constant attribute:',aname3,cret
168  if (cret .ne. 0 ) then
169  print *,'ERROR : information about attribute (by name)'
170  call efexit(-1)
171  endif
172  if ( (atype .ne. atype3) .or.
173  & (anc .ne. anc3) .or.
174  & (setype .ne. setype2) .or.
175  & (rpname .ne. pname) .or.
176  & (rpsize .ne. psize)
177  & ) then
178  print *,'ERROR : information about struct element (by name) '
179  call efexit(-1)
180  endif
181 c read values
182  call msesar(fid,mname2,aname3,val3,cret)
183  print *,'Read attribute values: ',aname3,cret
184  if (cret .ne. 0 ) then
185  print *,'ERROR : attribute values'
186  call efexit(-1)
187  endif
188  if ((aval3(1) .ne. val3(1)) .or.
189  & (aval3(2) .ne. val3(2))
190  & ) then
191  print *,'ERROR : attribute values'
192  call efexit(-1)
193  endif
194 C
195 C
196 C close file
197  call mficlo(fid,cret)
198  print *,'Close file',cret
199  if (cret .ne. 0 ) then
200  print *,'ERROR : close file'
201  call efexit(-1)
202  endif
203 C
204 C
205 C
206  end
207 
subroutine mficlo(fid, cret)
Definition: medfile.f:80
program medstructelement8
subroutine mseiar(fid, mname, aname, val, cret)
subroutine msesar(fid, mname, aname, val, cret)
subroutine mserar(fid, mname, aname, val, cret)
subroutine msesin(fid, mname, mgtype, mdim, smname, setype, snnode, sncell, sgtype, ncatt, ap, nvatt, cret)
subroutine mfiope(fid, name, access, cret)
Definition: medfile.f:41
subroutine msecni(fid, mname, aname, atype, anc, setype, pname, psize, cret)