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 : test8.f
 21 C *
 22 C * - Description : exemple d'ecriture des familles d'un maillage MED
 23 C *
 24 C *****************************************************************************
 25         program test8
 26 C
 27         implicit none
 28         include 'med.hf'
 29 C
 30         integer cret, fid
 31 
 32         character*32  maa
 33         integer       mdim
 34         character*32  nomfam
 35         integer       numfam
 36         character*200 attdes
 37         integer       natt, attide, attval
 38         integer       ngro
 39         character*80  gro
 40         integer       nfamn
 41         character*16   str
 42 
 43         parameter  ( mdim = 2, nfamn = 2 )
 44         data       maa /"maa1"/
 45 
 46 C     ** Creation du fichier test8.med                       **
 47         call efouvr(fid,'test8.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 
 54 C     ** Creation du maillage maa de dimension 2         **
 55         call efmaac(fid,maa,mdim,MED_NON_STRUCTURE,
 56      &                 'un maillage pour test8',cret)
 57         print *,cret
 58         if (cret .ne. 0 ) then
 59            print *,'Erreur creation du maillage'
 60            call efexit(-1)
 61         endif
 62 
 63 C     ** Ecriture des familles                           **
 64 C     * Conventions :
 65 C       - Toujours creer une famille de numero 0 ne comportant aucun attribut
 66 C         ni groupe (famille de reference pour les noeuds ou les elements
 67 C         qui ne sont rattaches a aucun groupe ni attribut)
 68 C       - Les numeros de familles de noeuds sont > 0
 69 C       - Les numeros de familles des elements sont < 0
 70 C       - Rien d'imposer sur les noms de familles
 71 C     **                                                 **
 72 
 73 C     * Creation de la famille 0                                     **
 74         numfam = 0
 75         nomfam="FAMILLE_0"
 76         call effamc(fid,maa,nomfam,numfam,attide,attval,attdes,
 77      &          0,gro,0,cret)  
 78         print *,cret
 79         if (cret .ne. 0 ) then
 80            print *,'Erreur creation de la famille 0'
 81            call efexit(-1)
 82         endif      
 83 
 84 C  * Creation pour correspondre aux cas tests precedents, 3 familles  *
 85 C  *  d'elements (-1,-2,-3) et deux familles de noeuds (1,2)         *
 86         do numfam=-1,-3,-1
 87            write(str,'(I1.0)') (-numfam)
 88            nomfam = "FAMILLE_ELEMENT_"//str
 89            attide = 1
 90            attval = numfam*100
 91            natt = 1
 92            attdes="description attribut"
 93            gro="groupe1"
 94            ngro = 1
 95            print *, nomfam," - ",numfam," - ",attide," - ",
 96      &                attval," - ",ngro
 97 
 98            call effamc(fid,maa,nomfam,numfam,attide,attval,attdes,
 99      &                natt,gro,ngro,cret)
100            print *,cret
101            if (cret .ne. 0 ) then
102               print *,'Erreur creation de famille'
103               call efexit(-1)
104            endif
105         end do
106 
107         do numfam=1,nfamn
108            write(str,'(I1.0)') numfam
109            nomfam = "FAMILLE_NOEUD_"//str
110            attide = 1
111            attval = numfam*100
112            natt = 1
113            attdes="description attribut"
114            gro="groupe1"
115            ngro = 1
116            print *, nomfam," - ",numfam," - ",attide," - ",
117      &                attval," - ",ngro
118            call effamc(fid,maa,nomfam,numfam,attide,attval,attdes,
119      &                natt,gro,ngro,cret)
120            print *,cret
121            if (cret .ne. 0 ) then
122               print *,'Erreur creation de famille'
123               call efexit(-1)
124            endif
125         end do
126 
127 
128 C     * Fermeture du fichier *
129         call efferm (fid,cret)
130         print *,cret
131         if (cret .ne. 0 ) then
132            print *,'Erreur fermeture du fichier'
133            call efexit(-1)
134         endif
135 C
136         end
137 
138 
139 
140 
141 
142