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 : 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 : ",ntr3
 80       endif
 81 
 82 !   ** Allocations memoire                                 **
 83       tse2 = 2
 84       allocate ( se2(tse2*nse2), nomse2(nse2),numse2(nse2), nufase2(nse2),STAT=ret )
 85 !      print *,ret
 86 
 87       ttr3 = 3
 88       allocate ( tr3(ntr3*ttr3), nomtr3(ntr3), numtr3(ntr3),nufatr3(ntr3),STAT=ret )
 89 !      print *,ret
 90 
 91 
 92 !   ** Lecture de la connectivite des segments avec profil           **   
 93       if (cret.eq.0) then
 94          call efconl(fid,maa,mdim,se2,MED_NO_INTERLACE,profil,2,MED_ARETE, &
 95      &               MED_SEG2,MED_DESC,cret)
 96       endif
 97       print *,cret
 98       print *,se2
 99 
100 !   ** Lecture (optionnelle) des noms des segments         **
101       if (cret.eq.0) then
102          call efnoml(fid,maa,nomse2,nse2,MED_ARETE,         &
103      &               MED_SEG2,ret)
104       endif
105 
106       if (ret <0) then
107          inoele = .FALSE.
108       else
109          inoele = .TRUE.
110       endif
111 
112 !  ** Lecture (optionnelle) des numeros des segments       **
113       if (cret.eq.0) then
114          call efnuml(fid,maa,numse2,nse2,MED_ARETE,MED_SEG2,ret)
115      endif
116 
117      if (ret <0) then
118         inuele = .FALSE.
119      else
120         inuele = .TRUE.
121      endif
122 
123 !  ** Lecture des numeros des familles des segments         **
124      if (cret.eq.0) then
125          call effaml(fid,maa,nufase2,nse2,MED_ARETE,MED_SEG2,cret)
126       endif
127       print *,cret
128 
129 !  ** Lecture de la connectivite des triangles sans profil **
130       if (cret.eq.0) then
131          call efconl(fid,maa,mdim,tr3,MED_NO_INTERLACE,profil,0,MED_MAILLE, &
132      &               MED_TRIA3,MED_DESC,cret)
133       endif
134       print *,cret
135 
136 !  ** Lecture (optionnelle) des noms des triangles          **
137       if (cret.eq.0) then
138          call efnoml(fid,maa,nomtr3,ntr3,MED_MAILLE,         &
139      &               MED_TRIA3,ret)
140       endif
141 
142       if (ret <0) then
143          inoele = .FALSE.
144       else
145          inoele = .TRUE.
146       endif
147       print *,cret
148 
149 !  ** Lecture (optionnelle) des numeros des segments       **
150       if (cret.eq.0) then
151          call efnuml(fid,maa,numtr3,ntr3,MED_MAILLE,MED_TRIA3,ret)
152      endif
153 
154      if (ret <0) then
155         inuele = .FALSE.
156      else
157         inuele = .TRUE.
158      endif
159      print *,cret
160 
161 !  ** Lecture des numeros des familles des segments         **
162      if (cret.eq.0) then
163          call effaml(fid,maa,nufatr3,ntr3,MED_MAILLE,MED_TRIA3,cret)
164       endif
165       print *,cret
166 
167 !  ** Fermeture du fichier                                           **
168      call efferm (fid,cret)
169      print *,cret
170 
171 !  ** Affichage des resulats                                         **
172      if (cret.eq.0) then
173 
174         print *,"Connectivite des segments : "
175         print *, se2
176 
177         if (inoele) then
178            print *,"Noms des segments :"
179            print *,nomse2
180         endif
181 
182         if (inuele) then
183            print *,"Numeros des segments :"
184            print *,numse2
185         endif
186 
187         print *,"Numeros des familles des segments :"
188         print *,nufase2
189 
190         print *,"Connectivite des triangles :"
191         print *,tr3
192 
193         if (inoele) then
194            print *,"Noms des triangles :"
195            print *,nomtr3
196         endif
197 
198         if (inuele) then
199            print *,"Numeros des triangles :"
200            print *,numtr3
201         endif
202 
203         print *,"Numeros des familles des triangles :"
204         print *,nufatr3
205 
206      endif
207 
208 !  ** Nettoyage memoire                                          **
209       deallocate (se2,nomse2,numse2,nufase2,tr3,nomtr3,numtr3,nufatr3)
210 
211 !  ** Code retour
212       call efexit(cret)
213 
214     end program test7
215