MED fichier
test11.f90
Aller à la documentation de ce fichier.
1 !* This file is part of MED.
2 !*
3 !* COPYRIGHT (C) 1999 - 2017 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 
26 program test11
27 
28  implicit none
29  include 'med.hf90'
30 
31 
32  integer cret,ret,lret,retmem, fid
33  integer USER_INTERLACE,USER_MODE
34  character*64 :: maa,nomcha,pflname,nomlien,locname
35  character*200 desc
36  character*255 argc
37  character*16, allocatable, dimension(:) :: comp,unit
38  character*16 dtunit
39  integer mdim,ncomp,ncha,npro,nln,pflsize,nval
40  integer, allocatable, dimension(:) :: pflval
41  integer ngauss,nloc
42  integer t1,t2,t3,typcha,type,type_geo
43  real*8, allocatable, dimension(:) :: refcoo, gscoo, wg
44  character*255 lien
45  integer i,j
46  integer getFieldsOn
47  integer nstep, stype, atype,sdim
48  character*16 nomcoo(3)
49  character*16 unicoo(3)
50  integer lmesh, ncst
51  character*64 :: giname, isname
52  integer nsmc, sgtype
53 
54  parameter(user_interlace = med_full_interlace)
55  parameter(user_mode = med_compact_pflmode)
56 
57  cret=0;ret=0;lret=0;retmem=0
58  print *,"Indiquez le fichier med a decrire : "
59  !!read(*,'(A)') argc
60  argc="test10.med"
61 
62  ! ** ouverture du fichier **
63  call mfiope(fid,argc,med_acc_rdonly, ret)
64  if (ret .ne. 0) call efexit(-1)
65 
66  ! ** info sur le premier maillage **
67  if (ret.eq.0) then
68  call mmhmii(fid,1,maa,sdim,mdim,type,desc,dtunit,stype,nstep,atype,nomcoo,unicoo,ret)
69  endif
70  if (ret.ne.0) then
71  print *, "Erreur a la lecture des informations sur le maillage : ", &
72  & maa,mdim,type,desc
73  call efexit(-1)
74  endif
75 
76  write (*,'(/A,A,A,I1)') "Maillage de nom |",trim(maa),"| et de dimension ",mdim
77 
78  ! ** combien de champs dans le fichier **
79  call mfdnfd(fid,ncha,ret)
80  if (ret.ne.0) then
81  print *, "Impossible de lire le nombre de champs : ",ncha
82  call efexit(-1)
83  endif
84 
85  write (*,'(A,I1/)') "Nombre de champs : ",ncha
86 
87 
88  ! ** lecture de tous les champs associes a <maa> **
89  do i=1,ncha
90  lret = 0
91  write(*,'(A,I5)') "- Champ numero : ",i
92 
93  ! ** combien de composantes **
94  call mfdnfc(fid,i,ncomp,ret)
95  ! print *,ncomp,ret
96  if (ret.ne.0) then
97  print *, "Erreur a la lecture du nombre de composantes : ",ncomp
98  cret = -1
99  endif
100 
101  ! ** allocation memoire de comp et unit **
102  allocate(comp(ncomp),unit(ncomp),stat=retmem)
103  if (retmem .ne. 0) then
104  print *, "Erreur a l'allocation mémoire de comp et unit : "
105  call efexit(-1)
106  endif
107 
108  ! ** Info sur les champs
109  call mfdfdi(fid,i,nomcha,maa,lmesh,typcha,comp,unit,dtunit,ncst,ret)
110  if (ret .ne. 0) then
111  print *, "Erreur a la demande d'information sur les champs : ",nomcha,typcha,comp,unit,ncomp,ncst
112  cret = -1
113  continue
114  endif
115 
116  write(*,'(/5X,A,A)') 'Nom du champ : ', trim(nomcha)
117  write(*,'(/5X,A,A)') 'Nom du maillage : ',trim(maa)
118  write(*,'(5X,A,I5)') 'Type du champ : ', typcha
119  write(*,'(5X,A,I1)') 'Nombre de composantes = ',ncomp
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 stockés : ', 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  &,"| et nbr. de pts Gauss ",ngauss,"| et 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 mémoire 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 mémoire 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 mémoire 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 
270 end program test11
271 
272 
273 integer function getfieldson(fid, nomcha, typcha, ncomp, entite, stockage, ncst)
274  implicit none
275  include 'med.hf90'
276 
277  integer ::fid,typcha,ncomp,entite,stockage, ncst
278  character(LEN=*) nomcha
279 
280  integer :: j,k,l,m,n,nb_geo,cret,ret,retmem,nvl,nref
281  integer :: nbpdtnor,pflsize,ngauss,ngroup,nent,nprofile
282  integer, allocatable, dimension(:) :: pflval
283  integer, allocatable, dimension(:) :: vale
284  integer :: numdt,numo,lnsize,nbrefmaa
285  real*8, allocatable, dimension(:) :: valr
286  real*8 dt
287  logical local
288  character*64 :: pflname,locname,maa_ass
289  character*16 :: dt_unit
290  character*255:: lien
291  integer USER_MODE
292 
293  integer,pointer,dimension(:) :: type_geo
294  integer,target :: typ_noeud(1) = (/ med_none /)
295 
296  integer :: MY_NOF_CELL_TYPE = 17
297  integer :: MY_NOF_DESCENDING_FACE_TYPE = 5
298  integer :: MY_NOF_DESCENDING_EDGE_TYPE = 2
299 
300  integer,target :: typmai(17) = (/ med_point1,med_seg2, &
301  & med_seg3,med_tria3, &
302  & med_quad4,med_tria6, &
303  & med_quad8,med_tetra4, &
304  & med_pyra5,med_penta6, &
305  & med_hexa8,med_tetra10, &
306  & med_pyra13,med_penta15, &
307  & med_hexa20,med_polygon,&
308  & med_polyhedron/)
309 
310  integer,target :: typfac(5) = (/med_tria3,med_tria6, &
311  & med_quad4,med_quad8,med_polygon/)
312  integer,target ::typare(2) = (/med_seg2,med_seg3/)
313 
314  character(LEN=15),pointer,dimension(:) :: AFF
315  character(LEN=15),target,dimension(17) :: FMED_GEOMETRIE_MAILLE_AFF = (/&
316  & "MED_POINT1 ",&
317  & "MED_SEG2 ",&
318  & "MED_SEG3 ",&
319  & "MED_TRIA3 ",&
320  & "MED_QUAD4 ",&
321  & "MED_TRIA6 ",&
322  & "MED_QUAD8 ",&
323  & "MED_TETRA4 ",&
324  & "MED_PYRA5 ",&
325  & "MED_PENTA6 ",&
326  & "MED_HEXA8 ",&
327  & "MED_TETRA10 ",&
328  & "MED_PYRA13 ",&
329  & "MED_PENTA15 ",&
330  & "MED_HEXA20 ",&
331  & "MED_POLYGON ",&
332  & "MED_POLYHEDRON " /)
333 
334  character(LEN=15),target,dimension(5) :: FMED_GEOMETRIE_FACE_AFF = (/&
335  & "MED_TRIA3 ",&
336  & "MED_TRIA6 ",&
337  & "MED_QUAD4 ",&
338  & "MED_QUAD8 ",&
339  & "MED_POLYGON " /)
340 
341  character(LEN=15),target,dimension(2) :: FMED_GEOMETRIE_ARETE_AFF = (/&
342  & "MED_SEG2 ",&
343  & "MED_SEG3 " /)
344 
345  character(LEN=15),target,dimension(1) :: FMED_GEOMETRIE_NOEUD_AFF = (/ &
346  & "(AUCUN) "/)
347 
348 
349  character(LEN=20),target,dimension(0:4) :: FMED_ENTITE_MAILLAGE_AFF =(/ &
350  & "MED_CELL ", &
351  & "MED_DESCENDING_FACE ", &
352  & "MED_DESCENDING_EDGE ", &
353  & "MED_NODE ", &
354  & "MED_NODE_ELEMENT "/)
355 
356  parameter(user_mode = med_compact_stmode )
357 
358  !! write (*,'(A0)') FMED_GEOMETRIE_NOEUD_AFF(1)
359  !! write (*,'(A0)') FMED_GEOMETRIE_MAILLE_AFF(1)
360  !! write (*,'(A0)') FMED_GEOMETRIE_FACE_AFF(1)
361  !! write (*,'(A0)') FMED_GEOMETRIE_ARETE_AFF(1)
362 
363  locname=''
364  nbpdtnor=0;pflsize=0;ngauss=0;nent=0
365  numdt = 0;numo=0;retmem=0
366  cret=0;ret=0
367 
368  nullify(type_geo)
369  nullify(aff)
370 
371 
372  select case (entite)
373  case (med_node)
374  type_geo => typ_noeud
375  nb_geo = 1
376  aff => fmed_geometrie_noeud_aff
377  case (med_cell)
378  type_geo => typmai
379  nb_geo = 17
380  aff => fmed_geometrie_maille_aff
381  case (med_node_element)
382  type_geo => typmai
383  nb_geo = 17
384  aff => fmed_geometrie_maille_aff
385  case (med_descending_face)
386  type_geo => typfac;
387  nb_geo = 5
388  aff => fmed_geometrie_face_aff
389  case (med_descending_edge)
390  type_geo => typare
391  nb_geo = my_nof_descending_edge_type
392  aff => fmed_geometrie_arete_aff
393  end select
394 
395  do k=1,nb_geo
396 
397  ! ** Combien de (PDT,NOR) a lire **
398  nbpdtnor = ncst
399  if(nbpdtnor < 1 ) continue
400 
401  do j=1,ncst
402 
403  call mfdcsi(fid,nomcha,j,numdt,numo,dt,ret)
404  !print *,ret
405  if (ret.ne.0) then
406  print *, "Erreur a la demande d'information sur (pdt,nor) : " &
407  & ,nomcha,entite, numdt, numo, dt
408  cret = -1
409  end if
410 
411  call mfdnpf(fid,nomcha,numdt,numo,entite,type_geo(k),pflname,locname,nprofile,ret)
412  !print *,ret
413  if (ret.ne.0) then
414  print *, "Erreur a la lecture du nombre de profil : " &
415  & ,nomcha,entite, type_geo(k),numdt, numo
416  cret = -1
417  call efexit(cret)
418  end if
419 
420  do l=1,nprofile
421 
422  ! ** Combien de valeurs à lire ? **
423  call mfdnvp(fid,nomcha,numdt,numo,entite,type_geo(k),l,user_mode,pflname,pflsize,locname,ngauss,nent,ret)
424  !print *,ret
425  if (ret.ne.0) then
426  print *,"Erreur a la lecture du nombre de valeurs du champ : " &
427  & ,nomcha,entite,type_geo(k), &
428  & numdt, numo
429  cret = -1; continue
430  endif
431  !write(*,'(5X,A,I5,A)') 'Il y a ', nent ,' valeurs a lire '
432 
433  write(*,'(5X,A,I2,A,I2,A,I2,A,E10.5,A)') 'Séquence de calcul n° ',l,' (',numdt,',',numo,'), dt=(',dt,')'
434  write(*,'(5X,A,I5,A,I2,A,A,A,A,A,A,I2,A,A)') &
435  & 'Il y a ',nent,' valeurs en mode ',user_mode, &
436  & '. Chaque entite ',trim(fmed_entite_maillage_aff(entite)), &
437  & ' de type geometrique ',trim(aff(k)),' associes au profil |',&
438  & trim(pflname)//'| a ',ngauss,' valeur(s) par entité, et une localization de nom |',trim(locname)//'|'
439 
440  ! **Lecture des valeurs du champ **
441  if (typcha .eq. med_float64) then
442  allocate(valr(ncomp*nent*ngauss),stat=retmem)
443 
444  call mfdrpr(fid,nomcha,numdt,numo,entite,type_geo(k),user_mode, &
445  & pflname,stockage,med_all_constituent,valr,ret)
446  !print *,ret
447  if (ret.ne.0) then
448  print *,"Erreur a la lecture des valeurs du champ : ", &
449  & nomcha,valr,stockage,med_all_constituent, &
450  & pflname,user_mode,entite,type_geo(k),numdt,numo
451  cret = -1;
452  call efexit(cret)
453  endif
454  else
455  allocate(vale(ncomp*nent*ngauss),stat=retmem)
456 
457  call mfdipr(fid,nomcha,numdt,numo,entite,type_geo(k),user_mode, &
458  & pflname,stockage,med_all_constituent,vale,ret)
459  !print *,ret
460  if (ret.ne.0) then
461  print *,"Erreur a la lecture des valeurs du champ : ",&
462  & nomcha,vale,stockage,med_all_constituent, &
463  & pflname,user_mode,entite,type_geo(k),numdt,numo
464  cret = -1;
465  endif
466 
467  endif
468 
469  if (ngauss .gt. 1 ) then
470  write (*,'(5X,A,A,A)') "- Modèle de localisation des ", &
471  & "points de Gauss de nom ", trim(locname)
472  end if
473 
474  if ( entite .eq. med_node_element ) then
475  ngroup = mod(type_geo(k),100)
476  else
477  ngroup = ngauss
478  end if
479 
480  select case (stockage)
481  case (med_full_interlace)
482  write(*,'(5X,A)') "- Valeurs :"; write(*,'(5X,A)') ""
483  do m=0,nent-1
484  write(*,*) "|"
485  do n=0,(ngroup*ncomp-1)
486  if (typcha .eq. med_float64) then
487  write (*,'(1X,E20.5,1X)') valr( m*ngroup*ncomp+n +1 )
488  else
489  write (*,'(1X,I8,1X)') vale( m*ngroup*ncomp+n +1 )
490  end if
491  enddo
492  enddo
493  case (med_no_interlace)
494  write(*,'(5X,A)') "- Valeurs :"; write(*,'(5X,A)') ""
495  do m=0,ncomp-1
496  write(*,*) "|"
497  do n=0,nent-1
498  if (typcha .eq. med_float64) then
499  write (*,'(1X,E20.5,1X)') valr(m*nent+n +1)
500  else
501  write (*,'(1X,I8,1X)') vale(m*nent+n +1)
502  endif
503  enddo
504  enddo
505  end select
506 
507  write(*,*) "|"
508  if (typcha .eq. med_float64) then
509  deallocate(valr)
510  else
511  deallocate(vale)
512  endif
513 
514  !* Profils
515  if (pflname .eq. med_no_profile) then
516  !write(*,'(5X,A)') 'Pas de profil'
517  else
518  write(*,'(5X,A,A)') 'Profil :',pflname
519  call mpfpsn(fid,pflname,pflsize,ret)
520  if (ret .ne. 0) then
521  print *,"Erreur a la lecture du nombre de valeurs du profil : ", &
522  & pflname,pflsize
523  cret = -1;continue
524  endif
525  write(*,'(5X,A,I5)') 'Taille du profil : ',pflsize
526 
527  ! ** allocation memoire de pflval **
528  allocate(pflval(pflsize),stat=retmem)
529  if (retmem .ne. 0) then
530  print *, "Erreur a l'allocation mémoire de pflsize : "
531  call efexit(-1)
532  endif
533 
534  call mpfprr(fid,pflname,pflval,ret)
535  if (cret .ne. 0) write(*,'(I1)') cret
536  if (ret .ne. 0) then
537  print *,"Erreur a la lecture du profil : ", &
538  & pflname,pflval
539  cret = -1;continue
540  endif
541  write(*,'(5X,A)') 'Valeurs du profil : '
542  do m=1,pflsize
543  write (*,'(5X,I6)') pflval(m)
544  enddo
545 
546  deallocate(pflval)
547 
548  endif
549 
550  enddo
551 
552  enddo
553 
554  enddo
555 
556  print *,""
557  getfieldson=ret
558 
559 end function getfieldson
subroutine mficlo(fid, cret)
Definition: medfile.f:80
subroutine mfdfdi(fid, it, fname, mname, lmesh, type, cname, cunit, dtunit, nc, cret)
Definition: medfield.f:248
subroutine mpfnpf(fid, n, cret)
Definition: medprofile.f:39
subroutine mlnnln(fid, n, cret)
Definition: medlink.f:38
subroutine mlclor(fid, lname, swm, ecoo, ipcoo, wght, cret)
subroutine mpfprr(fid, pname, profil, cret)
Definition: medprofile.f:97
subroutine mpfpfi(fid, it, pname, psize, cret)
Definition: medprofile.f:61
program test11
Definition: test11.f90:26
integer function getfieldson(fid, nomcha, typcha, ncomp, entite, stockage, ncst)
Definition: test11.f90:274
subroutine mfdrpr(fid, fname, numdt, numit, etype, gtype, stm, pname, swm, cs, val, cret)
Definition: medfield.f:505
subroutine mfdnfc(fid, ind, n, cret)
Definition: medfield.f:202
subroutine mlclci(fid, it, lname, gtype, sdim, nip, giname, isname, nsmc, sgtype, cret)
subroutine mlnlni(fid, it, mname, lsize, cret)
Definition: medlink.f:60
subroutine mlcnlc(fid, n, cret)
subroutine mfdnpf(fid, fname, numdt, numit, etype, gtype, dpname, dlname, n, cret)
Definition: medfield.f:354
subroutine mfdnfd(fid, n, cret)
Definition: medfield.f:180
subroutine mfdcsi(fid, fname, it, numdt, numit, dt, cret)
Definition: medfield.f:290
subroutine mfdipr(fid, fname, numdt, numit, etype, gtype, stm, pname, swm, cs, val, cret)
Definition: medfield.f:528
double med_float64
Definition: med.h:330
subroutine mmhmii(fid, it, name, sdim, mdim, mtype, desc, dtunit, stype, nstep, atype, aname, aunit, cret)
Definition: medmesh.f:110
subroutine mfdnvp(fid, fname, numdt, numit, etype, gtype, pit, stm, pname, psize, lname, nip, n, cret)
Definition: medfield.f:406
subroutine mfiope(fid, name, access, cret)
Definition: medfile.f:41
subroutine mlnlir(fid, mname, lname, cret)
Definition: medlink.f:102
subroutine mpfpsn(fid, pname, psize, cret)
Definition: medprofile.f:79