MED fichier
test13.f90
Aller à la documentation de ce fichier.
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 : test13.f90
20 ! *
21 ! * - Description : lecture des equivalences dans un maillage MED.
22 ! *
23 ! ******************************************************************************
24 
25 program test13
26 
27  implicit none
28  include 'med.hf90'
29 !
30 !
31  integer*8 fid
32  integer ret,cret
33  character*64 maa
34  integer mdim,nequ,ncor,sdim
35  integer, allocatable, dimension(:) :: cor
36  character*64 equ
37  character*200 desc,des
38  integer i,j,k
39  character*255 argc
40  integer,parameter :: MY_NOF_DESCENDING_FACE_TYPE = 5
41  integer,parameter :: MY_NOF_DESCENDING_EDGE_TYPE = 2
42 
43 
44  integer, parameter :: MED_NBR_MAILLE_EQU = 8
45  integer,parameter :: typmai(med_nbr_maille_equ) = (/ med_point1,med_seg2, &
46  & med_seg3,med_tria3, &
47  & med_tria6,med_quad4, &
48  & med_quad8,med_polygon/)
49 
50  integer,parameter :: typfac(my_nof_descending_face_type) = (/med_tria3,med_tria6, &
51  & med_quad4,med_quad8, med_polygon/)
52  integer,parameter ::typare(my_nof_descending_edge_type) = (/med_seg2,med_seg3/)
53  integer type
54  character(16) :: dtunit
55  integer nstep, stype, atype
56  character*16 nomcoo(3)
57  character*16 unicoo(3)
58  integer nctcor,nstepc
59 
60 
61  ! ** Ouverture du fichier en lecture seule **
62  call mfiope(fid,'test12.med',med_acc_rdonly, cret)
63  print *,cret
64 
65 
66  ! ** Lecture des infos sur le premier maillage **
67  if (cret.eq.0) then
68  call mmhmii(fid,1,maa,sdim,mdim,type,desc,dtunit,stype,nstep,atype,nomcoo,unicoo,cret)
69  print *,"Maillage de nom : ",maa," et de dimension : ", mdim
70  endif
71  print *,cret
72 
73 
74  ! ** Lecture du nombre d'equivalence **
75  if (cret.eq.0) then
76  call meqneq(fid,maa,nequ,cret)
77  if (cret.eq.0) then
78  print *,"Nombre d'equivalence : ",nequ
79  endif
80  endif
81 
82 
83  !** Lecture de toutes les equivalences **
84  if (cret.eq.0) then
85  do i=1,nequ
86  print *,"Equivalence numero : ",i
87  !** Lecture des infos sur l'equivalence **
88  if (cret.eq.0) then
89  call meqeqi(fid,maa,i,equ,des,nstepc,nctcor,cret)
90  endif
91  print *,cret
92  if (cret.eq.0) then
93  print *,"Nom de l'equivalence : ",equ
94  print *,"Description de l'equivalence : ",des
95  print *,"Nombre de pas de temps sur l'equivalence : ",nstepc
96  print *,"Nombre de correspondance sur MED_NO_IT, MED_NO_DT : ", nctcor
97  endif
98 
99  !** Lecture des correspondances sur les differents types d'entites **
100  if (cret.eq.0) then
101  !** Les noeuds **
102  call meqcsz(fid,maa,equ,med_no_dt,med_no_it,med_node,med_none,ncor,cret)
103  print *,cret
104  print *,"Il y a ",ncor," correspondances sur les noeuds "
105  if (ncor > 0) then
106  allocate(cor(ncor*2),stat=ret)
107  call meqcor(fid,maa,equ,med_no_dt,med_no_it,med_node,med_none,cor,cret)
108  do j=0,(ncor-1)
109  print *,"Correspondance ",j+1," : ",cor(2*j+1)," et ",cor(2*j+2)
110  end do
111  deallocate(cor)
112  end if
113 
114 !!$ !** Les mailles : on ne prend pas en compte les mailles 3D **
115 
116  do j=1,med_nbr_maille_equ
117  call meqcsz(fid,maa,equ,med_no_dt,med_no_it,med_cell,typmai(j),ncor,cret)
118  print *,"Il y a ",ncor," correspondances sur les mailles ",typmai(j)
119  if (ncor > 0 ) then
120  allocate(cor(2*ncor),stat=ret)
121  call meqcor(fid,maa,equ,med_no_dt,med_no_it,med_cell,typmai(j),cor,cret)
122  do k=0,(ncor-1)
123  print *,"Correspondance ",k+1," : ",cor(2*k+1)," et ",cor(2*k+2)
124  end do
125  deallocate(cor)
126  endif
127  end do
128 
129 !!$ ! ** Les faces **
130  do j=1,my_nof_descending_face_type
131  call meqcsz(fid,maa,equ,med_no_dt,med_no_it,med_descending_face,typmai(j),ncor,cret)
132  print *,"Il y a ",ncor," correspondances sur les faces ",typfac(j)
133  if (ncor > 0 ) then
134  allocate(cor(2*ncor),stat=ret)
135  call meqcor(fid,maa,equ,med_no_dt,med_no_it,med_descending_face,typfac(j),cor,cret)
136  do k=0,(ncor-1)
137  print *,"Correspondance ",k+1," : ",cor(2*k+1)," et ",cor(2*k+2)
138  end do
139  deallocate(cor)
140  endif
141  end do
142 
143 !!$ ! ** Les aretes **
144  do j=1,my_nof_descending_edge_type
145  call meqcsz(fid,maa,equ,med_no_dt,med_no_it,med_descending_edge,typare(j),ncor,cret)
146  print *,"Il y a ",ncor," correspondances sur les aretes ",typare(j)
147  if (ncor > 0 ) then
148  allocate(cor(2*ncor),stat=ret)
149  call meqcor(fid,maa,equ,med_no_dt,med_no_it,med_descending_edge,typare(j),cor,cret)
150  do k=0,(ncor-1)
151  print *,"Correspondance ",k+1," : ",cor(2*k+1)," et ",cor(2*k+2)
152  end do
153  deallocate(cor)
154  endif
155  end do
156 
157  end if
158  end do
159  end if
160 
161 ! ** Fermeture du fichier **
162  call mficlo(fid,cret)
163  print *,cret
164 
165 ! ** Code retour
166  call efexit(cret)
167 
168  end program test13
169 
170 
171 
172 
173 
subroutine meqcsz(fid, maa, eq, numdt, numit, typent, typgeo, n, cret)
program test13
Definition: test13.f90:25
subroutine meqeqi(fid, maa, ind, eq, des, nstep, nctcor, cret)
subroutine mmhmii(fid, it, name, sdim, mdim, mtype, desc, dtunit, stype, nstep, atype, aname, aunit, cret)
Definition: medmesh.f:110
subroutine mfiope(fid, name, access, cret)
Definition: medfile.f:42
subroutine meqneq(fid, maa, n, cret)
subroutine mficlo(fid, cret)
Definition: medfile.f:82
subroutine meqcor(fid, maa, eq, numdt, mumit, typent, typgeo, corr, cret)