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 - 2017 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 cret, fid
31
32 integer mdim,nse2,ntr3,sdim
33 parameter(nse2=5, ntr3=2, mdim=2, sdim=2)
34 integer se2 (2*nse2)
35 character*16 nomse2(nse2)
36 integer numse2(nse2),nufase2(nse2)
37
38 character*16 nomcoo(2)
39 character*16 unicoo(2)
40
41
42 integer tr3 (3*ntr3)
43 character*16 nomtr3(ntr3)
44 integer numtr3(ntr3), nufatr3(ntr3)
45 character*64 maa
46 real*8 dt
47 parameter(dt = 0.0)
48
49 data nomcoo /"x","y"/, unicoo /"cm","cm"/
50 data se2 / 1,2,1,3,2,4,3,4,2,3 /
51 data nomse2 /"se1","se2","se3","se4","se5" /
52 data numse2 / 1,2,3,4,5 /, nufase2 /-1,-1,0,-2,-3/
53 data tr3 /1,2,-5,-5,3,-4 /, nomtr3 /"tr1","tr2"/,
54 & numtr3 /4,5/
55 data nufatr3 /0,-1/, maa /"maa1"/
56
57 C ** Ouverture du fichier
58 call mfiope(fid,'test6.med',med_acc_rdwr, cret)
59 print *,cret
60 if (cret .ne. 0 ) then
61 print *,'Erreur creation du fichier'
62 call efexit(-1)
63 endif
64
65 C ** Creation du maillage maa de dimension 2 **
66 call mmhcre(fid,maa,mdim,sdim,
67 & med_unstructured_mesh,'un maillage pour test6',
68 & "",med_sort_dtit,med_cartesian,nomcoo,unicoo,cret)
69 print *,cret
70 if (cret .ne. 0 ) then
71 print *,'Erreur creation du maillage'
72 call efexit(-1)
73 endif
74
75 C ** Ecriture des connectivites des segments **
76 call mmhcyw(fid,maa,med_no_dt,med_no_it,dt,
77 & med_descending_edge,med_seg2,med_descending,
78 & med_no_interlace,nse2,se2,cret)
79 print *,cret
80 if (cret .ne. 0 ) then
81 print *,'Erreur ecriture de la connectivite'
82 call efexit(-1)
83 endif
84
85 C ** Ecriture (optionnelle) des noms des segments **
86 call mmheaw(fid,maa,med_no_dt,med_no_it,med_descending_edge,
87 & med_seg2,nse2,nomse2,cret)
88 print *,cret
89 if (cret .ne. 0 ) then
90 print *,'Erreur ecriture des noms'
91 call efexit(-1)
92 endif
93
94 C ** Ecriture (optionnelle) des numeros des segments **
95 call mmhenw(fid,maa,med_no_dt,med_no_it,med_descending_edge,
96 & med_seg2,nse2,numse2,cret)
97 print *,cret
98 if (cret .ne. 0 ) then
99 print *,'Erreur ecriture des numeros'
100 call efexit(-1)
101 endif
102
103 C ** Ecriture des numeros des familles des segments **
104 call mmhfnw(fid,maa,med_no_dt,med_no_it,med_descending_edge,
105 & med_seg2,nse2,nufase2,cret)
106 print *,cret
107 if (cret .ne. 0 ) then
108 print *,'Erreur ecriture des numéros de famille'
109 call efexit(-1)
110 endif
111
112 C ** Ecriture des connectivites des triangles **
113 call mmhcyw(fid,maa,med_no_dt,med_no_it,dt,
114 & med_cell,med_tria3,med_descending,
115 & med_no_interlace,ntr3,tr3,cret)
116 print *,cret
117 if (cret .ne. 0 ) then
118 print *,'Erreur ecriture de la connectivite'
119 call efexit(-1)
120 endif
121
122 C ** Ecriture (optionnelle) des noms des triangles **
123 call mmheaw(fid,maa,med_no_dt,med_no_it,med_cell,
124 & med_tria3,ntr3,nomtr3,cret)
125 print *,cret
126 if (cret .ne. 0 ) then
127 print *,'Erreur ecriture des noms'
128 call efexit(-1)
129 endif
130
131 C ** Ecriture (optionnelle) des numeros des triangles **
132 call mmhenw(fid,maa,med_no_dt,med_no_it,med_cell,
133 & med_tria3,ntr3,numtr3,cret)
134 print *,cret
135 if (cret .ne. 0 ) then
136 print *,'Erreur ecriture des numeros'
137 call efexit(-1)
138 endif
139
140 C ** Ecriture des numeros des familles des triangles **
141 call mmhfnw(fid,maa,med_no_dt,med_no_it,med_cell,
142 & med_tria3,ntr3,nufatr3,cret)
143 print *,cret
144 if (cret .ne. 0 ) then
145 print *,'Erreur ecriture des numeros de famille'
146 call efexit(-1)
147 endif
148
149 C ** Fermeture du fichier **
150 call mficlo(fid,cret)
151 print *,cret
152 if (cret .ne. 0 ) then
153 print *,'Erreur a la fermeture du fichier'
154 call efexit(-1)
155 endif
156 C
157 end