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 : test25.f
 21 C       *
 22 C       * - Description : ecriture de mailles MED_POLYEDRE dans un maillage MED
 23 C       *
 24 C       ******************************************************************************
 25         program test25
 26 C
 27         implicit none
 28         include 'med.hf'
 29 C       
 30         integer cret, fid,mdim
 31         parameter  (mdim = 3)
 32         character*32 maa       
 33         integer n
 34         parameter (n=2)
 35 C       Connectivite nodale
 36         integer np,nf
 37         parameter (nf=9,np=3)
 38         integer indexp(np),indexf(nf)
 39         integer conn(24)
 40 C       Connectivite descendante
 41         integer np2,nf2
 42         parameter (nf2=8,np2=3)
 43         integer indexp2(np2),indexf2(nf2)
 44         integer conn2(nf2)
 45         character*16 nom(n)
 46         integer num(n),fam(n)
 47 C
 48         data indexp / 1,5,9 /
 49         data indexf / 1,4,7,10,13,16,19,22,25 /
 50         data conn / 1,2,3,4,5,6,7,8,9,10,11,12,13,14,
 51      &              15,16,17,18,19,20,21,22,23,24 /
 52         data indexp2 / 1,5,9 /
 53         data indexf2 / MED_TRIA3,MED_TRIA3,MED_TRIA3,MED_TRIA3,
 54      &                 MED_TRIA3,MED_TRIA3,MED_TRIA3,MED_TRIA3 /
 55         data conn2 / 1,2,3,4,5,6,7,8 /
 56         data nom  / "poly1", "poly2"/
 57         data num  / 1,2 /, fam / 0,-1 /
 58         data maa /"maa1"/
 59 
 60 C       ** Creation du fichier test25.med  **
 61         call efouvr(fid,'test25.med',MED_LECTURE_ECRITURE, cret)
 62         print *,cret
 63         if (cret .ne. 0 ) then
 64            print *,'Erreur creation du fichier'
 65            call efexit(-1)
 66         endif
 67         print *,'Creation du fichier test25.med'
 68 
 69 C       ** Creation du maillage          **
 70         call efmaac(fid,maa,mdim,MED_NON_STRUCTURE,
 71      &                 'un maillage pour test25',cret)
 72         if (cret .ne. 0 ) then
 73            print *,'Erreur creation du maillage'
 74            call efexit(-1)
 75         endif
 76         print *,cret
 77         print *,'Creation du maillage'
 78 
 79 C       ** Ecriture des connectivites des mailles polyedres en mode nodal **
 80         call efpece(fid,maa,indexp,np,indexf,nf,conn,MED_NOD,cret)
 81         print *,cret
 82         if (cret .ne. 0 ) then
 83            print *,'Erreur ecriture connectivite des polyedres'
 84            call efexit(-1)
 85         endif
 86         print *,'Ecriture des connectivites des mailles
 87      & de type MED_POLYEDRE'
 88         print *,'Description nodale'
 89 
 90 C       ** Ecriture des connectivites des mailles polyedres en mode descendant **
 91         call efpece(fid,maa,indexp2,np2,indexf2,nf2,conn2,MED_DESC,cret)
 92         print *,cret
 93         if (cret .ne. 0 ) then
 94            print *,'Erreur ecriture connectivite des polyedres'
 95            call efexit(-1)
 96         endif
 97         print *,'Ecriture des connectivites des mailles 
 98      & de type MED_POLYEDRE'
 99         print *,'Description descendante'
100 
101 C       ** Ecriture des noms des mailles polyedres          **
102         call efnome(fid,maa,nom,n,MED_MAILLE,MED_POLYEDRE,
103      &                 cret)
104         print *,cret
105         if (cret .ne. 0 ) then
106            print *,'Erreur ecriture noms des polyedres'
107            call efexit(-1)
108         endif
109         print *,'Ecriture des noms des polyedress'
110 
111 C       ** Ecriture des numeros des mailles polyedres **
112         call efnume(fid,maa,num,n,MED_MAILLE,MED_POLYEDRE,
113      &                 cret)
114         print *,cret
115         if (cret .ne. 0 ) then
116            print *,'Erreur ecriture numeros des polyedres'
117            call efexit(-1)
118         endif
119         print *,'Ecriture des numeros des polyedres'
120 
121 C       ** Ecriture des numeros des familles des segments  **
122         call effame(fid,maa,fam,n,
123      &              MED_MAILLE,MED_POLYEDRE,cret)
124         print *,cret
125         if (cret .ne. 0 ) then
126            print *,'Erreur ecriture numeros de familles polyedres'
127            call efexit(-1)
128         endif
129         print *,'Ecriture des numeros de familles des polyedres'
130 
131 C       ** Fermeture du fichier                            **
132         call efferm (fid,cret)
133         print *,cret
134         if (cret .ne. 0 ) then
135            print *,'Erreur fermeture du fichier'
136            call efexit(-1)
137         endif
138         print *,'Fermeture du fichier'
139 C
140         end