1 !*************************************************************************
  2 ! COPYRIGHT (C) 1999 - 2007  EDF R&D, CEA/DEN
  3 ! THIS LIBRARY IS FREE SOFTWARE; YOU CAN REDISTRIBUTE IT AND/OR MODIFY
  4 ! IT UNDER THE TERMS OF THE GNU LESSER GENERAL PUBLIC LICENSE 
  5 ! AS PUBLISHED BY THE FREE SOFTWARE FOUNDATION; 
  6 ! EITHER VERSION 2.1 OF THE LICENSE, OR (AT YOUR OPTION) ANY LATER VERSION.
  7 !
  8 ! THIS LIBRARY IS DISTRIBUTED IN THE HOPE THAT IT WILL BE USEFUL, BUT
  9 ! WITHOUT ANY WARRANTY; WITHOUT EVEN THE IMPLIED WARRANTY OF
 10 ! MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. SEE THE GNU
 11 ! LESSER GENERAL PUBLIC LICENSE FOR MORE DETAILS.
 12 !
 13 ! YOU SHOULD HAVE RECEIVED A COPY OF THE GNU LESSER GENERAL PUBLIC LICENSE
 14 ! ALONG WITH THIS LIBRARY; IF NOT, WRITE TO THE FREE SOFTWARE FOUNDATION,
 15 ! INC., 59 TEMPLE PLACE, SUITE 330, BOSTON, MA 02111-1307 USA
 16 !
 17 !**************************************************************************
 18 
 19 ! ******************************************************************************
 20 ! * - Nom du fichier : test9.f90
 21 ! *
 22 ! * - Description : lecture des familles d'un maillage MED 
 23 ! *
 24 ! ******************************************************************************
 25 program test9
 26 
 27   implicit none
 28   include 'med.hf'
 29 !
 30   integer        ret,cret,fid
 31   character*32   maa
 32   integer        mdim
 33   integer        nfam
 34   integer        i,j
 35   integer        natt,ngro
 36   character*200, allocatable, dimension (:) :: attdes
 37   character*80,  allocatable, dimension (:) :: gro
 38   integer,       allocatable, dimension (:) :: attval,attide
 39   character*32   nomfam
 40   character*200  desc
 41   integer        numfam
 42   integer        type
 43 
 44 
 45 !  ** Ouverture du fichier test8.med en lecture seule **
 46   call efouvr(fid,'test8.med',MED_LECTURE, cret)
 47   print *,cret
 48 
 49 !  ** Lecture des infos sur le 1er maillage **
 50   if (cret.eq.0) then
 51      call efmaai(fid,1,maa,mdim,type,desc,cret)
 52      print *,"Maillage de nom : ",maa," et de dimension : ", mdim
 53   endif
 54   print *,cret
 55 
 56 !  ** Lecture du nombre de famille **
 57   if (cret .eq. 0) then
 58      call efnfam(fid,maa,nfam,cret)
 59      print *,' Nombre de familles a lire : ',nfam
 60   endif
 61   print *,cret
 62 
 63 !  ** Lecture de chaque famille **
 64   if (cret .eq. 0) then
 65      do i=1,nfam
 66 
 67 !       ** Lecture du nombre de groupe **
 68         if (cret .eq. 0) then
 69            call efngro(fid,maa,i,ngro,cret)
 70         endif
 71         print *,cret
 72 
 73 !       ** Lecture du nombre d'attribut **
 74         if (cret .eq. 0) then
 75            call efnatt(fid,maa,i,natt,cret)
 76         endif
 77         print *,cret
 78 
 79         print *,"Famille ",i," a ",natt," attributs et ",ngro," groupes "
 80 
 81 !       ** Lecture de : nom,numero,attributs,groupes **
 82         if (cret .eq. 0) then
 83            allocate(attide(natt),attval(natt),attdes(natt),gro(ngro),STAT=ret)
 84 !              print *,ret
 85 
 86            call effami(fid,maa,i,nomfam,numfam,attide,     &
 87                 &                     attval,attdes,natt,gro,ngro,cret)
 88            print *,cret
 89            print *,"Famille de nom ",nomfam," et de numero ",numfam
 90            print *,"Attributs :"
 91            do j=1,natt
 92               print *,"ide = ",attide(j)," - val = ",attval(j)," - des = ",attdes(j)
 93            enddo
 94            deallocate(attide,attval,attdes)
 95 
 96            do j=1,ngro
 97               print *,"gro = ",gro(j)
 98            enddo
 99            deallocate(gro)
100         endif
101      enddo
102   endif
103 
104 
105 !  ** Fermeture du fichier                                           **
106      call efferm (fid,cret)
107      print *,cret
108 
109 !  ** Code retour
110      call efexit(cret)
111 
112    end program test9
113 
114