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_stmode)
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
121 write(*,
'(5X,A,I1,A,A,A,A)')
'Composante ',j,
' : ',trim(comp(j)),
' ',trim(unit(j))
123 write(*,
'(5X,A,I1)')
'Nombre de pas de temps = ',ncst
126 deallocate(comp,unit)
128 lret =
getfieldson(fid, nomcha, typcha, ncomp, med_node, user_interlace, ncst)
131 if (lret .eq. 0)
then
132 lret =
getfieldson(fid, nomcha, typcha, ncomp, med_cell, user_interlace, ncst)
134 print *,
"Erreur a la lecture des champs aux noeuds "; cret = -1;
continue
137 if (lret .eq. 0)
then
138 lret =
getfieldson(fid, nomcha, typcha, ncomp, med_descending_face,user_interlace, ncst)
140 print *,
"Erreur a la lecture des champs aux mailles "; cret = -1;
continue
143 if (lret .eq. 0)
then
144 lret =
getfieldson(fid, nomcha, typcha, ncomp, med_descending_edge,user_interlace, ncst)
146 print *,
"Erreur a la lecture des champs aux faces "; cret = -1;
continue
149 if (lret .eq. 0)
then
150 lret =
getfieldson(fid, nomcha, typcha, ncomp, med_node_element,user_interlace, ncst)
152 print *,
"Erreur a la lecture des champs aux aretes "; cret = -1;
continue
155 if (lret .ne. 0)
then
156 print *,
"Erreur a la lecture des champs aux noeuds des mailles "; cret = -1
163 write (*,
'(5X,A,I2)') é
'Nombre de profils stocks : ', nval
165 if (nval .gt. 0 )
then
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
176 print *,
"Erreur a la lecture du nombre de liens : " &
181 write (*,
'(5X,A,I5)')
"Nombre de liens stockes : ",nln;print *,
"";print *,
""
183 call mlnlni(fid, i, nomlien, nval, ret)
185 print *,°
"Erreur a la demande d'information sur le lien n : ",i
188 write (*,
'(5X,A,I4,A,A,A,I4)') °
"- Lien n",i,
" de nom |",trim(nomlien),
"| et de taille ",nval
191 call mlnlir(fid,nomlien,lien,ret)
193 print *,
"Erreur a la lecture du lien : ", lien,nval,nomlien
196 write (*,
'(5X,A,A,A)')
"|",trim(lien),
"|";print *,
"";print *,
""
206 print *,
"Erreur a la lecture du nombre de points de Gauss : " &
210 print *,
"Nombre de localisations stockees : ",nloc;print *,
"";print *,
""
212 call mlclci(fid, i, locname, type_geo, sdim, ngauss, giname, isname, nsmc, sgtype, ret)
214 print *,°
"Erreur a la demande d'information sur la localisation n : ",i
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
222 allocate(refcoo(t1),stat=retmem)
223 if (retmem .ne. 0)
then
224 print *, é
"Erreur a l'allocation mmoire de refcoo : "
227 allocate(gscoo(t2),stat=retmem)
228 if (retmem .ne. 0)
then
229 print *, é
"Erreur a l'allocation mmoire de gscoo : "
232 allocate(wg(t3),stat=retmem)
233 if (retmem .ne. 0)
then
234 print *, é
"Erreur a l'allocation mmoire de wg : "
237 call mlclor(fid, locname,user_interlace,refcoo,gscoo,wg, ret )
239 print *,
"Erreur a la lecture des valeurs de la localisation : " &
243 write (*,
'(5X,A,I4)')
"Coordonnees de l'element de reference de type ",type_geo
245 write (*,
'(5X,E20.8)') refcoo(j)
248 write (*,
'(5X,A)')
"Localisation des points de GAUSS : "
250 write (*,
'(5X,E20.8)') gscoo(j)
253 write (*,
'(5X,A)')
"Poids associes aux points de GAUSS "
255 write (*,
'(5X,E20.8)') wg(j)
273integer function getfieldson(fid, nomcha, typcha, ncomp, entite, stockage, ncst)
278 integer ::typcha,ncomp,entite,stockage, ncst
279 character(LEN=*) nomcha
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
289 character*64 :: pflname,locname,maa_ass,mname
290 character*16 :: dt_unit
293 integer :: nmesh,lmesh, mnumdt, mnumit
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 mfdoci(fid,nomcha,j,numdt,numo,dt, nmesh, mname, lmesh, mnumdt, mnumit, ret)
408 print *,
"Erreur a la demande d'information sur (pdt,nor) : " &
409 & ,nomcha,entite, numdt, numo, dt
415 call mfdonp(fid,nomcha,numdt,numo,entite,type_geo(k),itm,mname,pflname,locname,nprofile,ret)
418 print *,
"Erreur a la lecture du nombre de profil : " &
419 & ,nomcha,entite, type_geo(k),numdt, numo
427 call mfdonv(fid,nomcha,numdt,numo,entite,type_geo(k),mname,l, &
428 & user_mode,pflname,pflsize,locname,ngauss,nent,ret)
432 print *,
"Erreur a la lecture du nombre de valeurs du champ : " &
433 & ,nomcha,entite,type_geo(k), &
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
449 allocate(valr(ncomp*nent*ngauss),stat=retmem)
451 call mfdorr(fid,nomcha,numdt,numo,entite,type_geo(k),mname,user_mode, &
452 & pflname,stockage,med_all_constituent,valr,ret)
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
462 allocate(vale(ncomp*nent*ngauss),stat=retmem)
464 call mfdoir(fid,nomcha,numdt,numo,entite,type_geo(k),mname,user_mode, &
465 & pflname,stockage,med_all_constituent,vale,ret)
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
476 if (ngauss .gt. 1 )
then
477 write (*,
'(5X,A,A,A)') è
"- Modle de localisation des ", &
478 &
"points de Gauss de nom ", trim(locname)
481 if ( entite .eq. med_node_element )
then
482 ngroup = mod(type_geo(k),100)
487 select case (stockage)
488 case (med_full_interlace)
489 write(*,
'(5X,A)')
"- Valeurs :";
write(*,
'(5X,A)')
""
492 do n=0,(ngroup*ncomp-1)
494 write (*,
'(1X,E20.5,1X)') valr( m*ngroup*ncomp+n +1 )
496 write (*,
'(1X,I8,1X)') vale( m*ngroup*ncomp+n +1 )
500 case (med_no_interlace)
501 write(*,
'(5X,A)')
"- Valeurs :";
write(*,
'(5X,A)')
""
506 write (*,
'(1X,E20.5,1X)') valr(m*nent+n +1)
508 write (*,
'(1X,I8,1X)') vale(m*nent+n +1)
522 if (pflname .eq. med_no_profile)
then
525 write(*,
'(5X,A,A)')
'Profil :',pflname
526 call mpfpsn(fid,pflname,pflsize,ret)
528 print *,
"Erreur a la lecture du nombre de valeurs du profil : ", &
532 write(*,
'(5X,A,I5)')
'Taille du profil : ',pflsize
535 allocate(pflval(pflsize),stat=retmem)
536 if (retmem .ne. 0)
then
537 print *, é
"Erreur a l'allocation mmoire de pflsize : "
541 call mpfprr(fid,pflname,pflval,ret)
542 if (cret .ne. 0)
write(*,
'(I1)') cret
544 print *,
"Erreur a la lecture du profil : ", &
548 write(*,
'(5X,A)')
'Valeurs du profil : '
550 write (*,
'(5X,I6)') pflval(m)
subroutine mfdorr(fid, fname, numdt, numit, etype, gtype, mname, stm, pname, swm, cs, val, cret)
subroutine mfdfdi(fid, it, fname, mname, lmesh, type, cname, cunit, dtunit, nc, cret)
subroutine mfdoci(fid, fname, it, numdt, numit, dt, nmesh, mname, lmesh, mnumdt, mnumit, cret)
subroutine mfdonv(fid, fname, numdt, numit, etype, gtype, mname, pit, stm, pname, psize, lname, nip, n, cret)
subroutine mfdoir(fid, fname, numdt, numit, etype, gtype, mname, stm, pname, swm, cs, val, cret)
subroutine mfdnfd(fid, n, cret)
subroutine mfdnfc(fid, ind, n, cret)
subroutine mfdonp(fid, fname, numdt, numit, etype, gtype, it, mname, dpname, dlname, 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)