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 : test13.f90
 21 ! *
 22 ! * - Description : lecture des equivalences dans un maillage MED.
 23 ! *
 24 ! ******************************************************************************
 25 
 26 program test13
 27 
 28   implicit none
 29   include 'med.hf'
 30 !
 31 !
 32   integer      ret,cret,fid
 33   character*32 maa
 34   integer      mdim,nequ,ncor
 35   integer, allocatable, dimension(:) :: cor
 36   character*32  equ
 37   character*200 des
 38   integer       i,j,k
 39   character*255 argc
 40   integer, parameter :: MED_NBR_MAILLE_EQU = 8
 41   integer,parameter  :: typmai(MED_NBR_MAILLE_EQU) =  (/ MED_POINT1,MED_SEG2,   &
 42                                                       &  MED_SEG3,MED_TRIA3,    &
 43                                                       &  MED_TRIA6,MED_QUAD4,   &
 44                                                       &  MED_QUAD8,MED_POLYGONE/)
 45 
 46    integer,parameter :: typfac(MED_NBR_GEOMETRIE_FACE+1) = (/MED_TRIA3,MED_TRIA6,       &
 47                                         &   MED_QUAD4,MED_QUAD8, MED_POLYGONE/)
 48    integer,parameter ::typare(MED_NBR_GEOMETRIE_ARETE) = (/MED_SEG2,MED_SEG3/)
 49    character*200 desc
 50    integer type
 51 
 52    print *,"Indiquez le fichier med a decrire : "
 53    !!read(*,*) argc
 54    argc = "test12.med"
 55 
 56    !  ** Ouverture du fichier en lecture seule **
 57    call efouvr(fid,argc,MED_LECTURE, cret)
 58    print *,cret
 59 
 60 
 61    !  ** Lecture des infos sur le premier maillage **
 62    if (cret.eq.0) then
 63       call efmaai(fid,1,maa,mdim,type,desc,cret)
 64       print *,"Maillage de nom : ",maa," et de dimension : ", mdim
 65    endif
 66    print *,cret
 67 
 68 
 69    !  ** Lecture du nombre d'equivalence  **
 70    if (cret.eq.0) then
 71       call efnequ(fid,maa,nequ,cret)
 72       if (cret.eq.0) then
 73          print *,"Nombre d'equivalences : ",nequ
 74       endif
 75    endif
 76 
 77    !** Lecture de toutes les equivalences **
 78    if (cret.eq.0) then
 79       do i=1,nequ
 80          print *,"Equivalence numero : ",i
 81          !** Lecture des infos sur l'equivalence **
 82          if (cret.eq.0) then
 83             call efequi(fid,maa,i,equ,des,cret)
 84          endif
 85          print *,cret
 86          if (cret.eq.0) then
 87             print *,"Nom de l'equivalence : ",equ
 88             print *,"Description de l'equivalence : ",des
 89          endif
 90 
 91          !** Lecture des correspondances sur les differents types d'entites **
 92          if (cret.eq.0) then
 93             !** Les noeuds **
 94             call efncor(fid,maa,equ,MED_NOEUD,0,ncor,cret)
 95             print *,"Il y a ",ncor," correspondances sur les noeuds "
 96             if (ncor > 0) then
 97                allocate(cor(ncor*2),STAT=ret)
 98                call efequl(fid,maa,equ,cor,ncor,MED_NOEUD,0,cret)
 99                do j=0,(ncor-1)
100                   print *,"Correspondance ",j+1," : ",cor(2*j+1)," et ",cor(2*j+2)
101                end do
102                deallocate(cor)
103             end if
104         
105             !** Les mailles : on ne prend pas en compte les mailles 3D **
106 
107             do j=1,MED_NBR_MAILLE_EQU
108                call efncor(fid,maa,equ,MED_MAILLE,typmai(j),ncor,cret)
109                print *,"Il y a ",ncor," correspondances sur les mailles ",typmai(j)
110                if (ncor > 0 ) then
111                   allocate(cor(2*ncor),STAT=ret)
112                   call efequl(fid,maa,equ,cor,ncor,MED_MAILLE,typmai(j),cret)
113                   do k=0,(ncor-1)
114                      print *,"Correspondance ",k+1," : ",cor(2*k+1)," et ",cor(2*k+2)
115                   end do
116                   deallocate(cor)
117                endif
118             end do
119 
120             ! ** Les faces **
121             do j=1,MED_NBR_GEOMETRIE_FACE+1
122                call efncor(fid,maa,equ,MED_FACE,typfac(j),ncor,cret)
123                print *,"Il y a ",ncor," correspondances sur les faces ",typfac(j)
124                if (ncor > 0 ) then
125                   allocate(cor(2*ncor),STAT=ret)
126                   call efequl(fid,maa,equ,cor,ncor,MED_FACE,typfac(j),cret)
127                   do k=0,(ncor-1)
128                      print *,"Correspondance ",k+1," : ",cor(2*k+1)," et ",cor(2*k+2)
129                   end do
130                   deallocate(cor)
131                endif
132             end do
133 
134             ! **  Les aretes **
135             do j=1,MED_NBR_GEOMETRIE_ARETE
136                call efncor(fid,maa,equ,MED_ARETE,typare(j),ncor,cret)
137                print *,"Il y a ",ncor," correspondances sur les aretes ",typare(j)
138                if (ncor > 0 ) then
139                   allocate(cor(2*ncor),STAT=ret)
140                   call efequl(fid,maa,equ,cor,ncor,MED_ARETE,typare(j),cret)
141                   do k=0,(ncor-1)
142                      print *,"Correspondance ",k+1," : ",cor(2*k+1)," et ",cor(2*k+2)
143                   end do
144                   deallocate(cor)
145                endif
146             end do
147 
148          end if
149       end do
150    end if
151 
152 !  ** Fermeture du fichier   **
153    call efferm (fid,cret)
154    print *,cret
155 
156 !  ** Code retour
157    call efexit(cret)
158 
159  end program test13
160         
161 
162 
163 
164