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 mémoire 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 stockés : ', 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 mémoire de refcoo : " 228 allocate(gscoo(t2),stat=retmem)
229 if (retmem .ne. 0)
then 230 print *,
"Erreur a l'allocation mémoire de gscoo : " 233 allocate(wg(t3),stat=retmem)
234 if (retmem .ne. 0)
then 235 print *,
"Erreur a l'allocation mémoire 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)
274 integer 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)')
'Séquence 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)')
"- Modèle 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 mémoire 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 mpfnpf(fid, n, cret)
subroutine mfiope(fid, name, access, cret)
subroutine mmhmii(fid, it, name, sdim, mdim, mtype, desc, dtunit, stype, nstep, atype, aname, aunit, cret)
subroutine mlclor(fid, lname, swm, ecoo, ipcoo, wght, cret)
subroutine mficlo(fid, cret)
subroutine mfdfdi(fid, it, fname, mname, lmesh, type, cname, cunit, dtunit, nc, cret)
subroutine mpfprr(fid, pname, profil, cret)
subroutine mlclci(fid, it, lname, gtype, sdim, nip, giname, isname, nsmc, sgtype, cret)
integer function getfieldson(fid, nomcha, typcha, ncomp, entite, stockage, ncst)
subroutine mfdnvp(fid, fname, numdt, numit, etype, gtype, pit, stm, pname, psize, lname, nip, n, cret)
subroutine mlnlni(fid, it, mname, lsize, cret)
subroutine mpfpsn(fid, pname, psize, cret)
subroutine mpfpfi(fid, it, pname, psize, cret)
subroutine mlnnln(fid, n, cret)
subroutine mfdnfc(fid, ind, n, cret)
subroutine mfdipr(fid, fname, numdt, numit, etype, gtype, stm, pname, swm, cs, val, cret)
subroutine mfdcsi(fid, fname, it, numdt, numit, dt, cret)
subroutine mfdnfd(fid, n, cret)
subroutine mfdrpr(fid, fname, numdt, numit, etype, gtype, stm, pname, swm, cs, val, cret)
subroutine mfdnpf(fid, fname, numdt, numit, etype, gtype, dpname, dlname, n, cret)
subroutine mlnlir(fid, mname, lname, cret)
subroutine mlcnlc(fid, n, cret)