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 : test7.f90
 21  ! *
 22  ! * - Description : lecture des elements du maillage MED ecrits par test6
 23  ! *
 24  ! ******************************************************************************
 25        program test7
 26
 27        implicit none
 28        include 'med.hf'
 29  !     
 30  !           
 31        integer cret, ret, fid
 32
 33        integer nse2
 34        integer,     allocatable, dimension (:) :: se2
 35        character*16, allocatable, dimension (:) :: nomse2
 36        integer,     allocatable, dimension (:) :: numse2,nufase2
 37
 38        integer ntr3
 39        integer,     allocatable, dimension (:) :: tr3
 40        character*16, allocatable, dimension (:) :: nomtr3
 41        integer,     allocatable, dimension (:) :: numtr3,nufatr3
 42
 43  !     ** nom du maillage de longueur maxi MED_TAILLE_NOM    **
 44        character*32  :: maa  = "maa1"
 45        character*200 :: desc
 46        integer       :: mdim
 47        logical inoele,inuele
 48        integer, parameter :: profil (2) = (/ 2,3 /)
 49        integer type
 50        integer tse2,ttr3, i
 51
 52  !   ** Ouverture du fichier test6.med en lecture seule       **
 53        call efouvr(fid,'test6.med',MED_LECTURE, cret)
 54        print *,cret
 55
 56  !   ** Lecture des infos concernant le premier maillage      **
 57        if (cret.eq.0) then
 58           call efmaai(fid,1,maa,mdim,type,desc,cret)
 59           print *,"Maillage de nom : ",maa," et de dimension :", mdim
 60        endif
 61        print *,cret
 62
 63  !   ** Combien de segments et de triangles                   **
 64        if (cret.eq.0) then
 65           nse2 = 0
 66           call efnema(fid,maa,MED_CONN,MED_ARETE,MED_SEG2,MED_DESC,        &
 67       &        nse2,cret)
 68        endif
 69        print *,cret
 70
 71        if (cret.eq.0) then
 72           ntr3 = 0
 73           call efnema(fid,maa,MED_CONN,MED_MAILLE,MED_TRIA3,MED_DESC,        &
 74       &        ntr3,cret)
 75        endif
 76        print *,cret
 77
 78        if (cret.eq.0) then
 79           print *,"Nombre de MED_SEG2 : ",nse2," - nombre de MED_TRIA3 "
 80       &            ,ntr3
 81        endif
 82
 83  !   ** Allocations memoire                                 **
 84        tse2 = 2
 85        allocate (se2(tse2*nse2),nomse2(nse2),numse2(nse2),nufase2(nse2),
 86       &          STAT=ret )
 87  !     print *,ret
 88
 89        ttr3 = 3
 90        allocate (tr3(ntr3*ttr3),nomtr3(ntr3),numtr3(ntr3),nufatr3(ntr3),
 91       &           STAT=ret )
 92  !     print *,ret
 93
 94
 95  !   ** Lecture de la connectivite des segments avec profil           **   
 96        if (cret.eq.0) then
 97           call efconl(fid,maa,mdim,se2,MED_NO_INTERLACE,profil,2,MED_ARETE, &
 98       &               MED_SEG2,MED_DESC,cret)
 99        endif
100        print *,cret
101        print *,se2
102
103  !   ** Lecture (optionnelle) des noms des segments         **
104        if (cret.eq.0) then
105           call efnoml(fid,maa,nomse2,nse2,MED_ARETE,         &
106       &               MED_SEG2,ret)
107        endif
108
109        if (ret <0) then
110           inoele = .FALSE.
111        else
112           inoele = .TRUE.
113        endif
114
115  !  ** Lecture (optionnelle) des numeros des segments       **
116        if (cret.eq.0) then
117           call efnuml(fid,maa,numse2,nse2,MED_ARETE,MED_SEG2,ret)
118        endif
119
120        if (ret <0) then
121          inuele = .FALSE.
122        else
123          inuele = .TRUE.
124        endif
125
126  !  ** Lecture des numeros des familles des segments         **
127        if (cret.eq.0) then
128           call effaml(fid,maa,nufase2,nse2,MED_ARETE,MED_SEG2,cret)
129        endif
130        print *,cret
131
132  !  ** Lecture de la connectivite des triangles sans profil **
133        if (cret.eq.0) then
134           call efconl(fid,maa,mdim,tr3,MED_NO_INTERLACE,profil,0,MED_MAILLE, &
135       &               MED_TRIA3,MED_DESC,cret)
136        endif
137        print *,cret
138
139  !  ** Lecture (optionnelle) des noms des triangles          **
140        if (cret.eq.0) then
141           call efnoml(fid,maa,nomtr3,ntr3,MED_MAILLE,         &
142       &               MED_TRIA3,ret)
143        endif
144
145        if (ret <0) then
146           inoele = .FALSE.
147        else
148           inoele = .TRUE.
149        endif
150        print *,cret
151
152  !  ** Lecture (optionnelle) des numeros des segments       **
153        if (cret.eq.0) then
154           call efnuml(fid,maa,numtr3,ntr3,MED_MAILLE,MED_TRIA3,ret)
155        endif
156
157        if (ret <0) then
158          inuele = .FALSE.
159        else
160          inuele = .TRUE.
161        endif
162        print *,cret
163
164  !  ** Lecture des numeros des familles des segments         **
165        if (cret.eq.0) then
166           call effaml(fid,maa,nufatr3,ntr3,MED_MAILLE,MED_TRIA3,cret)
167        endif
168        print *,cret
169
170  !  ** Fermeture du fichier                                           **
171        call efferm (fid,cret)
172        print *,cret
173
174  !  ** Affichage des resulats                                         **
175        if (cret.eq.0) then
176
177          print *,"Connectivite des segments : "
178          print *, se2
179
180          if (inoele) then
181             print *,"Noms des segments :"
182             print *,nomse2
183          endif
184
185          if (inuele) then
186             print *,"Numeros des segments :"
187             print *,numse2
188          endif
189
190          print *,"Numeros des familles des segments :"
191          print *,nufase2
192
193          print *,"Connectivite des triangles :"
194          print *,tr3
195
196          if (inoele) then
197             print *,"Noms des triangles :"
198             print *,nomtr3
199          endif
200
201          if (inuele) then
202             print *,"Numeros des triangles :"
203             print *,numtr3
204          endif
205
206          print *,"Numeros des familles des triangles :"
207          print *,nufatr3
208
209        endif
210
211  !  ** Nettoyage memoire                                          **
212        deallocate (se2,nomse2,numse2,nufase2,tr3,nomtr3,numtr3,nufatr3)
213
214        end program test7
215