MED fichier: Fichier source de Unittest_MEDparameter_3.f

MED fichier

- Documentation MED
- Guides d'utilisation
- Guides de référence

Unittest_MEDparameter_3.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 parameter module
20 C *
21 C *****************************************************************************
22 program medparameter3
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_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)
61 C
62 C
63 C 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
70 C
71 C
72 C 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
80 C
81 C
82 C read parameters
83 do it=1,np
84 c
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
92 c
93 c if (it .eq. 1) then
94 c if ((pname .ne. pname1) .or.
95 c & (type .ne. type1) .or.
96 c & (desc .ne. desc1) .or.
97 c & (dtunit .ne. dtunit1) .or.
98 c & (nstep .ne. nstep1)) then
99 c print *,'ERROR : interpolation information'
100 c call efexit(-1)
101 c endif
102 c endif
103 c
104 c if (it .eq. 2) then
105 c if ((pname .ne. pname2) .or.
106 c & (type .ne. type2) .or.
107 c & (desc .ne. desc2) .or.
108 c & (dtunit .ne. dtunit2) .or.
109 c & (nstep .ne. nstep2)) then
110 c print *,'ERROR : interpolation information'
111 c call efexit(-1)
112 c endif
113 c endif
114 c
115 do sit=1,nstep
116 c
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
124 c
125 c if ((pname .eq. pname1) .and.
126 c & (sit .eq. 1)) then
127 c if ((numdt .ne. p1numdt1) .or.
128 c & (numit .ne. p1numit1) .or.
129 c & (dt .ne. dt1)) then
130 c print *,'ERROR : read value'
131 c call efexit(-1)
132 c endif
133 c endif
134 c
135 c if ((pname .eq. pname1) .and.
136 c & (sit .eq. 2)) then
137 c if ((numdt .ne. p1numdt2) .or.
138 c & (numit .ne. p1numit2) .or.
139 c & (dt .ne. dt2)) then
140 c print *,'ERROR : read value'
141 c call efexit(-1)
142 c endif
143 c endif
144 c
145 c if ((pname .eq. pname2) .and.
146 c & (sit .eq. 1)) then
147 c if ((numdt .ne. p2numdt1) .or.
148 c & (numit .ne. p2numit1) .or.
149 c & (dt .ne. dt1)) then
150 c print *,'ERROR : read value'
151 c call efexit(-1)
152 c endif
153 c endif
154 c
155 c if ((pname .eq. pname2) .and.
156 c & (sit .eq. 2)) then
157 c if ((numdt .ne. p2numdt2) .or.
158 c & (numit .ne. p2numit2) .or.
159 c & (dt .ne. dt2)) then
160 c print *,'ERROR : read value'
161 c call efexit(-1)
162 c endif
163 c endif
164 c
165 c if (type .eq. MED_INT) then
166 c call mprivr(fid,pname,numdt,numit,iv,cret)
167 c print *,'read value',cret
168 c if (cret .ne. 0 ) then
169 c print *,'ERROR : read value'
170 c call efexit(-1)
171 c endif
172 c
173 c if ((sit .eq. 1) .and.
174 c & (iv .ne. p2v1)) then
175 c print *,'ERROR : read value'
176 c call efexit(-1)
177 c endif
178 c
179 c if ((sit .eq. 2) .and.
180 c & (iv .ne. p2v2)) then
181 c print *,'ERROR : read value'
182 c call efexit(-1)
183 c endif
184 c else
185 c call mprrvr(fid,pname,numdt,numit,rv,cret)
186 c print *,'read value',cret
187 c if (cret .ne. 0 ) then
188 c print *,'ERROR : read value'
189 c call efexit(-1)
190 c endif
191 c
192 c if ((sit .eq. 1) .and.
193 c & (rv .ne. p1v1)) then
194 c print *,'ERROR : read value'
195 c call efexit(-1)
196 c endif
197 c
198 c if ((sit .eq. 2) .and.
199 c & (rv .ne. p1v2)) then
200 c print *,'ERROR : read value'
201 c call efexit(-1)
202 c endif
203 c endif
204 enddo
205 c
206 enddo
207 C
208 C
209 C 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
216 C
217 C
218 C
219 end
220
med_float64
double med_float64
Definition: med.h:332
mprcsi
subroutine mprcsi(fid, name, it, numdt, numit, dt, cret)
Definition: medparameter.f:174
mfiope
subroutine mfiope(fid, name, access, cret)
Definition: medfile.f:42
med_int
int med_int
Definition: med.h:337
mprpri
subroutine mprpri(fid, it, name, type, desc, dtunit, nstep, cret)
Definition: medparameter.f:134
mprnpr
subroutine mprnpr(fid, n, cret)
Definition: medparameter.f:111
mficlo
subroutine mficlo(fid, cret)
Definition: medfile.f:82
medparameter3
program medparameter3
Definition: Unittest_MEDparameter_3.f:22