1!*  This file is part of MED.
2!*
3!*  COPYRIGHT (C) 1999 - 2019  EDF R&D, CEA/DEN
4!*  MED is free software: you can redistribute it and/or modify
5!*  it under the terms of the GNU Lesser General Public License as published by
6!*  the Free Software Foundation, either version 3 of the License, or
7!*  (at your option) any later version.
8!*
9!*  MED is distributed in the hope that it will be useful,
10!*  but WITHOUT ANY WARRANTY; without even the implied warranty of
11!*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
12!*  GNU Lesser General Public License for more details.
13!*
14!*  You should have received a copy of the GNU Lesser General Public License
15!*  along with MED.  If not, see <http://www.gnu.org/licenses/>.
16!*
17
18! ******************************************************************************
19! * - Nom du fichier : test7.f90
20! *
21! * - Description : lecture des elements du maillage MED ecrits par test6
22! *
23! ******************************************************************************
24      program test7
25
26      implicit none
27      include 'med.hf90'
28!
29!
30      integer*8 fid
31      integer cret, ret
32
33      integer nse2
34      integer,     allocatable, dimension (:) :: se2,se21
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*64  :: maa
45      character*200 :: desc
46      integer       :: mdim,edim,nstep,stype,atype
47      logical inoele,inuele
48      integer, parameter :: profil (2) = (/ 2,3 /)
49      integer type
50      integer tse2,ttr3, i
51      character*16 nomcoo(2)
52      character*16 unicoo(2)
53      character*16 dtunit
54      integer :: chgt,tsf
55      integer flta(1)
56      integer*8 flt(1)
57
58!   ** Ouverture du fichier test6.med en lecture seule       **
59      call mfiope(fid,'test6.med',MED_ACC_RDONLY, cret)
60      print *,cret
61
62!   ** Lecture des infos concernant le premier maillage      **
63      if (cret.eq.0) then
64         call mmhmii(fid,1,maa,edim,mdim,type,desc,dtunit,stype,nstep,atype,nomcoo,unicoo,cret)
65         print *,"Maillage de nom : ",maa," et de dimension :", mdim
66      endif
67      if (cret.ne.0) then
68         call efexit(-1)
69      endif
70!   ** Combien de segments et de triangles                   **
71      if (cret.eq.0) then
72         nse2 = 0
73         call mmhnme(fid,maa,MED_NO_DT,MED_NO_IT,MED_DESCENDING_EDGE,MED_SEG2,MED_CONNECTIVITY,MED_DESCENDING,chgt,tsf,nse2,cret)
74      endif
75      if (cret.ne.0) then
76         call efexit(-1)
77      endif
78
79      if (cret.eq.0) then
80         ntr3 = 0
81         call mmhnme(fid,maa,MED_NO_DT,MED_NO_IT,MED_CELL,MED_TRIA3,MED_CONNECTIVITY,MED_DESCENDING,chgt,tsf,ntr3,cret)
82      endif
83      if (cret.ne.0) then
84         call efexit(-1)
85      endif
86
87      if (cret.eq.0) then
88         print *,"Nombre de MED_SEG2 : ",nse2," - nombre de MED_TRIA3 : ",ntr3
89      endif
90
91!   ** Allocations memoire                                 **
92      tse2 = 2
93      allocate (se2(tse2*nse2),se21(tse2*nse2),nomse2(nse2),numse2(nse2), nufase2(nse2),STAT=ret )
94      se2(:)=0; se21(:)=0
95!      print *,ret
96
97      ttr3 = 3
98      allocate (tr3(ntr3*ttr3), nomtr3(ntr3), numtr3(ntr3),nufatr3(ntr3),STAT=ret )
99      tr3(:)=0
100!      print *,ret
101
102
103!   ** Lecture de la connectivite des segments           **
104      if (cret.eq.0) then
105	call mmhcyr(fid,maa,MED_NO_DT,MED_NO_IT,MED_DESCENDING_EDGE,MED_SEG2,MED_DESCENDING,MED_FULL_INTERLACE,se2,cret)
106      endif
107      if (cret.ne.0) then
108         call efexit(-1)
109      endif
110      print *,se2
111
112!    ** Lecture de de la composante 2 de la connectivite des segments           **
113!    ** On cree un filtre  associe
114     if (cret .eq. 0) then
115        call mfrall(1,flt,cret)
116     endif
117     if (cret.ne.0) then
118        call efexit(-1)
119     endif
120
121!    ** on initialise le filtre pour lire uniquement la deuxième composante.
122     if (cret .eq. 0) then
123        call mfrcre(fid,nse2,1,edim,2,MED_FULL_INTERLACE,MED_GLOBAL_STMODE, &
124                    MED_NO_PROFILE,MED_UNDEF_SIZE,flta,flt(1),cret)
125     endif
126     if (cret.ne.0) then
127        call efexit(-1)
128     endif
129
130!   ** Lecture des composantes n°2 des segments
131     if (cret.eq.0) then
132	call mmhyar(fid,maa,MED_NO_DT,MED_NO_IT,MED_DESCENDING_EDGE,MED_SEG2,MED_DESCENDING, &
133                    flt(1),se21,cret)
134     endif
135     if (cret.ne.0) then
136        call efexit(-1)
137     endif
138     print *,se21
139
140!   ** On desalloue le filtre
141     if (cret .eq. 0) then
142        call mfrdea(1,flt,cret)
143     endif
144     if (cret.ne.0) then
145        call efexit(-1)
146     endif
147
148!   ** Lecture (optionnelle) des noms des segments         **
149      if (cret.eq.0) then
150         call mmhear(fid,maa,MED_NO_DT,MED_NO_IT,MED_DESCENDING_EDGE,MED_SEG2,nomse2,cret)
151      endif
152
153      if (ret <0) then
154         inoele = .FALSE.
155      else
156         inoele = .TRUE.
157      endif
158
159!  ** Lecture (optionnelle) des numeros des segments       **
160      if (cret.eq.0) then
161         call mmhenr(fid,maa,MED_NO_DT,MED_NO_IT,MED_DESCENDING_EDGE,MED_SEG2,numse2,cret)
162     endif
163
164     if (ret <0) then
165        inuele = .FALSE.
166     else
167        inuele = .TRUE.
168     endif
169
170!  ** Lecture des numeros des familles des segments         **
171     if (cret.eq.0) then
172        call mmhfnr(fid,maa,MED_NO_DT,MED_NO_IT,MED_DESCENDING_EDGE,MED_SEG2,nufase2,cret)
173      endif
174     if (cret.ne.0) then
175        call efexit(-1)
176     endif
177
178!  ** Lecture de la connectivite des triangles sans profil **
179      if (cret.eq.0) then
180	call mmhcyr(fid,maa,MED_NO_DT,MED_NO_IT,MED_CELL,MED_TRIA3,MED_DESCENDING,MED_NO_INTERLACE,tr3,cret)
181      endif
182     if (cret.ne.0) then
183        call efexit(-1)
184     endif
185
186!  ** Lecture (optionnelle) des noms des triangles          **
187      if (cret.eq.0) then
188         call mmhear(fid,maa,MED_NO_DT,MED_NO_IT,MED_CELL,MED_TRIA3,nomtr3,cret)
189      endif
190
191      if (ret <0) then
192         inoele = .FALSE.
193      else
194         inoele = .TRUE.
195      endif
196      print *,cret
197
198!  ** Lecture (optionnelle) des numeros des segments       **
199      if (cret.eq.0) then
200        call mmhenr(fid,maa,MED_NO_DT,MED_NO_IT,MED_CELL,MED_TRIA3,numtr3,cret)
201     endif
202
203     if (ret <0) then
204        inuele = .FALSE.
205     else
206        inuele = .TRUE.
207     endif
208     print *,cret
209
210!  ** Lecture des numeros des familles des segments         **
211     if (cret.eq.0) then
212        call mmhfnr(fid,maa,MED_NO_DT,MED_NO_IT,MED_CELL,MED_TRIA3,nufatr3,cret)
213      endif
214      print *,cret
215
216!  ** Fermeture du fichier                                           **
217     call mficlo(fid,cret)
218     if (cret.ne.0) then
219        call efexit(-1)
220     endif
221
222!  ** Affichage des resulats                                         **
223     if (cret.eq.0) then
224
225        print *,"Connectivite des segments : "
226        print *, se2
227
228        if (inoele) then
229           print *,"Noms des segments :"
230           print *,nomse2
231        endif
232
233        if (inuele) then
234           print *,"Numeros des segments :"
235           print *,numse2
236        endif
237
238        print *,"Numeros des familles des segments :"
239        print *,nufase2
240
241        print *,"Connectivite des triangles :"
242        print *,tr3
243
244        if (inoele) then
245           print *,"Noms des triangles :"
246           print *,nomtr3
247        endif
248
249        if (inuele) then
250           print *,"Numeros des triangles :"
251           print *,numtr3
252        endif
253
254        print *,"Numeros des familles des triangles :"
255        print *,nufatr3
256
257     endif
258
259!  ** Nettoyage memoire                                          **
260      deallocate (se2,se21,nomse2,numse2,nufase2,tr3,nomtr3,numtr3,nufatr3)
261
262!  ** Code retour
263      call efexit(cret)
264
265    end program test7
266
267