      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