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 : test4.f
 21 C       *
 22 C       * - Description : ecriture des noeuds d'un maillage MED.
 23 C       *
 24 C       *****************************************************************************
 25         program test4
 26 C       
 27         implicit none
 28         include 'med.hf'
 29 C       
 30 C       
 31         integer cret, fid
 32         
 33 C       ** la dimension du maillage                         **
 34         integer      mdim
 35 C       ** nom du maillage de longueur maxi MED_TAILLE_NOM  **
 36         character*32 maa
 37 C       ** le nombre de noeuds                              **
 38         integer      nnoe 
 39 C       ** table des coordonnees                            **
 40 C       profil : (dimension * nombre de noeuds) ici 8       **
 41         real*8       coo(8)
 42 C       ** tables des noms et des unites des coordonnees    **
 43 C           profil : (dimension)                            **
 44         character*16 nomcoo(2)
 45         character*16 unicoo(2)
 46 C       ** tables des noms, numeros, numeros de familles des noeuds  **
 47 C       autant d'elements que de noeuds - les noms ont pout longueur **
 48 C       MED_TAILLE_PNOM                                              **
 49         character*16 nomnoe(4)
 50         integer     numnoe(4)
 51         integer     nufano(4)
 52         
 53         parameter    ( mdim = 2, maa = "maa1",nnoe = 4 )
 54         data  coo    /0.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0/
 55         data  nomcoo /"x","y"/, unicoo /"cm","cm"/
 56         data  nomnoe /"nom1","nom2","nom3","nom4"/
 57         data  numnoe /1,2,3,4/, nufano /0,1,2,2/
 58 
 59 C       ** Creation du fichier test4.med          **
 60         call efouvr(fid,'test4.med',MED_LECTURE_ECRITURE, cret)
 61         print *,cret
 62         if (cret .ne. 0 ) then
 63            print *,'Erreur creation du fichier'
 64            call efexit(-1)
 65         endif
 66         
 67 C       ** Creation du maillage maa de dimension 2 **
 68 C       **  et de type MED_NON_STRUCTURE           **
 69         call efmaac(fid,maa,mdim,MED_NON_STRUCTURE,
 70      &                 'un maillage pour test4',cret)
 71         print *,cret
 72         if (cret .ne. 0 ) then
 73            print *,'Erreur creation du maillage'
 74            call efexit(-1)
 75         endif
 76         
 77 C       ** Ecriture des coordonnees en mode MED_FULL_INTERLACE : **
 78 C       ** (X1,Y1, X2,Y2, X3,Y3, ...)  dans un repere cartesien **
 79         call efcooe(fid,maa,mdim,coo,MED_FULL_INTERLACE,
 80      &     nnoe,MED_CART,nomcoo,unicoo,cret)
 81         print *,cret
 82         if (cret .ne. 0 ) then
 83            print *,'Erreur ecriture des coordonnees des noeuds'
 84            call efexit(-1)
 85         endif
 86         
 87 C       ** Ecriture des noms des noeuds (optionnel dans un maillage MED) **
 88         call efnome(fid,maa,nomnoe,nnoe,MED_NOEUD,0,cret)
 89         print *,cret
 90         if (cret .ne. 0 ) then
 91            print *,'Erreur ecriture des noms des noeuds'
 92            call efexit(-1)
 93         endif
 94         
 95 C       ** Ecriture des numeros des noeuds (optionnel dans un maillage MED) **
 96         call efnume(fid,maa,numnoe,nnoe,MED_NOEUD,0,cret)
 97         print *,cret
 98         if (cret .ne. 0 ) then
 99            print *,'Erreur ecriture des numeros des noeuds'
100          call efexit(-1)
101         endif
102         
103 
104 C       ** Ecriture des numeros de familles des noeuds **       
105         call effame(fid,maa,nufano,nnoe,MED_NOEUD,0,cret)
106         print *,cret
107         if (cret .ne. 0 ) then
108            print *,'Erreur ecriture des numeros de famille'
109            call efexit(-1)
110         endif
111 
112 C       ** Fermeture du fichier **
113         call efferm (fid,cret)
114         print *,cret
115         if (cret .ne. 0 ) then
116            print *,'Erreur fermeture du fichier'
117            call efexit(-1)
118         endif
119         
120         end
121 
122 
123 
124