1 C*************************************************************************
  2 C COPYRIGHT (C) 1999 - 2007  EDF R&D, CEA/DEN
  3 C THIS LIBRARY IS FREE SOFTWARE; YOU CAN REDISTRIBUTE IT AND/OR MODIFY
  4 C IT UNDER THE TERMS OF THE GNU LESSER GENERAL PUBLIC LICENSE
  5 C AS PUBLISHED BY THE FREE SOFTWARE FOUNDATION;
  6 C EITHER VERSION 2.1 OF THE LICENSE, OR (AT YOUR OPTION) ANY LATER VERSION.
  7 C
  8 C THIS LIBRARY IS DISTRIBUTED IN THE HOPE THAT IT WILL BE USEFUL, BUT
  9 C WITHOUT ANY WARRANTY; WITHOUT EVEN THE IMPLIED WARRANTY OF
 10 C MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. SEE THE GNU
 11 C LESSER GENERAL PUBLIC LICENSE FOR MORE DETAILS.
 12 C
 13 C YOU SHOULD HAVE RECEIVED A COPY OF THE GNU LESSER GENERAL PUBLIC LICENSE
 14 C ALONG WITH THIS LIBRARY; IF NOT, WRITE TO THE FREE SOFTWARE FOUNDATION,
 15 C INC., 59 TEMPLE PLACE, SUITE 330, BOSTON, MA 02111-1307 USA
 16 C
 17 C**************************************************************************
 18 
 19 C ******************************************************************************
 20 C * - Nom du fichier : test10.f
 21 C *
 22 C * - Description : ecriture de champs de resultats MED
 23 C *
 24 C ******************************************************************************
 25         program test10
 26 C
 27         implicit none
 28         include 'med.hf'
 29 C
 30         integer      ret,fid,USER_INTERLACE,USER_MODE
 31         real*8       a,b,p1,p2,dt
 32 
 33         character*32 maa1,maa2,maa3
 34         character*13 lien_maa2
 35 C       CHAMP N°1
 36         character*32 nomcha1
 37         character*16 comp1(2), unit1(2)
 38         character*16 dtunit1, nounit
 39         integer      ncomp1
 40 C       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)
 46 C       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)
 53 C       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 
 58 C       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 
 64 C       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 
 70 C       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  )
 78 C       MAILLAGES
 79         parameter ( maa1 = "maa1", maa2 = "maa2", maa3 = "maa3" )
 80         parameter ( lien_maa2= "./testfoo.med"                  )
 81 C       CHAMP N°1
 82         parameter ( nomcha1 = "champ reel" )
 83         parameter ( ncomp1 = 2 )
 84         parameter ( dtunit1 = "                ")
 85         parameter ( nounit  = "                ")
 86 C       MODEL N°1 DE LOC. DES PTS DE GAUSS PR CHAMP1
 87         parameter ( gauss1_1 = "Model n1" )
 88         parameter ( ngauss1_1 = 6 )
 89 C       MODEL N°2 DE LOC. DES PTS DE GAUSS PR CHAMP1
 90         parameter ( gauss1_2  = "Model n2" )
 91         parameter ( ngauss1_2 = 3 )
 92 C       MODEL N°3 DE LOC. DES PTS DE GAUSS PR CHAMP1
 93         parameter ( ngauss1_3 = 6 )
 94         parameter ( nval1_3 = 6 )
 95 C       CHAMP N°2
 96         parameter ( nomcha2="champ entier")
 97         parameter ( ncomp2 = 3, nval2= 5  )
 98 C       CHAMP N°3
 99         parameter ( nomcha3="champ entier 3")
100         parameter ( ncomp3 = 2, nval3= 5*4  )
101 C       PROFILS
102         parameter ( nomprofil1  = "PROFIL(champ(1))" )
103         
104 
105 C       CHAMP N°1
106         data comp1 /"comp1", "comp2"/
107         data unit1 /"unit1","unit2"/
108 C       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/
114 C       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 /
118 C       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   /
122 C       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 /
127 C       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 
140 C       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                 
178 C     ** 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 
185 C     ** 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         
193 C     ** 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 
202 C     ** 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         
209 C     ** 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 
216 C     ** 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 
223 C     ** 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 
231 C     ** 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         
240 C     ** Ecriture du champ n°1
241 C     ** - enregistre uniquement la composante n°2 de valr1_1
242 C     ** - 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 
253 C     ** Nouvelle Ecriture du champ reel en mode remplacement
254 C     ** - complete le champ precedent en enregistrant les composantes 1
255 C     ** - 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         
265 C     ** Ecriture sur le champ reel
266 C     ** - De la 1ere composante du tableau valr1_2
267 C     ** - Avec un pas de temps égal a 5.5
268 C     ** - Pas de numero d'ordre
269 C     ** - 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 
280 C     ** Ecriture sur le champ reel
281 C     ** - De la 2ere composante du tableau valr1_2
282 C     ** - Avec un pas de temps égal a 5.5
283 C     ** - Pas de numero d'ordre
284 C     ** - 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 
296 C     ** Ecriture sur le champ reel
297 C     ** - De la 1ere composante du tableau valr1_1
298 C     ** - Avec un pas de temps égal a 5.5
299 C     ** - Numero d'ordre egal a 2
300 C     ** - 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     
311 C     ** Creation de profil
312 C     ** - 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 
320 C     ** Ecriture du champ reel 
321 C     ** - Toutes les composantes du 2e element de valr1_1 (MED_ALL)
322 C     ** - Extrait a partir du profil de nom "profil1(1)"
323 C     ** - Pas de temps = 5.6
324 C     ** - 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 
335 C     ** Ecriture du champ reel
336 C     ** - Toutes les composantes du 2e element de valr1_1 (MED_ALL)
337 C     ** - Extrait a partir du profil de nom "profil1(1)"
338 C     ** - Pas de temps = 5.6
339 C     ** - 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 
351 C     ** Ecriture du champ reel 
352 C     ** - 2e composante du 2e element du champ
353 C     ** - Extrait a partir du profil de nom "profil1(1)"
354 C     ** - Pas de temps = 5.7
355 C     ** - 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 
367 C     ** Ecriture du champ entier n°2
368 C     ** - 1ere composante des éléments de valr2
369 C     ** - 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 
379 C     ** Ecriture du champ entier n°2
380 C     ** - 2ere composante des éléments de valr2
381 C     ** - pas de pas de temps, ni de numero d'ordre
382 C     ** - pour des raisons de complétude des tests on change
383 C     **   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 
393 C     ** Ecriture du champ entier n°2
394 C     ** - 3ere composante des éléments de valr2
395 C     ** - pas de pas de temps, ni de numero d'ordre
396 C     ** - pour des raisons de complétude des tests on change
397 C     **   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 
406 C     ** Creation de profil
407 C     ** - 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 
416 C     ** Ecriture du champ entier n°2
417 C     ** - 3eme composante des éléments de valr2
418 C     ** - pas de pas de temps, ni de numero d'ordre
419 C     ** - profils
420 C     ** - pour des raisons de complétude des tests on change
421 C     **   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 
431 C     ** 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  
438 C     ** Ecriture du champ entier n°3
439 C     ** - 1ere composante des éléments de valr3
440 C     ** - pas de pas de temps, ni de numero d'ordre
441 C     ** - pour des raisons de complétude des tests on change
442 C     **   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 
451 C     ** Ecriture du champ entier n°3
452 C     ** - les composantes des éléments de valr3
453 C     ** - pas de pas de temps, ni de numero d'ordre
454 C     ** - pour des raisons de complétude des tests on change
455 C     **   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 
465 C     ** Ecriture du champ entier n°3
466 C     ** - les composantes des éléments de valr3
467 C     ** - pas de pas de temps, ni de numero d'ordre
468 C     ** - profils
469 C     ** - pour des raisons de complétude des tests on change
470 C     **   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 
481 C     ** 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