MED fichier: Fichier source de UsesCase_MEDfield_4.f

MED fichier

UsesCase_MEDfield_4.f
Aller à la documentation de ce fichier.
1 C* This file is part of MED.
2 C*
3 C* COPYRIGHT (C) 1999 - 2023 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 *
20 C * Field use case 4 : write a field with computing steps
21 C *
22 C *****************************************************************************
23 program usescase_medfield_4
24 C
25 implicit none
26 include 'med.hf77'
27 C
28 C
29 integer cret
30 integer*8 fid
31
32 C component number, node number
33 integer ncompo
34 C triangular elements number, quadrangular elements number
35 integer ntria3, nquad4
36 C med file name, link file name
37 character*64 fname, lfname
38 C mesh name, field name, component name, commponent unit
39 character*64 mname, finame, cpname, cpunit
40 character*16 dtunit
41 real*8 dt
42 integer ndt, nit
43 C mesh num dt, mesh num it
44 integer mnumdt, mnumit
45 C
46 real*8 t3vs1(8)
47 real*8 t3vs2(8)
48 real*8 q4vs1(4)
49 real*8 q4vs2(4)
50 C
51 parameter(fname = "UsesCase_MEDfield_4.med")
52 parameter(lfname = "./UsesCase_MEDmesh_1.med")
53 parameter(mname = "2D unstructured mesh")
54 parameter(finame = "TEMPERATURE_FIELD")
55 parameter(cpname ="TEMPERATURE", cpunit = "C")
56 parameter(dtunit = "ms")
57 parameter(ncompo = 1 )
58 parameter(ntria3 = 8, nquad4 = 4)
59
60 data t3vs1 / 1000., 2000., 3000., 4000.,
61 & 5000., 6000., 7000., 8000. /
62 data q4vs1 / 10000., 20000., 30000., 4000. /
63 data t3vs2 / 1500., 2500., 3500., 4500.,
64 & 5500., 6500., 7500., 8500. /
65 data q4vs2 / 15000., 25000., 35000., 45000. /
66 C
67 C
68 C file creation
69 call mfiope(fid,fname,med_acc_creat,cret)
70 if (cret .ne. 0 ) then
71 print *,'ERROR : file creation'
72 call efexit(-1)
73 endif
74 C
75 C
76 C create mesh link
77 call mlnliw(fid,mname,lfname,cret)
78 if (cret .ne. 0 ) then
79 print *,'ERROR : create mesh link ...'
80 call efexit(-1)
81 endif
82 C
83 C
84 C field creation : temperature field : 1 component in celsius degree
85 C the mesh is the 2D unstructured mesh of
86 C UsecaseMEDmesh_1.f use case. Computation step unit in 'ms'
87 call mfdcre(fid,finame,med_float64,ncompo,cpname,cpunit,dtunit,
88 & mname,cret)
89 if (cret .ne. 0 ) then
90 print *,'ERROR : create field ...'
91 call efexit(-1)
92 endif
93 C
94 C
95 C two computation steps :
96 C - first on meshname MED_NO_DT,MED_NO_IT mesh computation step
97 C - second on meshname 1,3 mesh computation step
98 C write values at cell centers : 8 MED_TRIA3 and 4 MED_QUAD4
99 C
100 C
101 C STEP 1 : dt1 = 5.5, it = 1
102 C
103 C
104 C MED_TRIA3
105 dt = 5.5d0
106 ndt = 1
107 nit = 1
108 call mfdrvw(fid,finame,ndt,nit,dt,med_cell,med_tria3,
109 & med_full_interlace,med_all_constituent,
110 & ntria3,t3vs1,cret)
111 if (cret .ne. 0 ) then
112 print *,'ERROR : write field values on MED_TRIA3'
113 call efexit(-1)
114 endif
115 C
116 C
117 C MED_QUAD4
118 call mfdrvw(fid,finame,ndt,nit,dt,med_cell,med_quad4,
119 & med_full_interlace,med_all_constituent,
120 & nquad4,q4vs1,cret)
121 if (cret .ne. 0 ) then
122 print *,'ERROR : write field values on MED_TRIA3'
123 call efexit(-1)
124 endif
125 C
126 C
127 C STEP 2 : dt2 = 8.9, it = 1
128 C
129 C MED_TRIA3
130 dt = 8.9d0
131 ndt = 2
132 nit = 1
133 call mfdrvw(fid,finame,ndt,nit,dt,med_cell,med_tria3,
134 & med_full_interlace,med_all_constituent,
135 & ntria3,t3vs2,cret)
136 if (cret .ne. 0 ) then
137 print *,'ERROR : write field values on MED_TRIA3'
138 call efexit(-1)
139 endif
140 C
141 C
142 C MED_QUAD4
143 call mfdrvw(fid,finame,ndt,nit,dt,med_cell,med_quad4,
144 & med_full_interlace,med_all_constituent,
145 & nquad4,q4vs2,cret)
146 if (cret .ne. 0 ) then
147 print *,'ERROR : write field values on MED_TRIA3'
148 call efexit(-1)
149 endif
150 C
151 C
152 C Write associated mesh computation step
153 mnumdt = 1
154 mnumit = 3
155 call mfdcmw(fid,finame,ndt,nit,mnumdt,mnumit,cret)
156 if (cret .ne. 0 ) then
157 print *,'ERROR : write field mesh computation step error '
158 call efexit(-1)
159 endif
160 C
161 C
162 C close file
163 call mficlo(fid,cret)
164 if (cret .ne. 0 ) then
165 print *,'ERROR : close file'
166 call efexit(-1)
167 endif
168 C
169 C
170 C
171 end
172 C
mlnliw
subroutine mlnliw(fid, mname, lname, cret)
Cette routine permet d'écrire un lien dans un fichier MED.
Definition: medlink.f:21
mfdcmw
subroutine mfdcmw(fid, fname, numdt, numit, mnumdt, mnumit, cret)
Cette fonction permet de définir l'étape de calcul ( meshnumdit , meshnumit ) à utiliser pour le mail...
Definition: medfield.f:333
usescase_medfield_4
program usescase_medfield_4
Definition: UsesCase_MEDfield_4.f:23
mficlo
subroutine mficlo(fid, cret)
Fermeture d'un fichier MED.
Definition: medfile.f:82
mfdcre
subroutine mfdcre(fid, fname, ftype, ncomp, cname, cunit, dtunit, mname, cret)
Cette fonction crée un champ dans un fichier.
Definition: medfield.f:22
mfdrvw
subroutine mfdrvw(fid, fname, numdt, numit, dt, etype, gtype, swm, cs, n, val, cret)
Cette fonction permet d'écrire les valeurs d'un champ définies sur des entités d'un maillage pour une...
Definition: medfield.f:42
med_float64
double med_float64
Definition: med.h:339
mfiope
subroutine mfiope(fid, name, access, cret)
Ouverture d'un fichier MED.
Definition: medfile.f:42