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 : test23.f
 21 C       *
 22 C       * - Description : ecriture de mailles MED_POLYGONE dans un maillage MED
 23 C       *
 24 C       ******************************************************************************
 25         program test23
 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 ni, n
 34         parameter (ni=4, n=3)
 35         integer index(ni)
 36         character*16 nom(n)
 37         integer num(n),fam(n)
 38         integer con(16)
 39 C
 40         data con  / 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16 /
 41         data nom  / "poly1", "poly2", "poly3"/
 42         data num  / 1,2,3 /, fam /0,-1,-2/
 43         data index /1,6,12,17/
 44         data maa /"maa1"/
 45 
 46 C       ** Creation du fichier test23.med                   **
 47         call efouvr(fid,'test23.med',MED_LECTURE_ECRITURE, cret)
 48         print *,cret
 49         if (cret .ne. 0 ) then
 50            print *,'Erreur creation du fichier'
 51            call efexit(-1)
 52         endif
 53         print *,'Creation du fichier test23.med'
 54 
 55 C       ** Creation du maillage          **
 56         call efmaac(fid,maa,mdim,MED_NON_STRUCTURE,
 57      &                 'un maillage pour test23',cret)
 58         print *,cret
 59         if (cret .ne. 0 ) then
 60            print *,'Erreur creation du maillage'
 61            call efexit(-1)
 62         endif
 63         print *,'Creation du maillage'
 64 
 65 C       ** Ecriture de la connectivite des mailles polygones **
 66         call efpgce(fid,maa,index,ni,con,MED_MAILLE,MED_NOD,cret)
 67         if (cret .ne. 0 ) then
 68            print *,'Erreur ecriture des connectivite polygones'
 69            call efexit(-1)
 70         endif
 71         print *,cret
 72         print *,'Ecriture des connectivites des mailles de type
 73      & MED_POLYGONE'
 74 
 75 C       ** Ecriture des noms des mailles polygones          **
 76         call efnome(fid,maa,nom,n,MED_MAILLE,MED_POLYGONE,
 77      &                 cret)
 78         print *,cret
 79         if (cret .ne. 0 ) then
 80            print *,'Erreur ecriture des noms polygones'
 81            call efexit(-1)
 82         endif
 83         print *,'Ecriture des noms des polygones'
 84 
 85 C       ** Ecriture des numeros des mailles polygones **
 86         call efnume(fid,maa,num,n,MED_MAILLE,MED_POLYGONE,
 87      &                 cret)
 88         if (cret .ne. 0 ) then
 89            print *,'Erreur ecriture des numeros polygones'
 90            call efexit(-1)
 91         endif
 92         print *,cret
 93         print *,'Ecriture des numeros des polygones'
 94 
 95 C       ** Ecriture des numeros des familles des segments  **
 96         call effame(fid,maa,fam,n,
 97      &              MED_MAILLE,MED_POLYGONE,cret)
 98         if (cret .ne. 0 ) then
 99            print *,'Erreur ecriture des numeros de famille polygones'
100            call efexit(-1)
101         endif
102         print *,cret
103         print *,'Ecriture des numeros de familles des polygones'
104 
105 C       ** Fermeture du fichier                            **
106         call efferm (fid,cret)
107         print *,cret
108         if (cret .ne. 0 ) then
109            print *,'Erreur fermeture du fichier'
110            call efexit(-1)
111         endif
112         print *,'Fermeture du fichier'
113 C
114         end