MED fichier: f/test6.f

MED fichier

- Documentation MED
- Guides d'utilisation
- Guides de référence

f/test6.f
1 C* This file is part of MED.
2 C*
3 C* COPYRIGHT (C) 1999 - 2019 EDF R&D, CEA/DEN
4 C* MED is free software: you can redistribute it and/or modify
5 C* it under the terms of the GNU Lesser General Public License as published by
6 C* the Free Software Foundation, either version 3 of the License, or
7 C* (at your option) any later version.
8 C*
9 C* MED is distributed in the hope that it will be useful,
10 C* but WITHOUT ANY WARRANTY; without even the implied warranty of
11 C* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 C* GNU Lesser General Public License for more details.
13 C*
14 C* You should have received a copy of the GNU Lesser General Public License
15 C* along with MED. If not, see <http://www.gnu.org/licenses/>.
16 C*
17
18 C *******************************************************************************
19 C * - Nom du fichier : test6.f
20 C *
21 C * - Description : exemples d'ecriture d'elements dans un maillage MED
22 C *
23 C ******************************************************************************
24 program test6
25 C
26 implicit none
27 include 'med.hf'
28 C
29 C
30 integer*8 fid
31 integer cret
32
33 integer mdim,nse2,ntr3,sdim
34 parameter(nse2=5, ntr3=2, mdim=2, sdim=2)
35 integer se2 (2*nse2)
36 character*16 nomse2(nse2)
37 integer numse2(nse2),nufase2(nse2)
38
39 character*16 nomcoo(2)
40 character*16 unicoo(2)
41
42
43 integer tr3 (3*ntr3)
44 character*16 nomtr3(ntr3)
45 integer numtr3(ntr3), nufatr3(ntr3)
46 character*64 maa
47 real*8 dt
48 parameter(dt = 0.0)
49
50 data nomcoo /"x","y"/, unicoo /"cm","cm"/
51 data se2 / 1,2,1,3,2,4,3,4,2,3 /
52 data nomse2 /"se1","se2","se3","se4","se5" /
53 data numse2 / 1,2,3,4,5 /, nufase2 /-1,-1,0,-2,-3/
54 data tr3 /1,2,-5,-5,3,-4 /, nomtr3 /"tr1","tr2"/,
55 & numtr3 /4,5/
56 data nufatr3 /0,-1/, maa /"maa1"/
57
58 C ** Ouverture du fichier
59 call mfiope(fid,'test6.med',med_acc_rdwr, cret)
60 print *,cret
61 if (cret .ne. 0 ) then
62 print *,'Erreur creation du fichier'
63 call efexit(-1)
64 endif
65
66 C ** Creation du maillage maa de dimension 2 **
67 call mmhcre(fid,maa,mdim,sdim,
68 & med_unstructured_mesh,'un maillage pour test6',
69 & "",med_sort_dtit,med_cartesian,nomcoo,unicoo,cret)
70 print *,cret
71 if (cret .ne. 0 ) then
72 print *,'Erreur creation du maillage'
73 call efexit(-1)
74 endif
75
76 C ** Ecriture des connectivites des segments **
77 call mmhcyw(fid,maa,med_no_dt,med_no_it,dt,
78 & med_descending_edge,med_seg2,med_descending,
79 & med_no_interlace,nse2,se2,cret)
80 print *,cret
81 if (cret .ne. 0 ) then
82 print *,'Erreur ecriture de la connectivite'
83 call efexit(-1)
84 endif
85
86 C ** Ecriture (optionnelle) des noms des segments **
87 call mmheaw(fid,maa,med_no_dt,med_no_it,med_descending_edge,
88 & med_seg2,nse2,nomse2,cret)
89 print *,cret
90 if (cret .ne. 0 ) then
91 print *,'Erreur ecriture des noms'
92 call efexit(-1)
93 endif
94
95 C ** Ecriture (optionnelle) des numeros des segments **
96 call mmhenw(fid,maa,med_no_dt,med_no_it,med_descending_edge,
97 & med_seg2,nse2,numse2,cret)
98 print *,cret
99 if (cret .ne. 0 ) then
100 print *,'Erreur ecriture des numeros'
101 call efexit(-1)
102 endif
103
104 C ** Ecriture des numeros des familles des segments **
105 call mmhfnw(fid,maa,med_no_dt,med_no_it,med_descending_edge,
106 & med_seg2,nse2,nufase2,cret)
107 print *,cret
108 if (cret .ne. 0 ) then
109 print *,'Erreur ecriture des numéros de famille'
110 call efexit(-1)
111 endif
112
113 C ** Ecriture des connectivites des triangles **
114 call mmhcyw(fid,maa,med_no_dt,med_no_it,dt,
115 & med_cell,med_tria3,med_descending,
116 & med_no_interlace,ntr3,tr3,cret)
117 print *,cret
118 if (cret .ne. 0 ) then
119 print *,'Erreur ecriture de la connectivite'
120 call efexit(-1)
121 endif
122
123 C ** Ecriture (optionnelle) des noms des triangles **
124 call mmheaw(fid,maa,med_no_dt,med_no_it,med_cell,
125 & med_tria3,ntr3,nomtr3,cret)
126 print *,cret
127 if (cret .ne. 0 ) then
128 print *,'Erreur ecriture des noms'
129 call efexit(-1)
130 endif
131
132 C ** Ecriture (optionnelle) des numeros des triangles **
133 call mmhenw(fid,maa,med_no_dt,med_no_it,med_cell,
134 & med_tria3,ntr3,numtr3,cret)
135 print *,cret
136 if (cret .ne. 0 ) then
137 print *,'Erreur ecriture des numeros'
138 call efexit(-1)
139 endif
140
141 C ** Ecriture des numeros des familles des triangles **
142 call mmhfnw(fid,maa,med_no_dt,med_no_it,med_cell,
143 & med_tria3,ntr3,nufatr3,cret)
144 print *,cret
145 if (cret .ne. 0 ) then
146 print *,'Erreur ecriture des numeros de famille'
147 call efexit(-1)
148 endif
149
150 C ** Fermeture du fichier **
151 call mficlo(fid,cret)
152 print *,cret
153 if (cret .ne. 0 ) then
154 print *,'Erreur a la fermeture du fichier'
155 call efexit(-1)
156 endif
157 C
158 end