MED fichier
Unittest_MEDstructElement_2.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_1.med")
32  character*64 mname1, mname2, mname3
33  parameter(mname1 = "model name 1")
34  parameter(mname2 = "model name 2")
35  parameter(mname3 = "model name 3")
36  integer dim1, dim2, dim3
37  parameter(dim1=2)
38  parameter(dim2=2)
39  parameter(dim3=2)
40  character*64 smname1
41  parameter(smname1=med_no_name)
42  character*64 smname2
43  parameter(smname2="support mesh name")
44  integer setype1
45  parameter(setype1=med_none)
46  integer setype2
47  parameter(setype2=med_node)
48  integer setype3
49  parameter(setype3=med_cell)
50  integer sgtype1
51  parameter(sgtype1=med_no_geotype)
52  integer sgtype2
53  parameter(sgtype2=med_no_geotype)
54  integer sgtype3
55  parameter(sgtype3=med_seg2)
56  integer mtype1,mtype2,mtype3
57  parameter(mtype1=601)
58  parameter(mtype2=602)
59  parameter(mtype3=603)
60  integer nnode1,nnode2
61  parameter(nnode1=1)
62  parameter(nnode2=3)
63  integer ncell2
64  parameter(ncell2=2)
65  integer ncell1
66  parameter(ncell1=0)
67  integer ncatt1,profile1,nvatt1
68  parameter(ncatt1=0)
69  parameter(nvatt1=0)
70  parameter(profile1=0)
71 c
72  integer mgtype,mdim,setype,snnode,sncell
73  integer sgtype,ncatt,nvatt,profile
74  character*64 smname
75 C
76 C
77 C open file
78  call mfiope(fid,fname,med_acc_rdonly,cret)
79  print *,'Open file',cret
80  if (cret .ne. 0 ) then
81  print *,'ERROR : file creation'
82  call efexit(-1)
83  endif
84 C
85 C
86 C Read information about a struct element model
87 C Access by name
88  call msesin(fid,mname1,mgtype,mdim,smname,
89  & setype,snnode,sncell,sgtype,
90  & ncatt,profile,nvatt,cret)
91  print *,'Read information about struct element (by name)',cret
92  if (cret .ne. 0 ) then
93  print *,'ERROR : information about struct element (by name) '
94  call efexit(-1)
95  endif
96  if ( (mgtype .ne. mtype1) .or.
97  & (mdim .ne. dim1) .or.
98  & (smname .ne. smname1) .or.
99  & (setype .ne. setype1) .or.
100  & (snnode .ne. nnode1) .or.
101  & (sncell .ne. ncell1) .or.
102  & (sgtype .ne. sgtype1) .or.
103  & (ncatt .ne. ncatt1) .or.
104  & (profile .ne. profile1) .or.
105  & (nvatt .ne. nvatt1)
106  & ) then
107  print *,'ERROR : information about struct element (by name) '
108  call efexit(-1)
109  endif
110 C
111 C
112 C
113  call msesin(fid,mname2,mgtype,mdim,smname,
114  & setype,snnode,sncell,sgtype,
115  & ncatt,profile,nvatt,cret)
116  print *,'Read information about struct element (by name)',cret
117  if (cret .ne. 0 ) then
118  print *,'ERROR : information about struct element (by name) '
119  call efexit(-1)
120  endif
121  if ( (mgtype .ne. mtype2) .or.
122  & (mdim .ne. dim2) .or.
123  & (smname .ne. smname2) .or.
124  & (setype .ne. setype2) .or.
125  & (snnode .ne. nnode2) .or.
126  & (sncell .ne. ncell1) .or.
127  & (sgtype .ne. sgtype2) .or.
128  & (ncatt .ne. ncatt1) .or.
129  & (profile .ne. profile1) .or.
130  & (nvatt .ne. nvatt1)
131  & ) then
132  print *,'ERROR : information about struct element (by name) '
133  call efexit(-1)
134  endif
135 C
136 C
137 C
138  call msesin(fid,mname3,mgtype,mdim,smname,
139  & setype,snnode,sncell,sgtype,
140  & ncatt,profile,nvatt,cret)
141  print *,'Read information about struct element (by name)',cret
142  if (cret .ne. 0 ) then
143  print *,'ERROR : information about struct element (by name) '
144  call efexit(-1)
145  endif
146  if ( (mgtype .ne. mtype3) .or.
147  & (mdim .ne. dim3) .or.
148  & (smname .ne. smname2) .or.
149  & (setype .ne. setype3) .or.
150  & (snnode .ne. nnode2) .or.
151  & (sncell .ne. ncell2) .or.
152  & (sgtype .ne. sgtype3) .or.
153  & (ncatt .ne. ncatt1) .or.
154  & (profile .ne. profile1) .or.
155  & (nvatt .ne. nvatt1)
156  & ) then
157  print *,'ERROR : information about struct element (by name) '
158  call efexit(-1)
159  endif
160 C
161 C
162 C Read model type from the name
163  call msesgt(fid,mname1,mgtype,cret)
164  print *,'Read struct element type (by name)',cret
165  if (cret .ne. 0 ) then
166  print *,'ERROR : struct element type (by name)'
167  call efexit(-1)
168  endif
169  if (mgtype .ne. mtype1) then
170  print *,'ERROR : struct element type (by name)'
171  call efexit(-1)
172  endif
173 c
174 c
175 c Read model type from the name
176  call msesgt(fid,mname2,mgtype,cret)
177  print *,'Read struct element type (by name)',cret
178  if (cret .ne. 0 ) then
179  print *,'ERROR : struct element type (by name)'
180  call efexit(-1)
181  endif
182  if (mgtype .ne. mtype2) then
183  print *,'ERROR : struct element type (by name)'
184  call efexit(-1)
185  endif
186 c
187 c
188 c Read model type from the name
189  call msesgt(fid,mname3,mgtype,cret)
190  print *,'Read struct element type (by name)',cret
191  if (cret .ne. 0 ) then
192  print *,'ERROR : struct element type (by name)'
193  call efexit(-1)
194  endif
195  if (mgtype .ne. mtype3) then
196  print *,'ERROR : struct element type (by name)'
197  call efexit(-1)
198  endif
199 C
200 C
201 C close file
202  call mficlo(fid,cret)
203  print *,'Close file',cret
204  if (cret .ne. 0 ) then
205  print *,'ERROR : close file'
206  call efexit(-1)
207  endif
208 C
209 C
210 C
211  end
212 
program medstructelement2
subroutine mficlo(fid, cret)
Definition: medfile.f:80
subroutine msesgt(fid, mname, gtype, 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