32 integer cret,ret,lret,retmem, fid
33 integer USER_INTERLACE,USER_MODE
34 character*64 :: maa,nomcha,pflname,nomlien,locname
37 character*16,
allocatable,
dimension(:) :: comp,unit
39 integer mdim,ncomp,ncha,npro,nln,pflsize,nval
40 integer,
allocatable,
dimension(:) :: pflval
42 integer t1,t2,t3,typcha,
type,type_geo
43 real*8,
allocatable,
dimension(:) :: refcoo, gscoo, wg
47 integer nstep, stype, atype,sdim
48 character*16 nomcoo(3)
49 character*16 unicoo(3)
51 character*64 :: giname, isname
54 parameter(user_interlace = med_full_interlace)
55 parameter(user_mode = med_compact_pflmode)
57 cret=0;ret=0;lret=0;retmem=0
58 print *,
"Indiquez le fichier med a decrire : " 63 call mfiope(fid,argc,med_acc_rdonly, ret)
64 if (ret .ne. 0)
call efexit(-1)
68 call mmhmii(fid,1,maa,sdim,mdim,
type,desc,dtunit,stype,nstep,atype,nomcoo,unicoo,ret)
71 print *,
"Erreur a la lecture des informations sur le maillage : ", &
76 write (*,
'(/A,A,A,I1)')
"Maillage de nom |",trim(maa),
"| et de dimension ",mdim
81 print *,
"Impossible de lire le nombre de champs : ",ncha
85 write (*,
'(A,I1/)')
"Nombre de champs : ",ncha
91 write(*,
'(A,I5)')
"- Champ numero : ",i
94 call mfdnfc(fid,i,ncomp,ret)
97 print *,
"Erreur a la lecture du nombre de composantes : ",ncomp
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 : " 109 call mfdfdi(fid,i,nomcha,maa,lmesh,typcha,comp,unit,dtunit,ncst,ret)
111 print *,
"Erreur a la demande d'information sur les champs : ",nomcha,typcha,comp,unit,ncomp,ncst
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
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 stockés : ', 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 &,
"| et nbr. de pts Gauss ",ngauss,
"| et 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 mémoire de refcoo : " 227 allocate(gscoo(t2),stat=retmem)
228 if (retmem .ne. 0)
then 229 print *,
"Erreur a l'allocation mémoire de gscoo : " 232 allocate(wg(t3),stat=retmem)
233 if (retmem .ne. 0)
then 234 print *,
"Erreur a l'allocation mémoire 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)
273 integer function getfieldson(fid, nomcha, typcha, ncomp, entite, stockage, ncst)
277 integer ::fid,typcha,ncomp,entite,stockage, ncst
278 character(LEN=*) nomcha
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
288 character*64 :: pflname,locname,maa_ass
289 character*16 :: dt_unit
293 integer,
pointer,
dimension(:) :: type_geo
294 integer,
target :: typ_noeud(1) = (/ med_none /)
296 integer :: MY_NOF_CELL_TYPE = 17
297 integer :: MY_NOF_DESCENDING_FACE_TYPE = 5
298 integer :: MY_NOF_DESCENDING_EDGE_TYPE = 2
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,&
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/)
314 character(LEN=15),
pointer,
dimension(:) :: AFF
315 character(LEN=15),
target,
dimension(17) :: FMED_GEOMETRIE_MAILLE_AFF = (/&
332 &
"MED_POLYHEDRON " /)
334 character(LEN=15),
target,
dimension(5) :: FMED_GEOMETRIE_FACE_AFF = (/&
341 character(LEN=15),
target,
dimension(2) :: FMED_GEOMETRIE_ARETE_AFF = (/&
345 character(LEN=15),
target,
dimension(1) :: FMED_GEOMETRIE_NOEUD_AFF = (/ &
349 character(LEN=20),
target,
dimension(0:4) :: FMED_ENTITE_MAILLAGE_AFF =(/ &
351 &
"MED_DESCENDING_FACE ", &
352 &
"MED_DESCENDING_EDGE ", &
354 &
"MED_NODE_ELEMENT "/)
356 parameter(user_mode = med_compact_stmode )
364 nbpdtnor=0;pflsize=0;ngauss=0;nent=0
365 numdt = 0;numo=0;retmem=0
374 type_geo => typ_noeud
376 aff => fmed_geometrie_noeud_aff
380 aff => fmed_geometrie_maille_aff
381 case (med_node_element)
384 aff => fmed_geometrie_maille_aff
385 case (med_descending_face)
388 aff => fmed_geometrie_face_aff
389 case (med_descending_edge)
391 nb_geo = my_nof_descending_edge_type
392 aff => fmed_geometrie_arete_aff
399 if(nbpdtnor < 1 )
continue 403 call mfdcsi(fid,nomcha,j,numdt,numo,dt,ret)
406 print *,
"Erreur a la demande d'information sur (pdt,nor) : " &
407 & ,nomcha,entite, numdt, numo, dt
411 call mfdnpf(fid,nomcha,numdt,numo,entite,type_geo(k),pflname,locname,nprofile,ret)
414 print *,
"Erreur a la lecture du nombre de profil : " &
415 & ,nomcha,entite, type_geo(k),numdt, numo
423 call mfdnvp(fid,nomcha,numdt,numo,entite,type_geo(k),l,user_mode,pflname,pflsize,locname,ngauss,nent,ret)
426 print *,
"Erreur a la lecture du nombre de valeurs du champ : " &
427 & ,nomcha,entite,type_geo(k), &
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)//
'|' 442 allocate(valr(ncomp*nent*ngauss),stat=retmem)
444 call mfdrpr(fid,nomcha,numdt,numo,entite,type_geo(k),user_mode, &
445 & pflname,stockage,med_all_constituent,valr,ret)
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
455 allocate(vale(ncomp*nent*ngauss),stat=retmem)
457 call mfdipr(fid,nomcha,numdt,numo,entite,type_geo(k),user_mode, &
458 & pflname,stockage,med_all_constituent,vale,ret)
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
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)
474 if ( entite .eq. med_node_element )
then 475 ngroup = mod(type_geo(k),100)
480 select case (stockage)
481 case (med_full_interlace)
482 write(*,
'(5X,A)')
"- Valeurs :";
write(*,
'(5X,A)')
"" 485 do n=0,(ngroup*ncomp-1)
487 write (*,
'(1X,E20.5,1X)') valr( m*ngroup*ncomp+n +1 )
489 write (*,
'(1X,I8,1X)') vale( m*ngroup*ncomp+n +1 )
493 case (med_no_interlace)
494 write(*,
'(5X,A)')
"- Valeurs :";
write(*,
'(5X,A)')
"" 499 write (*,
'(1X,E20.5,1X)') valr(m*nent+n +1)
501 write (*,
'(1X,I8,1X)') vale(m*nent+n +1)
515 if (pflname .eq. med_no_profile)
then 518 write(*,
'(5X,A,A)')
'Profil :',pflname
519 call mpfpsn(fid,pflname,pflsize,ret)
521 print *,
"Erreur a la lecture du nombre de valeurs du profil : ", &
525 write(*,
'(5X,A,I5)')
'Taille du profil : ',pflsize
528 allocate(pflval(pflsize),stat=retmem)
529 if (retmem .ne. 0)
then 530 print *,
"Erreur a l'allocation mémoire de pflsize : " 534 call mpfprr(fid,pflname,pflval,ret)
535 if (cret .ne. 0)
write(*,
'(I1)') cret
537 print *,
"Erreur a la lecture du profil : ", &
541 write(*,
'(5X,A)')
'Valeurs du profil : ' 543 write (*,
'(5X,I6)') pflval(m)
subroutine mficlo(fid, cret)
subroutine mfdfdi(fid, it, fname, mname, lmesh, type, cname, cunit, dtunit, nc, cret)
subroutine mpfnpf(fid, n, cret)
subroutine mlnnln(fid, n, cret)
subroutine mlclor(fid, lname, swm, ecoo, ipcoo, wght, cret)
subroutine mpfprr(fid, pname, profil, cret)
subroutine mpfpfi(fid, it, pname, psize, cret)
integer function getfieldson(fid, nomcha, typcha, ncomp, entite, stockage, ncst)
subroutine mfdrpr(fid, fname, numdt, numit, etype, gtype, stm, pname, swm, cs, val, cret)
subroutine mfdnfc(fid, ind, n, cret)
subroutine mlclci(fid, it, lname, gtype, sdim, nip, giname, isname, nsmc, sgtype, cret)
subroutine mlnlni(fid, it, mname, lsize, cret)
subroutine mlcnlc(fid, n, cret)
subroutine mfdnpf(fid, fname, numdt, numit, etype, gtype, dpname, dlname, n, cret)
subroutine mfdnfd(fid, n, cret)
subroutine mfdcsi(fid, fname, it, numdt, numit, dt, cret)
subroutine mfdipr(fid, fname, numdt, numit, etype, gtype, stm, pname, swm, cs, val, cret)
subroutine mmhmii(fid, it, name, sdim, mdim, mtype, desc, dtunit, stype, nstep, atype, aname, aunit, cret)
subroutine mfdnvp(fid, fname, numdt, numit, etype, gtype, pit, stm, pname, psize, lname, nip, n, cret)
subroutine mfiope(fid, name, access, cret)
subroutine mlnlir(fid, mname, lname, cret)
subroutine mpfpsn(fid, pname, psize, cret)