MED fichier
test11b.f90
Aller à la documentation de ce fichier.
1!* This file is part of MED.
2!*
3!* COPYRIGHT (C) 1999 - 2020 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! ******************************************************************************
20! * - Nom du fichier : test11.f90
21! *
22! * - Description : lecture de champs de resultats MED
23! *
24! *****************************************************************************
25
26program test11
27
28 implicit none
29 include 'med.hf90'
30
31
32 integer*8 fid
33 integer cret,ret,lret,retmem
34 integer user_interlace,user_mode
35 character*64 :: maa,nomcha,pflname,nomlien,locname
36 character*200 desc
37 character*255 argc
38 character*16, allocatable, dimension(:) :: comp,unit
39 character*16 dtunit
40 integer mdim,ncomp,ncha,npro,nln,pflsize,nval
41 integer, allocatable, dimension(:) :: pflval
42 integer ngauss,nloc
43 integer t1,t2,t3,typcha,type,type_geo
44 real*8, allocatable, dimension(:) :: refcoo, gscoo, wg
45 character*255 lien
46 integer i,j
47 integer getfieldson
48 integer nstep, stype, atype,sdim
49 character*16 nomcoo(3)
50 character*16 unicoo(3)
51 integer lmesh, ncst
52 character*64 :: giname, isname
53 integer nsmc, sgtype
54
55 parameter(user_interlace = med_full_interlace)
56 parameter(user_mode = med_compact_stmode)
57
58 cret=0;ret=0;lret=0;retmem=0
59 print *,"Indiquez le fichier med a decrire : "
60 !!read(*,'(A)') argc
61 argc="test10.med"
62
63 ! ** ouverture du fichier **
64 call mfiope(fid,argc,med_acc_rdonly, ret)
65 if (ret .ne. 0) call efexit(-1)
66
67 ! ** info sur le premier maillage **
68 if (ret.eq.0) then
69 call mmhmii(fid,1,maa,sdim,mdim,type,desc,dtunit,stype,nstep,atype,nomcoo,unicoo,ret)
70 endif
71 if (ret.ne.0) then
72 print *, "Erreur a la lecture des informations sur le maillage : ", &
73 & maa,mdim,type,desc
74 call efexit(-1)
75 endif
76
77 write (*,'(/A,A,A,I1)') "Maillage de nom |",trim(maa),"| et de dimension ",mdim
78
79 ! ** combien de champs dans le fichier **
80 call mfdnfd(fid,ncha,ret)
81 if (ret.ne.0) then
82 print *, "Impossible de lire le nombre de champs : ",ncha
83 call efexit(-1)
84 endif
85
86 write (*,'(A,I1/)') "Nombre de champs : ",ncha
87
88
89 ! ** lecture de tous les champs associes a <maa> **
90 do i=1,ncha
91 lret = 0
92 write(*,'(A,I5)') "- Champ numero : ",i
93
94 ! ** combien de composantes **
95 call mfdnfc(fid,i,ncomp,ret)
96 ! print *,ncomp,ret
97 if (ret.ne.0) then
98 print *, "Erreur a la lecture du nombre de composantes : ",ncomp
99 cret = -1
100 endif
101
102 ! ** allocation memoire de comp et unit **
103 allocate(comp(ncomp),unit(ncomp),stat=retmem)
104 if (retmem .ne. 0) then
105 print *, é"Erreur a l'allocation mmoire de comp et unit : "
106 call efexit(-1)
107 endif
108
109 ! ** Info sur les champs
110 call mfdfdi(fid,i,nomcha,maa,lmesh,typcha,comp,unit,dtunit,ncst,ret)
111 if (ret .ne. 0) then
112 print *, "Erreur a la demande d'information sur les champs : ",nomcha,typcha,comp,unit,ncomp,ncst
113 cret = -1
114 continue
115 endif
116
117 write(*,'(/5X,A,A)') 'Nom du champ : ', trim(nomcha)
118 write(*,'(/5X,A,A)') 'Nom du maillage : ',trim(maa)
119 write(*,'(5X,A,I5)') 'Type du champ : ', typcha
120 do j=1,ncomp
121 write(*,'(5X,A,I1,A,A,A,A)') 'Composante ',j,' : ',trim(comp(j)),' ',trim(unit(j))
122 enddo
123 write(*,'(5X,A,I1)') 'Nombre de pas de temps = ',ncst
124 print *,""
125
126 deallocate(comp,unit)
127
128 lret = getfieldson(fid, nomcha, typcha, ncomp, med_node, user_interlace, ncst)
129 ! print *,lret
130
131 if (lret .eq. 0) then
132 lret = getfieldson(fid, nomcha, typcha, ncomp, med_cell, user_interlace, ncst)
133 else
134 print *, "Erreur a la lecture des champs aux noeuds "; cret = -1; continue
135 endif
136
137 if (lret .eq. 0) then
138 lret = getfieldson(fid, nomcha, typcha, ncomp, med_descending_face,user_interlace, ncst)
139 else
140 print *,"Erreur a la lecture des champs aux mailles "; cret = -1; continue
141 endif
142
143 if (lret .eq. 0) then
144 lret = getfieldson(fid, nomcha, typcha, ncomp, med_descending_edge,user_interlace, ncst)
145 else
146 print *,"Erreur a la lecture des champs aux faces "; cret = -1; continue
147 endif
148
149 if (lret .eq. 0) then
150 lret = getfieldson(fid, nomcha, typcha, ncomp, med_node_element,user_interlace, ncst)
151 else
152 print *,"Erreur a la lecture des champs aux aretes "; cret = -1; continue
153 endif
154
155 if (lret .ne. 0) then
156 print *,"Erreur a la lecture des champs aux noeuds des mailles "; cret = -1
157 endif
158
159 enddo
160
161
162 call mpfnpf(fid,nval,ret)
163 write (*,'(5X,A,I2)') é'Nombre de profils stocks : ', nval
164
165 if (nval .gt. 0 ) then
166 do i=1,nval
167 call mpfpfi(fid,i,pflname,nval,ret)
168 write (*,'(5X,A,I2,A,A,A,I2)') 'Profil n ',i,' : ',pflname, ' et de taille',nval
169 enddo
170 endif
171
172
173 ! ** Interrogation des liens **
174 call mlnnln(fid,nln,ret)
175 if (ret.ne.0) then
176 print *,"Erreur a la lecture du nombre de liens : " &
177 & ,nln
178 cret = -1;
179 else
180 print *,""
181 write (*,'(5X,A,I5)') "Nombre de liens stockes : ",nln;print *,"";print *,""
182 do i=1,nln
183 call mlnlni(fid, i, nomlien, nval, ret)
184 if (ret.ne.0) then
185 print *,°"Erreur a la demande d'information sur le lien n : ",i
186 cret = -1;continue;
187 endif
188 write (*,'(5X,A,I4,A,A,A,I4)') °"- Lien n",i," de nom |",trim(nomlien),"| et de taille ",nval
189 !! allocate
190 lien = ""
191 call mlnlir(fid,nomlien,lien,ret)
192 if (ret.ne.0) then
193 print *,"Erreur a la lecture du lien : ", lien,nval,nomlien
194 ret = -1;
195 else
196 write (*,'(5X,A,A,A)') "|",trim(lien),"|";print *,"";print *,""
197 endif
198 !!deallocate
199 end do
200 endif
201
202
203 ! ** Interrogation des localisations des points de GAUSS **
204 call mlcnlc(fid,nloc,ret)
205 if (ret.ne.0) then
206 print *,"Erreur a la lecture du nombre de points de Gauss : " &
207 & ,nloc
208 cret = -1;
209 else
210 print *,"Nombre de localisations stockees : ",nloc;print *,"";print *,""
211 do i=1,nloc
212 call mlclci(fid, i, locname, type_geo, sdim, ngauss, giname, isname, nsmc, sgtype, ret)
213 if (ret.ne.0) then
214 print *,°"Erreur a la demande d'information sur la localisation n : ",i
215 cret = -1;continue;
216 endif
217 write (*,'(5X,A,I4,A,A,A,I4,A,I4)') °"- Loc n",i," de nom |",trim(locname) &
218 &,à"| ",ngauss, é" points d'intgration dans un espace de dimension ",sdim
219 t1 = mod(type_geo,100)*sdim
220 t2 = ngauss*sdim
221 t3 = ngauss
222 allocate(refcoo(t1),stat=retmem)
223 if (retmem .ne. 0) then
224 print *, é"Erreur a l'allocation mmoire de refcoo : "
225 call efexit(-1)
226 endif;
227 allocate(gscoo(t2),stat=retmem)
228 if (retmem .ne. 0) then
229 print *, é"Erreur a l'allocation mmoire de gscoo : "
230 call efexit(-1)
231 endif;
232 allocate(wg(t3),stat=retmem)
233 if (retmem .ne. 0) then
234 print *, é"Erreur a l'allocation mmoire de wg : "
235 call efexit(-1)
236 endif;
237 call mlclor(fid, locname,user_interlace,refcoo,gscoo,wg, ret )
238 if (ret.ne.0) then
239 print *,"Erreur a la lecture des valeurs de la localisation : " &
240 & ,locname
241 cret = -1;
242 else
243 write (*,'(5X,A,I4)') "Coordonnees de l'element de reference de type ",type_geo
244 do j=1,t1
245 write (*,'(5X,E20.8)') refcoo(j)
246 enddo
247 print *,""
248 write (*,'(5X,A)') "Localisation des points de GAUSS : "
249 do j=1,t2
250 write (*,'(5X,E20.8)') gscoo(j)
251 enddo
252 print *,""
253 write (*,'(5X,A)') "Poids associes aux points de GAUSS "
254 do j=1,t3
255 write (*,'(5X,E20.8)') wg(j)
256 enddo
257 print *,""
258 endif
259 deallocate(refcoo)
260 deallocate(gscoo)
261 deallocate(wg)
262 enddo
263 endif
264
265 call mficlo(fid,ret)
266 !print *,ret
267
268 call efexit(cret)
269
270end program test11
271
272
273integer function getfieldson(fid, nomcha, typcha, ncomp, entite, stockage, ncst)
274 implicit none
275 include 'med.hf90'
276
277 integer*8 fid
278 integer ::typcha,ncomp,entite,stockage, ncst
279 character(LEN=*) nomcha
280
281 integer :: itm,j,k,l,m,n,nb_geo,cret,ret,retmem,nvl,nref
282 integer :: nbpdtnor,pflsize,ngauss,ngroup,nent,nprofile
283 integer, allocatable, dimension(:) :: pflval
284 integer, allocatable, dimension(:) :: vale
285 integer :: numdt,numo,lnsize,nbrefmaa
286 real*8, allocatable, dimension(:) :: valr
287 real*8 dt
288 logical local
289 character*64 :: pflname,locname,maa_ass,mname
290 character*16 :: dt_unit
291 character*255:: lien
292 integer user_mode
293 integer :: nmesh,lmesh, mnumdt, mnumit
294
295 integer,pointer,dimension(:) :: type_geo
296 integer,target :: typ_noeud(1) = (/ med_none /)
297
298 integer :: my_nof_cell_type = 17
299 integer :: my_nof_descending_face_type = 5
300 integer :: my_nof_descending_edge_type = 2
301
302 integer,target :: typmai(17) = (/ med_point1,med_seg2, &
303 & med_seg3,med_tria3, &
304 & med_quad4,med_tria6, &
305 & med_quad8,med_tetra4, &
306 & med_pyra5,med_penta6, &
307 & med_hexa8,med_tetra10, &
308 & med_pyra13,med_penta15, &
309 & med_hexa20,med_polygon,&
310 & med_polyhedron/)
311
312 integer,target :: typfac(5) = (/med_tria3,med_tria6, &
313 & med_quad4,med_quad8,med_polygon/)
314 integer,target ::typare(2) = (/med_seg2,med_seg3/)
315
316 character(LEN=15),pointer,dimension(:) :: aff
317 character(LEN=15),target,dimension(17) :: fmed_geometrie_maille_aff = (/&
318 & "MED_POINT1 ",&
319 & "MED_SEG2 ",&
320 & "MED_SEG3 ",&
321 & "MED_TRIA3 ",&
322 & "MED_QUAD4 ",&
323 & "MED_TRIA6 ",&
324 & "MED_QUAD8 ",&
325 & "MED_TETRA4 ",&
326 & "MED_PYRA5 ",&
327 & "MED_PENTA6 ",&
328 & "MED_HEXA8 ",&
329 & "MED_TETRA10 ",&
330 & "MED_PYRA13 ",&
331 & "MED_PENTA15 ",&
332 & "MED_HEXA20 ",&
333 & "MED_POLYGON ",&
334 & "MED_POLYHEDRON " /)
335
336 character(LEN=15),target,dimension(5) :: fmed_geometrie_face_aff = (/&
337 & "MED_TRIA3 ",&
338 & "MED_TRIA6 ",&
339 & "MED_QUAD4 ",&
340 & "MED_QUAD8 ",&
341 & "MED_POLYGON " /)
342
343 character(LEN=15),target,dimension(2) :: fmed_geometrie_arete_aff = (/&
344 & "MED_SEG2 ",&
345 & "MED_SEG3 " /)
346
347 character(LEN=15),target,dimension(1) :: fmed_geometrie_noeud_aff = (/ &
348 & "(AUCUN) "/)
349
350
351 character(LEN=20),target,dimension(0:4) :: fmed_entite_maillage_aff =(/ &
352 & "MED_CELL ", &
353 & "MED_DESCENDING_FACE ", &
354 & "MED_DESCENDING_EDGE ", &
355 & "MED_NODE ", &
356 & "MED_NODE_ELEMENT "/)
357
358 parameter(user_mode = med_compact_stmode )
359
360 !! write (*,'(A0)') FMED_GEOMETRIE_NOEUD_AFF(1)
361 !! write (*,'(A0)') FMED_GEOMETRIE_MAILLE_AFF(1)
362 !! write (*,'(A0)') FMED_GEOMETRIE_FACE_AFF(1)
363 !! write (*,'(A0)') FMED_GEOMETRIE_ARETE_AFF(1)
364
365 locname=''
366 nbpdtnor=0;pflsize=0;ngauss=0;nent=0
367 numdt = 0;numo=0;retmem=0
368 cret=0;ret=0
369
370 nullify(type_geo)
371 nullify(aff)
372
373
374 select case (entite)
375 case (med_node)
376 type_geo => typ_noeud
377 nb_geo = 1
378 aff => fmed_geometrie_noeud_aff
379 case (med_cell)
380 type_geo => typmai
381 nb_geo = 17
382 aff => fmed_geometrie_maille_aff
383 case (med_node_element)
384 type_geo => typmai
385 nb_geo = 17
386 aff => fmed_geometrie_maille_aff
387 case (med_descending_face)
388 type_geo => typfac;
389 nb_geo = 5
390 aff => fmed_geometrie_face_aff
391 case (med_descending_edge)
392 type_geo => typare
393 nb_geo = my_nof_descending_edge_type
394 aff => fmed_geometrie_arete_aff
395 end select
396
397 do k=1,nb_geo
398
399 ! ** Combien de (PDT,NOR) a lire **
400 nbpdtnor = ncst
401 if(nbpdtnor < 1 ) continue
402
403 do j=1,ncst
404
405 call mfdoci(fid,nomcha,j,numdt,numo,dt, nmesh, mname, lmesh, mnumdt, mnumit, ret)
406 ! print *,'ret=',ret
407 if (ret.ne.0) then
408 print *, "Erreur a la demande d'information sur (pdt,nor) : " &
409 & ,nomcha,entite, numdt, numo, dt
410 cret = -1
411 end if
412
413 do itm=1,nmesh
414
415 call mfdonp(fid,nomcha,numdt,numo,entite,type_geo(k),itm,mname,pflname,locname,nprofile,ret)
416 ! print *,'ret=',ret
417 if (ret.ne.0) then
418 print *, "Erreur a la lecture du nombre de profil : " &
419 & ,nomcha,entite, type_geo(k),numdt, numo
420 cret = -1
421 call efexit(cret)
422 end if
423
424 do l=1,nprofile
425
426 ! ** Combien de valeurs à lire ? **
427 call mfdonv(fid,nomcha,numdt,numo,entite,type_geo(k),mname,l, &
428 & user_mode,pflname,pflsize,locname,ngauss,nent,ret)
429
430 ! print *,'ret=',ret
431 if (ret.ne.0) then
432 print *,"Erreur a la lecture du nombre de valeurs du champ : " &
433 & ,nomcha,entite,type_geo(k), &
434 & numdt, numo
435 cret = -1; continue
436 endif
437 !write(*,'(5X,A,I5,A)') 'Il y a ', nent ,' valeurs a lire '
438
439 write(*,'(5X,A,I2,A,I2,A,I2,A,E10.5,A)') ɰ'tape de calcul n ',l,' (',numdt,',',numo,'), dt=(',dt,')'
440 write(*,'(5X,A,I5,A,I2,A,A,A,A,A,A,I2,A,A)') &
441 & 'Il y a ',nent,' valeurs en mode ',user_mode, &
442 & '. Chaque entite ',trim(fmed_entite_maillage_aff(entite)), &
443 & ' de type geometrique ',trim(aff(k)),' associes au profil |',&
444 & trim(pflname)//'| a ',ngauss,é' valeur(s) par entit une localization de nom |',trim(locname)//'|'
445 print *,'Le maillage associe est ', mname
446
447 ! **Lecture des valeurs du champ **
448 if (typcha .eq. med_float64) then
449 allocate(valr(ncomp*nent*ngauss),stat=retmem)
450
451 call mfdorr(fid,nomcha,numdt,numo,entite,type_geo(k),mname,user_mode, &
452 & pflname,stockage,med_all_constituent,valr,ret)
453 ! print *,'ret=',ret
454 if (ret.ne.0) then
455 print *,"Erreur a la lecture des valeurs du champ : ", &
456 & nomcha,valr,stockage,med_all_constituent, &
457 & pflname,user_mode,entite,type_geo(k),numdt,numo
458 cret = -1;
459 call efexit(cret)
460 endif
461 else
462 allocate(vale(ncomp*nent*ngauss),stat=retmem)
463
464 call mfdoir(fid,nomcha,numdt,numo,entite,type_geo(k),mname,user_mode, &
465 & pflname,stockage,med_all_constituent,vale,ret)
466 ! print *,'ret=',ret
467 if (ret.ne.0) then
468 print *,"Erreur a la lecture des valeurs du champ : ",&
469 & nomcha,vale,stockage,med_all_constituent, &
470 & pflname,user_mode,entite,type_geo(k),numdt,numo
471 cret = -1;
472 endif
473
474 endif
475
476 if (ngauss .gt. 1 ) then
477 write (*,'(5X,A,A,A)') è"- Modle de localisation des ", &
478 & "points de Gauss de nom ", trim(locname)
479 end if
480
481 if ( entite .eq. med_node_element ) then
482 ngroup = mod(type_geo(k),100)
483 else
484 ngroup = ngauss
485 end if
486
487 select case (stockage)
488 case (med_full_interlace)
489 write(*,'(5X,A)') "- Valeurs :"; write(*,'(5X,A)') ""
490 do m=0,nent-1
491 write(*,*) "|"
492 do n=0,(ngroup*ncomp-1)
493 if (typcha .eq. med_float64) then
494 write (*,'(1X,E20.5,1X)') valr( m*ngroup*ncomp+n +1 )
495 else
496 write (*,'(1X,I8,1X)') vale( m*ngroup*ncomp+n +1 )
497 end if
498 enddo
499 enddo
500 case (med_no_interlace)
501 write(*,'(5X,A)') "- Valeurs :"; write(*,'(5X,A)') ""
502 do m=0,ncomp-1
503 write(*,*) "|"
504 do n=0,nent-1
505 if (typcha .eq. med_float64) then
506 write (*,'(1X,E20.5,1X)') valr(m*nent+n +1)
507 else
508 write (*,'(1X,I8,1X)') vale(m*nent+n +1)
509 endif
510 enddo
511 enddo
512 end select
513
514 write(*,*) "|"
515 if (typcha .eq. med_float64) then
516 deallocate(valr)
517 else
518 deallocate(vale)
519 endif
520
521 !* Profils
522 if (pflname .eq. med_no_profile) then
523 !write(*,'(5X,A)') 'Pas de profil'
524 else
525 write(*,'(5X,A,A)') 'Profil :',pflname
526 call mpfpsn(fid,pflname,pflsize,ret)
527 if (ret .ne. 0) then
528 print *,"Erreur a la lecture du nombre de valeurs du profil : ", &
529 & pflname,pflsize
530 cret = -1;continue
531 endif
532 write(*,'(5X,A,I5)') 'Taille du profil : ',pflsize
533
534 ! ** allocation memoire de pflval **
535 allocate(pflval(pflsize),stat=retmem)
536 if (retmem .ne. 0) then
537 print *, é"Erreur a l'allocation mmoire de pflsize : "
538 call efexit(-1)
539 endif
540
541 call mpfprr(fid,pflname,pflval,ret)
542 if (cret .ne. 0) write(*,'(I1)') cret
543 if (ret .ne. 0) then
544 print *,"Erreur a la lecture du profil : ", &
545 & pflname,pflval
546 cret = -1;continue
547 endif
548 write(*,'(5X,A)') 'Valeurs du profil : '
549 do m=1,pflsize
550 write (*,'(5X,I6)') pflval(m)
551 enddo
552
553 deallocate(pflval)
554
555 endif
556
557 enddo
558
559 enddo
560
561 enddo
562
563 enddo
564
565
566 print *,""
567 getfieldson=ret
568
569end function getfieldson
subroutine mfdorr(fid, fname, numdt, numit, etype, gtype, mname, stm, pname, swm, cs, val, cret)
Definition medfield.f:738
subroutine mfdfdi(fid, it, fname, mname, lmesh, type, cname, cunit, dtunit, nc, cret)
Definition medfield.f:248
subroutine mfdoci(fid, fname, it, numdt, numit, dt, nmesh, mname, lmesh, mnumdt, mnumit, cret)
Definition medfield.f:653
subroutine mfdonv(fid, fname, numdt, numit, etype, gtype, mname, pit, stm, pname, psize, lname, nip, n, cret)
Definition medfield.f:706
subroutine mfdoir(fid, fname, numdt, numit, etype, gtype, mname, stm, pname, swm, cs, val, cret)
Definition medfield.f:763
subroutine mfdnfd(fid, n, cret)
Definition medfield.f:180
subroutine mfdnfc(fid, ind, n, cret)
Definition medfield.f:202
subroutine mfdonp(fid, fname, numdt, numit, etype, gtype, it, mname, dpname, dlname, n, cret)
Definition medfield.f:678
subroutine mfiope(fid, name, access, cret)
Definition medfile.f:42
subroutine mficlo(fid, cret)
Definition medfile.f:82
subroutine mlcnlc(fid, n, cret)
subroutine mlclci(fid, it, lname, gtype, sdim, nip, giname, isname, nsmc, sgtype, cret)
subroutine mlclor(fid, lname, swm, ecoo, ipcoo, wght, cret)
subroutine mmhmii(fid, it, name, sdim, mdim, mtype, desc, dtunit, stype, nstep, atype, aname, aunit, cret)
Definition medmesh.f:110
subroutine mpfprr(fid, pname, profil, cret)
Definition medprofile.f:97
subroutine mpfnpf(fid, n, cret)
Definition medprofile.f:39
subroutine mpfpsn(fid, pname, psize, cret)
Definition medprofile.f:79
subroutine mpfpfi(fid, it, pname, psize, cret)
Definition medprofile.f:61
integer function getfieldson(fid, nomcha, typcha, ncomp, entite, stockage, ncst)
Definition test11.f90:275
program test11
Definition test11.f90:26