1  C*************************************************************************
  2  C COPYRIGHT (C) 1999 - 2003  EDF R&D
  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      integer      mdim
 38      character*16 comp1(2), unit1(2)
 39      character*16 dtunit1
 40      integer      ncomp1
 41  C   MODEL N°1 DE LOC. DES PTS DE GAUSS PR CHAMP1
 42      integer      ngauss1_1
 43      character*32 gauss1_1
 44      real*8       refcoo1(12), gscoo1_1(12), wg1_1(6)
 45      integer      nval1_1
 46      real*8       valr1_1(1*6*2)
 47  C   MODEL N°2 DE LOC. DES PTS DE GAUSS PR CHAMP1
 48      integer      ngauss1_2
 49      character*32 gauss1_2
 50      real*8       gscoo1_2(6), wg1_2(3)
 51      integer      nval1_2
 52      real*8       valr1_2(2*3*2)
 53      real*8       valr1_2p(2*3)
 54  C   MODEL N°3 DE LOC. DES PTS DE GAUSS PR CHAMP1
 55      integer      ngauss1_3,nval1_3
 56      real*8       valr1_3(2*3*2)
 57      real*8       valr1_3p(2*2)
 58
 59  C   CHAMP N°2
 60      character*32 nomcha2
 61      character*16 comp2(3), unit2(3)
 62      integer      ncomp2, nval2
 63      integer      valr2(5*3),   valr2p(3*3)
 64
 65  C   PROFILS UTILISES
 66      character*32 nomprofil1
 67      integer      profil1(2) , profil2(3)
 68
 69      parameter (USER_INTERLACE = MED_FULL_INTERLACE)
 70      parameter (USER_MODE = MED_COMPACT )
 71      parameter ( a=0.446948490915965, b=0.091576213509771    )
 72      parameter ( p1=0.11169079483905, p2=0.0549758718227661  )
 73  C       MAILLAGES
 74      parameter ( maa1 = "maa1", maa2 = "maa2", maa3 = "maa3" )
 75      parameter ( lien_maa2= "./testfoo.med"                  )
 76  C       CHAMP N°1
 77      parameter ( nomcha1 = "champ reel" )
 78      parameter ( ncomp1 = 2 )
 79      parameter ( dtunit1 = "")
 80  C       MODEL N°1 DE LOC. DES PTS DE GAUSS PR CHAMP1
 81      parameter ( gauss1_1 = "Model n1" )
 82      parameter ( ngauss1_1 = 6 )
 83  C       MODEL N°2 DE LOC. DES PTS DE GAUSS PR CHAMP1
 84      parameter ( gauss1_2  = "Model n2" )
 85      parameter ( ngauss1_2 = 3 )
 86  C       MODEL N°3 DE LOC. DES PTS DE GAUSS PR CHAMP1
 87      parameter ( ngauss1_3 = 6 )
 88      parameter ( nval1_3 = 6 )
 89  C       CHAMP N°2
 90      parameter ( nomcha2="champ entier")
 91          parameter ( ncomp2 = 3, nval2= 5  )
 92  C       PROFILS
 93      parameter ( nomprofil1  = "PROFIL(champ(1))" )
 94
 95
 96  C       CHAMP N°1
 97      data comp1 /"comp1", "comp2"/
 98          data unit1 /"unit1","unit2"/
 99  C       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/
105  C       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 /
109  C       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   /
113  C       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 /
118  C       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      ygscoo1_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.0/3
146      gscoo1_2(2) =  1.0/3
147      gscoo1_2(3) = -2.0/3
148      gscoo1_2(4) = -2.0/3
149      gscoo1_2(5) =  1.0/3
150      gscoo1_2(6) = -2.0/3
151
152      wg1_2(1) =  2.0/3
153      wg1_2(2) =  2.0/3
154      wg1_2(3) =  2.0/3
155
156  C     ** ouverture du fichier                            **
157      call efouvr(fid,'test10.med',MED_CREATION, ret)
158      if (ret .ne. 0 ) then
159          print *,'Erreur à l''ouverture du fichier  : ','test10.med'
160          call efexit(-1)
161      endif
162
163  C     ** 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
171  C     ** 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
180  C     ** 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
187  C     ** 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
194  C     ** 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
201  C     ** 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
209  C     ** 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
218  C     ** Ecriture du champ 1
219  C     ** - enregistre uniquement la composante 2 de valr1_1
220  C     ** - pas de pas de temps, ni de numero d ordre
221      call efchae(fid,maa1,nomcha1,valr1_1,USER_INTERLACE,nval1_1,
222      1               gauss1_1,2,MED_NOPFL,MED_NO_PFLMOD,
223      2               MED_MAILLE,MED_TRIA6,
224      3               MED_NOPDT,dtunit1,0.0,MED_NONOR,ret)
225      if (ret .ne. 0 ) then
226         print *,'Erreur à l''écriture du champ : ', nomcha1,'et.1'
227         ret = -1
228      endif
229
230  C     ** Nouvelle Ecriture du champ reel en mode remplacement
231  C     ** - complete le champ precedent en enregistrant les composantes 1
232  C     ** - pas de pas de temps, ni de numero d ordre
233      call efchae(fid,maa1,nomcha1,valr1_1,USER_INTERLACE,nval1_1,
234      1               gauss1_1,1,MED_NOPFL,MED_NO_PFLMOD,
235      2               MED_MAILLE,MED_TRIA6,
236      3               MED_NOPDT,dtunit1,0.0,MED_NONOR,ret)
237      if (ret .ne. 0 ) then
238         print *,'Erreur à l''écriture du champ : ', nomcha1,'et.2'
239         ret = -1
240      endif
241
242  C     ** Ecriture sur le champ reel
243  C     ** - De la 1ere composante du tableau valr1_2
244  C     ** - Avec un pas de temps égal a 5.5
245  C     ** - Pas de numero d ordre
246  C     ** - maa2 est distant
247      dt = 5.5
248      call efchae(fid,maa2,nomcha1,valr1_2,USER_INTERLACE,nval1_2,
249       1               gauss1_2,1,MED_NOPFL,MED_NO_PFLMOD,
250       2               MED_MAILLE,MED_TRIA6,
251       3               1,"ms",dt,MED_NONOR,ret)
252      if (ret .ne. 0 ) then
253         print *,'Erreur à l''écriture du champ : ', nomcha1,'et.3'
254         ret = -1
255      endif
256
257  C     ** Ecriture sur le champ reel
258  C     ** - De la 2ere composante du tableau valr1_2
259  C     ** - Avec un pas de temps égal a 5.5
260  C     ** - Pas de numero d ordre
261  C     ** - maa1 est local
262      dt = 5.5
263      call efchae(fid,maa1,nomcha1,valr1_1,USER_INTERLACE,nval1_1,
264       1               gauss1_1,2,MED_NOPFL,MED_NO_PFLMOD,
265       2               MED_MAILLE,MED_TRIA6,
266       3               1,"ms",dt,MED_NONOR,ret)
267      if (ret .ne. 0 ) then
268         print *,'Erreur à l''écriture du champ : ', nomcha1,'et.4'
269         ret = -1
270      endif
271
272
273  C     ** Ecriture sur le champ reel
274  C     ** - De la 1ere composante du tableau valr1_1
275  C     ** - Avec un pas de temps égal a 5.5
276  C     ** - Numero d ordre egal a 2
277  C     ** - maa3 est local
278      dt = 5.5
279      call efchae(fid,maa3,nomcha1,valr1_2,USER_INTERLACE,nval1_2,
280       1               gauss1_2,1,MED_NOPFL,MED_NO_PFLMOD,
281       2               MED_MAILLE,MED_TRIA6,
282       3               1,"ms",dt,2,ret)
283      if (ret .ne. 0 ) then
284         print *,'Erreur à l''écriture du champ : ', nomcha1,'et.5'
285         ret = -1
286      endif
287
288  C     ** Creation de profil
289  C     ** - qui selectionne uniquement le 2e element du tableau valr1
290      call efpfle(fid,profil1,1,nomprofil1,ret)
291      if (ret .ne. 0 ) then
292         print *,'Erreur à la création du profil : ', nomprofil1
293         ret = -1
294      endif
295
296
297  C     ** Ecriture du champ reel
298  C     ** - Toutes les composantes du 2e element de valr1_1 (MED_ALL)
299  C     ** - Extrait a partir du profil de nom "profil1(1)"
300  C     ** - Pas de temps = 5.6
301  C     ** - Numero d ordre = 2
302      dt = 5.6
303      call efchae(fid,maa1,nomcha1,valr1_3p,USER_INTERLACE,nval1_3,
304       1               MED_NOGAUSS,MED_ALL,nomprofil1,USER_MODE,
305       2               MED_MAILLE,MED_TRIA6,
306       3               2,"ms",dt,2,ret)
307      if (ret .ne. 0 ) then
308         print *,'Erreur à l''écriture du champ : ', nomcha1,'et.6'
309         ret = -1
310      endif
311
312  C     ** Ecriture du champ reel
313  C     ** - Toutes les composantes du 2e element de valr1_1 (MED_ALL)
314  C     ** - Extrait a partir du profil de nom "profil1(1)"
315  C     ** - Pas de temps = 5.6
316  C     ** - Numero d ordre = 2
317      dt = 5.6
318      call efchae(fid,maa2,nomcha1,valr1_2p,USER_INTERLACE,nval1_2,
319       1               gauss1_2,MED_ALL,nomprofil1,USER_MODE,
320       2               MED_MAILLE,MED_TRIA6,
321       3               2,"ms",dt,2,ret)
322      if (ret .ne. 0 ) then
323         print *,'Erreur à l''écriture du champ : ', nomcha1,'et.7'
324         ret = -1
325      endif
326
327
328  C     ** Ecriture du champ reel
329  C     ** - 2e composante du 2e element du champ
330  C     ** - Extrait a partir du profil de nom "profil1(1)"
331  C     ** - Pas de temps = 5.7
332  C     ** - Numero d ordre = 2
333      dt = 5.7
334      call efchae(fid,maa1,nomcha1,valr1_3p,USER_INTERLACE,nval1_3,
335       1               MED_NOGAUSS,2,nomprofil1,USER_MODE,
336       2               MED_MAILLE,MED_TRIA6,
337       3               3,"ms",dt,2,ret)
338      if (ret .ne. 0 ) then
339         print *,'Erreur à l''écriture du champ : ', nomcha1,'et.8'
340         ret = -1
341      endif
342
343
344  C     ** Ecriture du champ entier n°2
345  C     ** - 1ere composante des éléments de valr2
346  C     ** - pas de pas de temps, ni de numero d ordre
347      call efchae(fid,maa1,nomcha2,valr2,USER_INTERLACE,nval2,
348       1     MED_NOGAUSS,1,MED_NOPFL,MED_NO_PFLMOD,MED_ARETE,
349       1               MED_SEG2,MED_NOPDT,"",0.0,MED_NONOR,ret)
350      if (ret .ne. 0 ) then
351         print *,'Erreur à l''écriture du champ : ', nomcha2,'et.1'
352         ret = -1
353      endif
354
355  C     ** Ecriture du champ entier n°2
356  C     ** - 2ere composante des éléments de valr2
357  C     ** - pas de pas de temps, ni de numero d ordre
358  C     ** - pour des raisons de complétude des tests on change
359  C     **   le type d élément (aucun sens phys.))
360      call efchae(fid,maa1,nomcha2,valr2,USER_INTERLACE,nval2,
361       1     MED_NOGAUSS,2,MED_NOPFL,MED_NO_PFLMOD,MED_NOEUD,
362       1               0,MED_NOPDT,"",0.0,MED_NONOR,ret)
363      if (ret .ne. 0 ) then
364        print *,'Erreur à l''écriture du champ : ', nomcha2,'et.2'
365        ret = -1
366      endif
367
368
369  C     ** Ecriture du champ entier n°2
370  C     ** - 3ere composante des éléments de valr2
371  C     ** - pas de pas de temps, ni de numero d'ordre
372  C     ** - pour des raisons de complétude des tests on change 
373  C     **   le type d'élément (aucun sens phys.))
374      call efchae(fid,maa1,nomcha2,valr2,USER_INTERLACE,nval2,
375       1     MED_NOGAUSS,3,MED_NOPFL,MED_NO_PFLMOD,MED_FACE,
376       1               MED_TRIA6,MED_NOPDT,"",0.0,MED_NONOR,ret)
377      if (ret .ne. 0 ) then
378         print *,'Erreur à l''écriture du champ : ', nomcha2,'et.3'
379         ret = -1
380      endif
381
382  C     ** Creation de profil
383  C     ** - selectionne les elements 1,3,5 du tableau valr2
384      call efpfle(fid,profil2,3,"PROFIL(champ2)",ret)
385      if (ret .ne. 0 ) then
386         print *,'Erreur à l''écriture du profil : ', 'profil2(champ2)'
387         ret = -1
388      endif
389
390
391  C     ** Ecriture du champ entier n°2
392  C     ** - 3eme composante des éléments de valr2
393  C     ** - pas de pas de temps, ni de numero d'ordre
394  C     ** - profils 
395  C     ** - pour des raisons de complétude des tests on change 
396  C     **   le type d'élément (aucun sens phys.))
397      call efchae(fid,maa1,nomcha2,valr2p,USER_INTERLACE,nval2,
398       1     MED_NOGAUSS,3,"PROFIL(champ2)",USER_MODE,MED_MAILLE,
399       1               MED_TRIA6,MED_NOPDT,"",0.0,MED_NONOR,ret)
400      if (ret .ne. 0 ) then
401         print *,'Erreur à l''écriture du profil : ', 'profil2(champ2)'
402         ret = -1
403      endif
404
405  C     ** Fermeture du fichier *
406      call efferm (fid,ret)
407      if (ret .ne. 0 ) then
408         print *,'Erreur à la fermeture du fichier : '
409         ret = -1
410      endif
411
412      print *,"Le code retour : ",ret
413      call efexit(ret)
414
415      end
416
417
418