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 : 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       nfame, nfamn
 41          character*16   str
 42
 43          parameter  ( mdim = 2, nfame = 3, nfamn = 2 )
 44          data       maa /"maa1"/
 45
 46  C       ** Creation du fichier test8.med                       **
 47          call efouvr(fid,'test8.med',MED_CREATION, cret)
 48          print *,cret
 49
 50  C       ** Creation du maillage maa de dimension 2         **
 51          if (cret .eq. 0) then
 52         call efmaac(fid,maa,mdim,MED_NON_STRUCTURE,
 53       &                 'un maillage pour test8',cret)
 54          endif
 55          print *,cret
 56
 57  C       ** Ecriture des familles                           **
 58  C           ** Conventions :
 59  C           - Toujours creer une famille de numero 0 ne comportant aucun attribut
 60  C           ni groupe (famille de reference pour les noeuds ou les elements
 61  C           qui ne sont rattaches a aucun groupe ni attribut)
 62  C           - Les numeros de familles de noeuds sont > 0
 63  C           - Les numeros de familles des elements sont < 0
 64  C           - Rien d imposer sur les noms de familles
 65  C        **                                                 **
 66
 67  C       ** Creation de la famille 0
 68          if (cret .eq. 0) then
 69             numfam = 0
 70             nomfam="FAMILLE_0"
 71             call effamc(fid,maa,nomfam,numfam,attide,attval,attdes,
 72       &          0,gro,0,cret)
 73          endif
 74          print *,cret
 75
 76  C       ** Creation pour correspondre aux cas tests precedents, 3 familles  *
 77  C       **  d elements (-1,-2,-3) et deux familles de noeuds (1,2)         *
 78          if (cret .eq. 0) then
 79             do numfam=-1,-3,-1
 80                if (cret .eq. 0) then
 81                   write(str,'(I1.0)') (-numfam)
 82                   nomfam = "FAMILLE_ELEMENT_"//str
 83                   attide = 1
 84                   attval = numfam*100
 85                   natt = 1
 86                   attdes="description attribut"
 87                   gro="groupe1"
 88                   ngro = 1
 89                   print *, nomfam," - ",numfam," - ",attide," - ",
 90       &                attval," - ",ngro
 91
 92                   call effamc(fid,maa,nomfam,numfam,attide,attval,attdes,
 93       &                natt,gro,ngro,cret)
 94                   print *,"MEDfamCr : ",cret
 95                endif
 96             end do
 97          end if
 98
 99          if (cret .eq. 0) then
100             do numfam=1,nfamn
101                if (cret .eq. 0) then
102                   write(str,'(I1.0)') numfam
103                   nomfam = "FAMILLE_NOEUD_"//str
104                   attide = 1
105                   attval = numfam*100
106                   natt = 1
107                   attdes="description attribut"
108                   gro="groupe1"
109                   ngro = 1
110                   print *, nomfam," - ",numfam," - ",attide," - ",
111       &                attval," - ",ngro
112                   call effamc(fid,maa,nomfam,numfam,attide,attval,attdes,
113       &                natt,gro,ngro,cret)
114                   print *,"MEDfamCr : ",cret
115
116                endif
117             end do
118           end if
119
120
121  C     ** Fermeture du fichier *
122        call efferm (fid,cret)
123        print *,cret
124
125
126        end
127
128
129
130
131
132