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