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 : 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,15,16,17,18,19,20,21,22,23,24 /
 51          data indexp2 / 1,5,9 /
 52          data indexf2 / MED_TRIA3,MED_TRIA3,MED_TRIA3,MED_TRIA3,MED_TRIA3,MED_TRIA3,MED_TRIA3,MED_TRIA3 /
 53          data conn2 / 1,2,3,4,5,6,7,8 /
 54          data nom  / "poly1", "poly2"/
 55          data num  / 1,2 /, fam / 0,-1 /
 56          data maa /"maa1"/
 57
 58  C       ** Creation du fichier test25.med  **
 59          call efouvr(fid,'test25.med',MED_CREATION, cret)
 60          print *,cret
 61          print *,'Creation du fichier test25.med'
 62
 63  C       ** Creation du maillage          **
 64          if (cret .eq. 0) then
 65            call efmaac(fid,maa,mdim,MED_NON_STRUCTURE,
 66       &                 'un maillage pour test25',cret)
 67          endif
 68          print *,cret
 69          print *,'Creation du maillage'
 70
 71  C       ** Ecriture des connectivites des mailles polyedres en mode nodal **
 72          if (cret .eq. 0) then
 73            call efpece(fid,maa,indexp,np,indexf,nf,conn,MED_NOD,cret)
 74          endif
 75          print *,cret
 76          print *,'Ecriture des connectivites des mailles de type MED_POLYEDRE'
 77          print *,'Description nodale'
 78
 79  C       ** Ecriture des connectivites des mailles polyedres en mode descendant **
 80          if (cret .eq. 0) then
 81            call efpece(fid,maa,indexp2,np2,indexf2,nf2,conn2,MED_DESC,cret)
 82          endif
 83          print *,cret
 84          print *,'Ecriture des connectivites des mailles de type MED_POLYEDRE'
 85          print *,'Description descendante'
 86
 87  C       ** Ecriture des noms des mailles polyedres          **
 88          if (cret .eq. 0) then
 89              call efnome(fid,maa,nom,n,MED_MAILLE,MED_POLYEDRE,
 90       &                 cret)
 91          endif
 92          print *,cret
 93          print *,'Ecriture des noms des polyedress'
 94
 95  C       ** Ecriture des numeros des mailles polyedres **
 96          if (cret .eq. 0) then
 97              call efnume(fid,maa,num,n,MED_MAILLE,MED_POLYEDRE,
 98       &                 cret)
 99          endif
100          print *,cret
101          print *,'Ecriture des numeros des polyedres'
102
103  C       ** Ecriture des numeros des familles des segments  **
104          if (cret .eq. 0) then
105              call effame(fid,maa,fam,n,
106       &              MED_MAILLE,MED_POLYEDRE,cret)
107          endif
108          print *,cret
109          print *,'Ecriture des numeros de familles des polyedres'
110
111  C       ** Fermeture du fichier                            **
112          call efferm (fid,cret)
113          print *,cret
114          print *,'Fermeture du fichier'
115
116          end