33 integer cret,ret,lret,retmem
34 integer user_interlace,user_mode
35 character*64 :: maa,nomcha,pflname,nomlien,locname
38 character*16,
allocatable,
dimension(:) :: comp,unit
40 integer mdim,ncomp,ncha,npro,nln,pflsize,nval
41 integer,
allocatable,
dimension(:) :: pflval
43 integer t1,t2,t3,typcha,
type,type_geo
44 real*8,
allocatable,
dimension(:) :: refcoo, gscoo, wg
48 integer nstep, stype, atype,sdim
49 character*16 nomcoo(3)
50 character*16 unicoo(3)
52 character*64 :: giname, isname
55 parameter(user_interlace = med_full_interlace)
56 parameter(user_mode = med_compact_pflmode)
58 cret=0;ret=0;lret=0;retmem=0
59 print *,
"Indiquez le fichier med a decrire : "
64 call mfiope(fid,argc,med_acc_rdonly, ret)
65 if (ret .ne. 0)
call efexit(-1)
69 call mmhmii(fid,1,maa,sdim,mdim,
type,desc,dtunit,stype,nstep,atype,nomcoo,unicoo,ret)
72 print *,
"Erreur a la lecture des informations sur le maillage : ", &
77 write (*,
'(/A,A,A,I1)')
"Maillage de nom |",trim(maa),
"| et de dimension ",mdim
82 print *,
"Impossible de lire le nombre de champs : ",ncha
86 write (*,
'(A,I1/)')
"Nombre de champs : ",ncha
92 write(*,
'(A,I5)')
"- Champ numero : ",i
95 call mfdnfc(fid,i,ncomp,ret)
98 print *,
"Erreur a la lecture du nombre de composantes : ",ncomp
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 : "
110 call mfdfdi(fid,i,nomcha,maa,lmesh,typcha,comp,unit,dtunit,ncst,ret)
112 print *,
"Erreur a la demande d'information sur les champs : ",nomcha,typcha,comp,unit,ncomp,ncst
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 write(*,
'(5X,A,I1)')
'Nombre de composantes = ',ncomp
122 write(*,
'(5X,A,I1,A,A,A,A)')
'Composante ',j,
' : ',trim(comp(j)),
' ',trim(unit(j))
124 write(*,
'(5X,A,I1)')
'Nombre de pas de temps = ',ncst
127 deallocate(comp,unit)
129 lret =
getfieldson(fid, nomcha, typcha, ncomp, med_node, user_interlace, ncst)
132 if (lret .eq. 0)
then
133 lret =
getfieldson(fid, nomcha, typcha, ncomp, med_cell, user_interlace, ncst)
135 print *,
"Erreur a la lecture des champs aux noeuds "; cret = -1;
continue
138 if (lret .eq. 0)
then
139 lret =
getfieldson(fid, nomcha, typcha, ncomp, med_descending_face,user_interlace, ncst)
141 print *,
"Erreur a la lecture des champs aux mailles "; cret = -1;
continue
144 if (lret .eq. 0)
then
145 lret =
getfieldson(fid, nomcha, typcha, ncomp, med_descending_edge,user_interlace, ncst)
147 print *,
"Erreur a la lecture des champs aux faces "; cret = -1;
continue
150 if (lret .eq. 0)
then
151 lret =
getfieldson(fid, nomcha, typcha, ncomp, med_node_element,user_interlace, ncst)
153 print *,
"Erreur a la lecture des champs aux aretes "; cret = -1;
continue
156 if (lret .ne. 0)
then
157 print *,
"Erreur a la lecture des champs aux noeuds des mailles "; cret = -1
164 write (*,
'(5X,A,I2)') é
'Nombre de profils stocks : ', nval
166 if (nval .gt. 0 )
then
168 call mpfpfi(fid,i,pflname,nval,ret)
169 write (*,
'(5X,A,I2,A,A,A,I2)')
'Profil n ',i,
' : ',pflname,
' et de taille',nval
177 print *,
"Erreur a la lecture du nombre de liens : " &
182 write (*,
'(5X,A,I5)')
"Nombre de liens stockes : ",nln;print *,
"";print *,
""
184 call mlnlni(fid, i, nomlien, nval, ret)
186 print *,°
"Erreur a la demande d'information sur le lien n : ",i
189 write (*,
'(5X,A,I4,A,A,A,I4)') °
"- Lien n",i,
" de nom |",trim(nomlien),
"| et de taille ",nval
192 call mlnlir(fid,nomlien,lien,ret)
194 print *,
"Erreur a la lecture du lien : ", lien,nval,nomlien
197 write (*,
'(5X,A,A,A)')
"|",trim(lien),
"|";print *,
"";print *,
""
207 print *,
"Erreur a la lecture du nombre de points de Gauss : " &
211 print *,
"Nombre de localisations stockees : ",nloc;print *,
"";print *,
""
213 call mlclci(fid, i, locname, type_geo, sdim, ngauss, giname, isname, nsmc, sgtype, ret)
215 print *,°
"Erreur a la demande d'information sur la localisation n : ",i
218 write (*,
'(5X,A,I4,A,A,A,I4,A,I4)') °
"- Loc n",i,
" de nom |",trim(locname) &
219 &,
"| et nbr. de pts Gauss ",ngauss,
"| et dans un espace de dimension ",sdim
220 t1 = mod(type_geo,100)*sdim
223 allocate(refcoo(t1),stat=retmem)
224 if (retmem .ne. 0)
then
225 print *, é
"Erreur a l'allocation mmoire de refcoo : "
228 allocate(gscoo(t2),stat=retmem)
229 if (retmem .ne. 0)
then
230 print *, é
"Erreur a l'allocation mmoire de gscoo : "
233 allocate(wg(t3),stat=retmem)
234 if (retmem .ne. 0)
then
235 print *, é
"Erreur a l'allocation mmoire de wg : "
238 call mlclor(fid, locname,user_interlace,refcoo,gscoo,wg, ret )
240 print *,
"Erreur a la lecture des valeurs de la localisation : " &
244 write (*,
'(5X,A,I4)')
"Coordonnees de l'element de reference de type ",type_geo
246 write (*,
'(5X,E20.8)') refcoo(j)
249 write (*,
'(5X,A)')
"Localisation des points de GAUSS : "
251 write (*,
'(5X,E20.8)') gscoo(j)
254 write (*,
'(5X,A)')
"Poids associes aux points de GAUSS "
256 write (*,
'(5X,E20.8)') wg(j)
274integer function getfieldson(fid, nomcha, typcha, ncomp, entite, stockage, ncst)
279 integer ::typcha,ncomp,entite,stockage, ncst
280 character(LEN=*) nomcha
282 integer :: j,k,l,m,n,nb_geo,cret,ret,retmem,nvl,nref
283 integer :: nbpdtnor,pflsize,ngauss,ngroup,nent,nprofile
284 integer,
allocatable,
dimension(:) :: pflval
285 integer,
allocatable,
dimension(:) :: vale
286 integer :: numdt,numo,lnsize,nbrefmaa
287 real*8,
allocatable,
dimension(:) :: valr
290 character*64 :: pflname,locname,maa_ass
291 character*16 :: dt_unit
295 integer,
pointer,
dimension(:) :: type_geo
296 integer,
target :: typ_noeud(1) = (/ med_none /)
298 integer :: my_nof_cell_type = 17
299 integer :: my_nof_descending_face_type = 5
300 integer :: my_nof_descending_edge_type = 2
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,&
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/)
316 character(LEN=15),
pointer,
dimension(:) :: aff
317 character(LEN=15),
target,
dimension(17) :: fmed_geometrie_maille_aff = (/&
334 &
"MED_POLYHEDRON " /)
336 character(LEN=15),
target,
dimension(5) :: fmed_geometrie_face_aff = (/&
343 character(LEN=15),
target,
dimension(2) :: fmed_geometrie_arete_aff = (/&
347 character(LEN=15),
target,
dimension(1) :: fmed_geometrie_noeud_aff = (/ &
351 character(LEN=20),
target,
dimension(0:4) :: fmed_entite_maillage_aff =(/ &
353 &
"MED_DESCENDING_FACE ", &
354 &
"MED_DESCENDING_EDGE ", &
356 &
"MED_NODE_ELEMENT "/)
358 parameter(user_mode = med_compact_stmode )
366 nbpdtnor=0;pflsize=0;ngauss=0;nent=0
367 numdt = 0;numo=0;retmem=0
376 type_geo => typ_noeud
378 aff => fmed_geometrie_noeud_aff
382 aff => fmed_geometrie_maille_aff
383 case (med_node_element)
386 aff => fmed_geometrie_maille_aff
387 case (med_descending_face)
390 aff => fmed_geometrie_face_aff
391 case (med_descending_edge)
393 nb_geo = my_nof_descending_edge_type
394 aff => fmed_geometrie_arete_aff
401 if(nbpdtnor < 1 )
continue
405 call mfdcsi(fid,nomcha,j,numdt,numo,dt,ret)
408 print *,
"Erreur a la demande d'information sur (pdt,nor) : " &
409 & ,nomcha,entite, numdt, numo, dt
413 call mfdnpf(fid,nomcha,numdt,numo,entite,type_geo(k),pflname,locname,nprofile,ret)
416 print *,
"Erreur a la lecture du nombre de profil : " &
417 & ,nomcha,entite, type_geo(k),numdt, numo
425 call mfdnvp(fid,nomcha,numdt,numo,entite,type_geo(k),l,user_mode,pflname,pflsize,locname,ngauss,nent,ret)
428 print *,
"Erreur a la lecture du nombre de valeurs du champ : " &
429 & ,nomcha,entite,type_geo(k), &
435 write(*,
'(5X,A,I2,A,I2,A,I2,A,E10.5,A)') ɰ
'tape de calcul n ',l,
' (',numdt,
',',numo,
'), dt=(',dt,
')'
436 write(*,
'(5X,A,I5,A,I2,A,A,A,A,A,A,I2,A,A)') &
437 &
'Il y a ',nent,
' valeurs en mode ',user_mode, &
438 &
'. Chaque entite ',trim(fmed_entite_maillage_aff(entite)), &
439 &
' de type geometrique ',trim(aff(k)),
' associes au profil |',&
440 & trim(pflname)//
'| a ',ngauss,é
' valeur(s) par entit, et une localization de nom |',trim(locname)//
'|'
444 allocate(valr(ncomp*nent*ngauss),stat=retmem)
446 call mfdrpr(fid,nomcha,numdt,numo,entite,type_geo(k),user_mode, &
447 & pflname,stockage,med_all_constituent,valr,ret)
450 print *,
"Erreur a la lecture des valeurs du champ : ", &
451 & nomcha,valr,stockage,med_all_constituent, &
452 & pflname,user_mode,entite,type_geo(k),numdt,numo
457 allocate(vale(ncomp*nent*ngauss),stat=retmem)
459 call mfdipr(fid,nomcha,numdt,numo,entite,type_geo(k),user_mode, &
460 & pflname,stockage,med_all_constituent,vale,ret)
463 print *,
"Erreur a la lecture des valeurs du champ : ",&
464 & nomcha,vale,stockage,med_all_constituent, &
465 & pflname,user_mode,entite,type_geo(k),numdt,numo
471 if (ngauss .gt. 1 )
then
472 write (*,
'(5X,A,A,A)') è
"- Modle de localisation des ", &
473 &
"points de Gauss de nom ", trim(locname)
476 if ( entite .eq. med_node_element )
then
477 ngroup = mod(type_geo(k),100)
482 select case (stockage)
483 case (med_full_interlace)
484 write(*,
'(5X,A)')
"- Valeurs :";
write(*,
'(5X,A)')
""
487 do n=0,(ngroup*ncomp-1)
489 write (*,
'(1X,E20.5,1X)') valr( m*ngroup*ncomp+n +1 )
491 write (*,
'(1X,I8,1X)') vale( m*ngroup*ncomp+n +1 )
495 case (med_no_interlace)
496 write(*,
'(5X,A)')
"- Valeurs :";
write(*,
'(5X,A)')
""
501 write (*,
'(1X,E20.5,1X)') valr(m*nent+n +1)
503 write (*,
'(1X,I8,1X)') vale(m*nent+n +1)
517 if (pflname .eq. med_no_profile)
then
520 write(*,
'(5X,A,A)')
'Profil :',pflname
521 call mpfpsn(fid,pflname,pflsize,ret)
523 print *,
"Erreur a la lecture du nombre de valeurs du profil : ", &
527 write(*,
'(5X,A,I5)')
'Taille du profil : ',pflsize
530 allocate(pflval(pflsize),stat=retmem)
531 if (retmem .ne. 0)
then
532 print *, é
"Erreur a l'allocation mmoire de pflsize : "
536 call mpfprr(fid,pflname,pflval,ret)
537 if (cret .ne. 0)
write(*,
'(I1)') cret
539 print *,
"Erreur a la lecture du profil : ", &
543 write(*,
'(5X,A)')
'Valeurs du profil : '
545 write (*,
'(5X,I6)') pflval(m)
subroutine mfdnpf(fid, fname, numdt, numit, etype, gtype, dpname, dlname, n, cret)
subroutine mfdfdi(fid, it, fname, mname, lmesh, type, cname, cunit, dtunit, nc, cret)
subroutine mfdipr(fid, fname, numdt, numit, etype, gtype, stm, pname, swm, cs, val, cret)
subroutine mfdrpr(fid, fname, numdt, numit, etype, gtype, stm, pname, swm, cs, val, cret)
subroutine mfdnfd(fid, n, cret)
subroutine mfdnfc(fid, ind, n, cret)
subroutine mfdcsi(fid, fname, it, numdt, numit, dt, cret)
subroutine mfdnvp(fid, fname, numdt, numit, etype, gtype, pit, stm, pname, psize, lname, nip, n, cret)
subroutine mfiope(fid, name, access, cret)
subroutine mficlo(fid, cret)
subroutine mlnlir(fid, mname, lname, cret)
subroutine mlnnln(fid, n, cret)
subroutine mlnlni(fid, it, mname, lsize, cret)
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)
subroutine mpfprr(fid, pname, profil, cret)
subroutine mpfnpf(fid, n, cret)
subroutine mpfpsn(fid, pname, psize, cret)
subroutine mpfpfi(fid, it, pname, psize, cret)
integer function getfieldson(fid, nomcha, typcha, ncomp, entite, stockage, ncst)