1C*  This file is part of MED.
2C*
3C*  COPYRIGHT (C) 1999 - 2019  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 * - Nom du fichier : test10.f
20C *
21C * - Description : ecriture de champs de resultats MED
22C *
23C ******************************************************************************
24	program test10
25C
26	implicit none
27	include 'med.hf'
28C
29	integer*8    fid
30	integer      ret,USER_INTERLACE,USER_MODE
31	real*8       a,b,p1,p2,dt
32
33	character*32 maa1,maa2,maa3
34	character*13 lien_maa2
35C       CHAMP N°1
36	character*32 nomcha1
37	character*16 comp1(2), unit1(2)
38	character*16 dtunit1, nounit
39	integer      ncomp1
40C	MODEL N°1 DE LOC. DES PTS DE GAUSS PR CHAMP1
41	integer      ngauss1_1
42	character*32 gauss1_1
43	real*8       refcoo1(12), gscoo1_1(12), wg1_1(6)
44	integer      nval1_1
45	real*8       valr1_1(1*6*2)
46C	MODEL N°2 DE LOC. DES PTS DE GAUSS PR CHAMP1
47	integer      ngauss1_2
48	character*32 gauss1_2
49	real*8       gscoo1_2(6), wg1_2(3)
50	integer      nval1_2
51	real*8       valr1_2(2*3*2)
52	real*8       valr1_2p(2*3)
53C	MODEL N°3 DE LOC. DES PTS DE GAUSS PR CHAMP1
54	integer      ngauss1_3,nval1_3
55	real*8       valr1_3(2*3*2)
56	real*8       valr1_3p(2*2)
57
58C	CHAMP N°2
59	character*32 nomcha2
60	character*16 comp2(3), unit2(3)
61	integer      ncomp2, nval2
62	integer      valr2(5*3),   valr2p(3*3)
63
64C	PROFILS UTILISES
65	character*32 nomprofil1
66        integer      profil1(2) , profil2(3)
67
68	parameter (USER_INTERLACE = MED_FULL_INTERLACE)
69	parameter (USER_MODE = MED_COMPACT )
70        parameter ( a=0.446948490915965D0, b=0.091576213509771D0    )
71	parameter ( p1=0.11169079483905D0, p2=0.0549758718227661D0  )
72C       MAILLAGES
73	parameter ( maa1 = "maa1", maa2 = "maa2", maa3 = "maa3" )
74	parameter ( lien_maa2= "./testfoo.med"                  )
75C       CHAMP N°1
76	parameter ( nomcha1 = "champ reel" )
77	parameter ( ncomp1 = 2 )
78	parameter ( dtunit1 = "                ")
79	parameter ( nounit  = "                ")
80C       MODEL N°1 DE LOC. DES PTS DE GAUSS PR CHAMP1
81	parameter ( gauss1_1 = "Model n1" )
82	parameter ( ngauss1_1 = 6 )
83C       MODEL N°2 DE LOC. DES PTS DE GAUSS PR CHAMP1
84	parameter ( gauss1_2  = "Model n2" )
85	parameter ( ngauss1_2 = 3 )
86C       MODEL N°3 DE LOC. DES PTS DE GAUSS PR CHAMP1
87	parameter ( ngauss1_3 = 6 )
88	parameter ( nval1_3 = 6 )
89C       CHAMP N°2
90	parameter ( nomcha2="champ entier")
91        parameter ( ncomp2 = 3, nval2= 5  )
92C       PROFILS
93	parameter ( nomprofil1  = "PROFIL(champ(1))" )
94
95
96C       CHAMP N°1
97	data comp1 /"comp1", "comp2"/
98        data unit1 /"unit1","unit2"/
99C       MODEL N°1 DE LOC. DES PTS DE GAUSS PR CHAMP1
100	data nval1_1  / 1*6 /
101	data refcoo1  / -1.0,1.0, -1.0,-1.0, 1.0,-1.0, -1.0,0.0,
102     1	                0.0,-1.0, 0.0,0.0 /
103	data valr1_1  /  0.0,1.0, 2.0,3.0, 10.0,11.0, 12.0,13.0,
104     1                   20.0,21.0, 22.0,23.0/
105C       MODEL N°2 DE LOC. DES PTS DE GAUSS PR CHAMP1
106	data valr1_2  / 0.0,1.0, 2.0,3.0, 10.0,11.0,
107     1                  12.0,13.0, 20.0,21.0, 22.0,23.0 /
108	data valr1_2p / 12.0,13.0, 20.0,21.0, 22.0,23.0 /
109C       MODEL N°3 DE LOC. DES PTS DE GAUSS PR CHAMP1
110	data valr1_3  / 0.0,1.0, 2.0,3.0, 10.0,11.0, 12.0,13.0,
111     1                  20.0,21.0, 22.0,23.0 /
112	data valr1_3p / 2.0,3.0, 10.0,11.0   /
113C       CHAMP N°2
114	data comp2 /"comp1", "comp2", "comp3"/
115        data unit2 /"unit1","unit2", "unit3"/
116	data valr2 / 0,1,2, 10,11,12, 20,21,22, 30,31,32, 40,41,42 /
117	data valr2p / 0,1,2,           20,21,22,           40,41,42 /
118C       PROFILS
119	data profil1 /2,3/
120	data profil2 /1,3,5/
121
122	ret = 0
123
124	gscoo1_1(1) =  2*b-1
125	gscoo1_1(2) =  1-4*b
126	gscoo1_1(3) =  2*b-1
127	gscoo1_1(4) =  2*b-1
128	gscoo1_1(5) =  1-4*b
129	gscoo1_1(6) =  2*b-1
130	gscoo1_1(7) =  1-4*a
131	gscoo1_1(8) =  2*a-1
132	gscoo1_1(9) =  2*a-1
133	gscoo1_1(10) =  1-4*a
134	gscoo1_1(11) =  2*a-1
135	gscoo1_1(12) =  2*a-1
136
137	wg1_1(1) =  4*p2
138	wg1_1(2) =  4*p2
139	wg1_1(3) =  4*p2
140	wg1_1(4) =  4*p1
141	wg1_1(5) =  4*p1
142	wg1_1(6) =  4*p1
143
144	nval1_2 = 2*3
145	gscoo1_2(1) = -2.0D0/3
146	gscoo1_2(2) =  1.0D0/3
147	gscoo1_2(3) = -2.0D0/3
148	gscoo1_2(4) = -2.0D0/3
149	gscoo1_2(5) =  1.0D0/3
150	gscoo1_2(6) = -2.0D0/3
151
152	wg1_2(1) =  2.0D0/3
153	wg1_2(2) =  2.0D0/3
154	wg1_2(3) =  2.0D0/3
155
156C     ** ouverture du fichier                            **
157 	call efouvr(fid,'test10.med',MED_LECTURE_ECRITURE, ret)
158        if (ret .ne. 0 ) then
159	   print *,'Erreur à l''ouverture du fichier  : ','test10.med'
160	   call efexit(-1)
161	endif
162
163C     ** creation du maillage maa1 de dimension 3         **
164	call efmaac(fid,maa1,3,MED_NON_STRUCTURE,
165     1	               "Maillage vide",ret)
166        if (ret .ne. 0 ) then
167	   print *,'Erreur à la création du maillage : ', maa1
168	   call efexit(-1)
169	endif
170
171C     ** creation du maillage maa3 de dimension 3         **
172	call efmaac(fid,maa3,3,MED_NON_STRUCTURE,
173     1	               "Maillage vide",ret)
174        if (ret .ne. 0 ) then
175	   print *,'Erreur à la création du maillage : ', maa3
176	   call efexit(-1)
177	endif
178
179
180C     ** creation du champ réel n°1                        **
181	call efchac(fid,nomcha1,MED_FLOAT64,comp1,unit1,ncomp1,ret)
182        if (ret .ne. 0 ) then
183	   print *,'Erreur à la création du champ : ', nomcha1
184	   ret = -1
185	endif
186
187C     ** creation du champ entier n°2                      **
188	call efchac(fid,nomcha2,MED_INT32,comp2,unit2,ncomp2,ret)
189        if (ret .ne. 0 ) then
190	   print *,'Erreur à la création du champ : ', nomcha2
191	   ret = -1
192	endif
193
194C     ** creation du lien au fichier distant contenant maa2 **
195	call efliee(fid,lien_maa2,maa2,ret)
196        if (ret .ne. 0 ) then
197	   print *,'Erreur à la création du lien : ', lien_maa2
198	   ret = -1
199	endif
200
201C     ** creation de la localisation des points de Gauss modèle n°1 **
202	call efgaue(fid, MED_TRIA6, refcoo1, USER_INTERLACE,
203     1	             ngauss1_1, gscoo1_1, wg1_1, gauss1_1, ret)
204        if (ret .ne. 0 ) then
205	   print *,'Erreur à la création du modèle n°1 : ', gauss1_1
206	   ret = -1
207	endif
208
209C     ** creation de la localisation des points de Gauss modèle n°2 **
210	call efgaue(fid, MED_TRIA6, refcoo1, USER_INTERLACE,
211     1	             ngauss1_2, gscoo1_2, wg1_2, gauss1_2, ret)
212        if (ret .ne. 0 ) then
213	   print *,'Erreur à la création du modèle n°2 : ', gauss1_2
214	   ret = -1
215	endif
216
217
218C     ** Ecriture du champ n°1
219C     ** - enregistre uniquement la composante n°2 de valr1_1
220C     ** - pas de pas de temps, ni de numero d'ordre
221	dt = 0.0D0
222	call efchae(fid,maa1,nomcha1,valr1_1,USER_INTERLACE,nval1_1,
223     1               gauss1_1,2,MED_NOPFL,MED_NO_PFLMOD,
224     2               MED_MAILLE,MED_TRIA6,
225     3               MED_NOPDT,dtunit1,dt,MED_NONOR,ret)
226	if (ret .ne. 0 ) then
227	   print *,'Erreur à l''écriture du champ : ', nomcha1,'et.1'
228	   ret = -1
229	endif
230
231C     ** Nouvelle Ecriture du champ reel en mode remplacement
232C     ** - complete le champ precedent en enregistrant les composantes 1
233C     ** - pas de pas de temps, ni de numero d'ordre
234	call efchae(fid,maa1,nomcha1,valr1_1,USER_INTERLACE,nval1_1,
235     1               gauss1_1,1,MED_NOPFL,MED_NO_PFLMOD,
236     2               MED_MAILLE,MED_TRIA6,
237     3               MED_NOPDT,dtunit1,dt,MED_NONOR,ret)
238	if (ret .ne. 0 ) then
239	   print *,'Erreur à l''écriture du champ : ', nomcha1,'et.2'
240	   ret = -1
241	endif
242
243C     ** Ecriture sur le champ reel
244C     ** - De la 1ere composante du tableau valr1_2
245C     ** - Avec un pas de temps égal a 5.5
246C     ** - Pas de numero d'ordre
247C     ** - maa2 est distant
248	dt = 5.5D0
249	call efchae(fid,maa2,nomcha1,valr1_2,USER_INTERLACE,nval1_2,
250     1               gauss1_2,1,MED_NOPFL,MED_NO_PFLMOD,
251     2               MED_MAILLE,MED_TRIA6,
252     3               1,"ms",dt,MED_NONOR,ret)
253	if (ret .ne. 0 ) then
254	   print *,'Erreur à l''écriture du champ : ', nomcha1,'et.3'
255	   ret = -1
256	endif
257
258C     ** Ecriture sur le champ reel
259C     ** - De la 2ere composante du tableau valr1_2
260C     ** - Avec un pas de temps égal a 5.5
261C     ** - Pas de numero d'ordre
262C     ** - maa1 est local
263	dt = 5.5D0
264	call efchae(fid,maa1,nomcha1,valr1_1,USER_INTERLACE,nval1_1,
265     1               gauss1_1,2,MED_NOPFL,MED_NO_PFLMOD,
266     2               MED_MAILLE,MED_TRIA6,
267     3               1,"ms",dt,MED_NONOR,ret)
268	if (ret .ne. 0 ) then
269	   print *,'Erreur à l''écriture du champ : ', nomcha1,'et.4'
270	   ret = -1
271	endif
272
273
274C     ** Ecriture sur le champ reel
275C     ** - De la 1ere composante du tableau valr1_1
276C     ** - Avec un pas de temps égal a 5.5
277C     ** - Numero d'ordre egal a 2
278C     ** - maa3 est local
279	dt = 5.5D0
280	call efchae(fid,maa3,nomcha1,valr1_2,USER_INTERLACE,nval1_2,
281     1               gauss1_2,1,MED_NOPFL,MED_NO_PFLMOD,
282     2               MED_MAILLE,MED_TRIA6,
283     3               1,"ms",dt,2,ret)
284	if (ret .ne. 0 ) then
285	   print *,'Erreur à l''écriture du champ : ', nomcha1,'et.5'
286	   ret = -1
287	endif
288
289C     ** Creation de profil
290C     ** - qui selectionne uniquement le 2e element du tableau valr1
291	call efpfle(fid,profil1,1,nomprofil1,ret)
292	if (ret .ne. 0 ) then
293	   print *,'Erreur à la création du profil : ', nomprofil1
294	   ret = -1
295	endif
296
297
298C     ** Ecriture du champ reel
299C     ** - Toutes les composantes du 2e element de valr1_1 (MED_ALL)
300C     ** - Extrait a partir du profil de nom "profil1(1)"
301C     ** - Pas de temps = 5.6
302C     ** - Numero d'ordre = 2
303	dt = 5.6D0
304	call efchae(fid,maa1,nomcha1,valr1_3p,USER_INTERLACE,nval1_3,
305     1               MED_NOGAUSS,MED_ALL,nomprofil1,USER_MODE,
306     2               MED_MAILLE,MED_TRIA6,
307     3               2,"ms",dt,2,ret)
308	if (ret .ne. 0 ) then
309	   print *,'Erreur à l''écriture du champ : ', nomcha1,'et.6'
310	   ret = -1
311	endif
312
313C     ** Ecriture du champ reel
314C     ** - Toutes les composantes du 2e element de valr1_1 (MED_ALL)
315C     ** - Extrait a partir du profil de nom "profil1(1)"
316C     ** - Pas de temps = 5.6
317C     ** - Numero d'ordre = 2
318	dt = 5.6D0
319	call efchae(fid,maa2,nomcha1,valr1_2p,USER_INTERLACE,nval1_2,
320     1               gauss1_2,MED_ALL,nomprofil1,USER_MODE,
321     2               MED_MAILLE,MED_TRIA6,
322     3               2,"ms",dt,2,ret)
323	if (ret .ne. 0 ) then
324	   print *,'Erreur à l''écriture du champ : ', nomcha1,'et.7'
325	   ret = -1
326	endif
327
328
329C     ** Ecriture du champ reel
330C     ** - 2e composante du 2e element du champ
331C     ** - Extrait a partir du profil de nom "profil1(1)"
332C     ** - Pas de temps = 5.7
333C     ** - Numero d'ordre = 2
334	dt = 5.7D0
335	call efchae(fid,maa1,nomcha1,valr1_3p,USER_INTERLACE,nval1_3,
336     1               MED_NOGAUSS,2,nomprofil1,USER_MODE,
337     2               MED_MAILLE,MED_TRIA6,
338     3               3,"ms",dt,2,ret)
339	if (ret .ne. 0 ) then
340	   print *,'Erreur à l''écriture du champ : ', nomcha1,'et.8'
341	   ret = -1
342	endif
343
344
345C     ** Ecriture du champ entier n°2
346C     ** - 1ere composante des éléments de valr2
347C     ** - pas de pas de temps, ni de numero d'ordre
348	dt = 0.0D0
349	call efchae(fid,maa1,nomcha2,valr2,USER_INTERLACE,nval2,
350     1     MED_NOGAUSS,1,MED_NOPFL,MED_NO_PFLMOD,MED_ARETE,
351     1               MED_SEG2,MED_NOPDT,nounit,dt,MED_NONOR,ret)
352	if (ret .ne. 0 ) then
353	   print *,'Erreur à l''écriture du champ : ', nomcha2,'et.1'
354	   ret = -1
355	endif
356
357C     ** Ecriture du champ entier n°2
358C     ** - 2ere composante des éléments de valr2
359C     ** - pas de pas de temps, ni de numero d'ordre
360C     ** - pour des raisons de complétude des tests on change
361C     **   le type d'élément (aucun sens phys.))
362	call efchae(fid,maa1,nomcha2,valr2,USER_INTERLACE,nval2,
363     1     MED_NOGAUSS,2,MED_NOPFL,MED_NO_PFLMOD,MED_NOEUD,
364     1               0,MED_NOPDT,nounit,dt,MED_NONOR,ret)
365	if (ret .ne. 0 ) then
366	   print *,'Erreur à l''écriture du champ : ', nomcha2,'et.2'
367	   ret = -1
368	endif
369
370
371C     ** Ecriture du champ entier n°2
372C     ** - 3ere composante des éléments de valr2
373C     ** - pas de pas de temps, ni de numero d'ordre
374C     ** - pour des raisons de complétude des tests on change
375C     **   le type d'élément (aucun sens phys.))
376	call efchae(fid,maa1,nomcha2,valr2,USER_INTERLACE,nval2,
377     1     MED_NOGAUSS,3,MED_NOPFL,MED_NO_PFLMOD,MED_FACE,
378     1               MED_TRIA6,MED_NOPDT,nounit,dt,MED_NONOR,ret)
379	if (ret .ne. 0 ) then
380	   print *,'Erreur à l''écriture du champ : ', nomcha2,'et.3'
381	   ret = -1
382	endif
383
384C     ** Creation de profil
385C     ** - selectionne les elements 1,3,5 du tableau valr2
386	call efpfle(fid,profil2,3,"PROFIL(champ2)",ret)
387	if (ret .ne. 0 ) then
388	   print *,'Erreur à l''écriture du profil : ',
389     1              'profil2(champ2)'
390	   ret = -1
391	endif
392
393
394C     ** Ecriture du champ entier n°2
395C     ** - 3eme composante des éléments de valr2
396C     ** - pas de pas de temps, ni de numero d'ordre
397C     ** - profils
398C     ** - pour des raisons de complétude des tests on change
399C     **   le type d'élément (aucun sens phys.))
400	call efchae(fid,maa1,nomcha2,valr2p,USER_INTERLACE,nval2,
401     1     MED_NOGAUSS,3,"PROFIL(champ2)",USER_MODE,MED_MAILLE,
402     1               MED_TRIA6,MED_NOPDT,nounit,dt,MED_NONOR,ret)
403	if (ret .ne. 0 ) then
404	   print *,'Erreur à l''écriture du profil : ',
405     1             'profil2(champ2)'
406	   ret = -1
407	endif
408
409C     ** Fermeture du fichier *
410 	call efferm (fid,ret)
411	if (ret .ne. 0 ) then
412	   print *,'Erreur à la fermeture du fichier : '
413	   ret = -1
414	endif
415
416	print *,"Le code retour : ",ret
417	call efexit(ret)
418
419	end
420
421
422
423