MED fichier
Unittest_MEDparameter_3.f
Aller à la documentation de ce fichier.
1C* This file is part of MED.
2C*
3C* COPYRIGHT (C) 1999 - 2020 EDF R&D, CEA/DEN
4C* MED is free software: you can redistribute it and/or modify
5C* it under the terms of the GNU Lesser General Public License as published by
6C* the Free Software Foundation, either version 3 of the License, or
7C* (at your option) any later version.
8C*
9C* MED is distributed in the hope that it will be useful,
10C* but WITHOUT ANY WARRANTY; without even the implied warranty of
11C* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12C* GNU Lesser General Public License for more details.
13C*
14C* You should have received a copy of the GNU Lesser General Public License
15C* along with MED. If not, see <http://www.gnu.org/licenses/>.
16C*
17
18C******************************************************************************
19C * Tests for parameter module
20C *
21C *****************************************************************************
23C
24 implicit none
25 include 'med.hf'
26C
27C
28 integer cret
29 integer*8 fid
30
31 character*64 fname
32 parameter(fname = "Unittest_MEDparameter_1.med")
33 character*64 pname1,pname2,pname
34 parameter(pname1="first parameter name")
35 parameter(pname2="second parameter name")
36 integer type1,type2,type
37 parameter(type1=med_float64, type2=med_int)
38 character*200 desc1,desc2,desc
39 parameter(desc1="First parameter description")
40 parameter(desc2="Second parameter description")
41 character*16 dtunit1,dtunit2,dtunit
42 parameter(dtunit1="unit1")
43 parameter(dtunit2="unit2")
44 real*8 p1v1, p1v2,rv
45 parameter(p1v1=1.0,p1v2=2.0)
46 integer p1numdt1,p1numdt2,p2numdt1,p2numdt2,numdt
47 parameter(p1numdt1=med_no_dt,p1numdt2=1)
48 parameter(p2numdt1=2, p2numdt2=3)
49 real*8 dt1, dt2,dt
50 parameter(dt1=med_undef_dt,dt2=5.5)
51 integer p2v1,p2v2,iv
52 parameter(p2v1=3,p2v2=4)
53 integer p1numit1, p1numit2, p2numit1, p2numit2
54 integer numit
55 parameter(p1numit1=med_no_it, p1numit2=1)
56 parameter(p2numit1=2, p2numit2=3)
57 integer nstep1,nstep2,nstep,sit
58 parameter(nstep1=2,nstep2=2)
59 integer np,np1,it
60 parameter(np1=2)
61C
62C
63C open file
64 call mfiope(fid,fname,med_acc_rdonly,cret)
65 print *,'Open file',cret
66 if (cret .ne. 0 ) then
67 print *,'ERROR : open file'
68 call efexit(-1)
69 endif
70C
71C
72C number of parameter
73 call mprnpr(fid,np,cret)
74 print *,'Number of parameter',cret
75 if ((cret .ne. 0) .or.
76 & (np .ne. np1)) then
77 print *,'ERROR : number of parameter'
78 call efexit(-1)
79 endif
80C
81C
82C read parameters
83 do it=1,np
84c
85 call mprpri(fid,it,pname,type,desc,
86 & dtunit,nstep,cret)
87 print *,'interpolation information',cret
88 if (cret .ne. 0 ) then
89 print *,'ERROR : interpolation information'
90 call efexit(-1)
91 endif
92c
93c if (it .eq. 1) then
94c if ((pname .ne. pname1) .or.
95c & (type .ne. type1) .or.
96c & (desc .ne. desc1) .or.
97c & (dtunit .ne. dtunit1) .or.
98c & (nstep .ne. nstep1)) then
99c print *,'ERROR : interpolation information'
100c call efexit(-1)
101c endif
102c endif
103c
104c if (it .eq. 2) then
105c if ((pname .ne. pname2) .or.
106c & (type .ne. type2) .or.
107c & (desc .ne. desc2) .or.
108c & (dtunit .ne. dtunit2) .or.
109c & (nstep .ne. nstep2)) then
110c print *,'ERROR : interpolation information'
111c call efexit(-1)
112c endif
113c endif
114c
115 do sit=1,nstep
116c
117 call mprcsi(fid,pname,sit,numdt,numit,
118 & dt,cret)
119 print *,'computation step information',cret
120 if (cret .ne. 0 ) then
121 print *,'ERROR : computation step information'
122 call efexit(-1)
123 endif
124c
125c if ((pname .eq. pname1) .and.
126c & (sit .eq. 1)) then
127c if ((numdt .ne. p1numdt1) .or.
128c & (numit .ne. p1numit1) .or.
129c & (dt .ne. dt1)) then
130c print *,'ERROR : read value'
131c call efexit(-1)
132c endif
133c endif
134c
135c if ((pname .eq. pname1) .and.
136c & (sit .eq. 2)) then
137c if ((numdt .ne. p1numdt2) .or.
138c & (numit .ne. p1numit2) .or.
139c & (dt .ne. dt2)) then
140c print *,'ERROR : read value'
141c call efexit(-1)
142c endif
143c endif
144c
145c if ((pname .eq. pname2) .and.
146c & (sit .eq. 1)) then
147c if ((numdt .ne. p2numdt1) .or.
148c & (numit .ne. p2numit1) .or.
149c & (dt .ne. dt1)) then
150c print *,'ERROR : read value'
151c call efexit(-1)
152c endif
153c endif
154c
155c if ((pname .eq. pname2) .and.
156c & (sit .eq. 2)) then
157c if ((numdt .ne. p2numdt2) .or.
158c & (numit .ne. p2numit2) .or.
159c & (dt .ne. dt2)) then
160c print *,'ERROR : read value'
161c call efexit(-1)
162c endif
163c endif
164c
165c if (type .eq. MED_INT) then
166c call mprivr(fid,pname,numdt,numit,iv,cret)
167c print *,'read value',cret
168c if (cret .ne. 0 ) then
169c print *,'ERROR : read value'
170c call efexit(-1)
171c endif
172c
173c if ((sit .eq. 1) .and.
174c & (iv .ne. p2v1)) then
175c print *,'ERROR : read value'
176c call efexit(-1)
177c endif
178c
179c if ((sit .eq. 2) .and.
180c & (iv .ne. p2v2)) then
181c print *,'ERROR : read value'
182c call efexit(-1)
183c endif
184c else
185c call mprrvr(fid,pname,numdt,numit,rv,cret)
186c print *,'read value',cret
187c if (cret .ne. 0 ) then
188c print *,'ERROR : read value'
189c call efexit(-1)
190c endif
191c
192c if ((sit .eq. 1) .and.
193c & (rv .ne. p1v1)) then
194c print *,'ERROR : read value'
195c call efexit(-1)
196c endif
197c
198c if ((sit .eq. 2) .and.
199c & (rv .ne. p1v2)) then
200c print *,'ERROR : read value'
201c call efexit(-1)
202c endif
203c endif
204 enddo
205c
206 enddo
207C
208C
209C close file
210 call mficlo(fid,cret)
211 print *,'Close file',cret
212 if (cret .ne. 0 ) then
213 print *,'ERROR : close file'
214 call efexit(-1)
215 endif
216C
217C
218C
219 end
220
program medparameter3
subroutine mfiope(fid, name, access, cret)
Definition medfile.f:42
subroutine mficlo(fid, cret)
Definition medfile.f:82
subroutine mprpri(fid, it, name, type, desc, dtunit, nstep, cret)
subroutine mprcsi(fid, name, it, numdt, numit, dt, cret)
subroutine mprnpr(fid, n, cret)