      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