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