test11b.f90
Aller à la documentation de ce fichier.
!* This file is part of MED.
!*
!* COPYRIGHT (C) 1999 - 2020 EDF R&D, CEA/DEN
!* MED is free software: you can redistribute it and/or modify
!* it under the terms of the GNU Lesser General Public License as published by
!* the Free Software Foundation, either version 3 of the License, or
!* (at your option) any later version.
!*
!* MED is distributed in the hope that it will be useful,
!* but WITHOUT ANY WARRANTY; without even the implied warranty of
!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!* GNU Lesser General Public License for more details.
!*
!* You should have received a copy of the GNU Lesser General Public License
!* along with MED. If not, see <http://www.gnu.org/licenses/>.
!*
! ******************************************************************************
! * - Nom du fichier : test11.f90
! *
! * - Description : lecture de champs de resultats MED
! *
! *****************************************************************************
program test11
implicit none
include 'med.hf90'
integer*8 fid
integer cret,ret,lret,retmem
integer user_interlace,user_mode
character*64 :: maa,nomcha,pflname,nomlien,locname
character*200 desc
character*255 argc
character*16, allocatable, dimension(:) :: comp,unit
character*16 dtunit
integer mdim,ncomp,ncha,npro,nln,pflsize,nval
integer, allocatable, dimension(:) :: pflval
integer ngauss,nloc
integer t1,t2,t3,typcha,type,type_geo
real*8, allocatable, dimension(:) :: refcoo, gscoo, wg
character*255 lien
integer i,j
integer getfieldson
integer nstep, stype, atype,sdim
character*16 nomcoo(3)
character*16 unicoo(3)
integer lmesh, ncst
character*64 :: giname, isname
integer nsmc, sgtype
parameter(user_interlace = med_full_interlace)
parameter(user_mode = med_compact_stmode)
cret=0;ret=0;lret=0;retmem=0
print *,"Indiquez le fichier med a decrire : "
!!read(*,'(A)') argc
argc="test10.med"
! ** ouverture du fichier **
call mfiope(fid,argc,med_acc_rdonly, ret)
if (ret .ne. 0) call efexit(-1)
! ** info sur le premier maillage **
if (ret.eq.0) then
call mmhmii(fid,1,maa,sdim,mdim,type,desc,dtunit,stype,nstep,atype,nomcoo,unicoo,ret)
endif
if (ret.ne.0) then
print *, "Erreur a la lecture des informations sur le maillage : ", &
& maa,mdim,type,desc
call efexit(-1)
endif
write (*,'(/A,A,A,I1)') "Maillage de nom |",trim(maa),"| et de dimension ",mdim
! ** combien de champs dans le fichier **
call mfdnfd(fid,ncha,ret)
if (ret.ne.0) then
print *, "Impossible de lire le nombre de champs : ",ncha
call efexit(-1)
endif
write (*,'(A,I1/)') "Nombre de champs : ",ncha
! ** lecture de tous les champs associes a <maa> **
do i=1,ncha
lret = 0
write(*,'(A,I5)') "- Champ numero : ",i
! ** combien de composantes **
call mfdnfc(fid,i,ncomp,ret)
! print *,ncomp,ret
if (ret.ne.0) then
print *, "Erreur a la lecture du nombre de composantes : ",ncomp
cret = -1
endif
! ** allocation memoire de comp et unit **
allocate(comp(ncomp),unit(ncomp),stat=retmem)
if (retmem .ne. 0) then
print *, "Erreur a l'allocation mémoire de comp et unit : "
call efexit(-1)
endif
! ** Info sur les champs
call mfdfdi(fid,i,nomcha,maa,lmesh,typcha,comp,unit,dtunit,ncst,ret)
if (ret .ne. 0) then
print *, "Erreur a la demande d'information sur les champs : ",nomcha,typcha,comp,unit,ncomp,ncst
cret = -1
continue
endif
write(*,'(/5X,A,A)') 'Nom du champ : ', trim(nomcha)
write(*,'(/5X,A,A)') 'Nom du maillage : ',trim(maa)
write(*,'(5X,A,I5)') 'Type du champ : ', typcha
do j=1,ncomp
write(*,'(5X,A,I1,A,A,A,A)') 'Composante ',j,' : ',trim(comp(j)),' ',trim(unit(j))
enddo
write(*,'(5X,A,I1)') 'Nombre de pas de temps = ',ncst
print *,""
deallocate(comp,unit)
lret = getfieldson(fid, nomcha, typcha, ncomp, med_node, user_interlace, ncst)
! print *,lret
if (lret .eq. 0) then
lret = getfieldson(fid, nomcha, typcha, ncomp, med_cell, user_interlace, ncst)
else
print *, "Erreur a la lecture des champs aux noeuds "; cret = -1; continue
endif
if (lret .eq. 0) then
lret = getfieldson(fid, nomcha, typcha, ncomp, med_descending_face,user_interlace, ncst)
else
print *,"Erreur a la lecture des champs aux mailles "; cret = -1; continue
endif
if (lret .eq. 0) then
lret = getfieldson(fid, nomcha, typcha, ncomp, med_descending_edge,user_interlace, ncst)
else
print *,"Erreur a la lecture des champs aux faces "; cret = -1; continue
endif
if (lret .eq. 0) then
lret = getfieldson(fid, nomcha, typcha, ncomp, med_node_element,user_interlace, ncst)
else
print *,"Erreur a la lecture des champs aux aretes "; cret = -1; continue
endif
if (lret .ne. 0) then
print *,"Erreur a la lecture des champs aux noeuds des mailles "; cret = -1
endif
enddo
call mpfnpf(fid,nval,ret)
write (*,'(5X,A,I2)') 'Nombre de profils stockés : ', nval
if (nval .gt. 0 ) then
do i=1,nval
call mpfpfi(fid,i,pflname,nval,ret)
write (*,'(5X,A,I2,A,A,A,I2)') 'Profil n ',i,' : ',pflname, ' et de taille',nval
enddo
endif
! ** Interrogation des liens **
call mlnnln(fid,nln,ret)
if (ret.ne.0) then
print *,"Erreur a la lecture du nombre de liens : " &
& ,nln
cret = -1;
else
print *,""
write (*,'(5X,A,I5)') "Nombre de liens stockes : ",nln;print *,"";print *,""
do i=1,nln
call mlnlni(fid, i, nomlien, nval, ret)
if (ret.ne.0) then
print *,"Erreur a la demande d'information sur le lien n° : ",i
cret = -1;continue;
endif
write (*,'(5X,A,I4,A,A,A,I4)') "- Lien n°",i," de nom |",trim(nomlien),"| et de taille ",nval
!! allocate
lien = ""
call mlnlir(fid,nomlien,lien,ret)
if (ret.ne.0) then
print *,"Erreur a la lecture du lien : ", lien,nval,nomlien
ret = -1;
else
write (*,'(5X,A,A,A)') "|",trim(lien),"|";print *,"";print *,""
endif
!!deallocate
end do
endif
! ** Interrogation des localisations des points de GAUSS **
call mlcnlc(fid,nloc,ret)
if (ret.ne.0) then
print *,"Erreur a la lecture du nombre de points de Gauss : " &
& ,nloc
cret = -1;
else
print *,"Nombre de localisations stockees : ",nloc;print *,"";print *,""
do i=1,nloc
call mlclci(fid, i, locname, type_geo, sdim, ngauss, giname, isname, nsmc, sgtype, ret)
if (ret.ne.0) then
print *,"Erreur a la demande d'information sur la localisation n° : ",i
cret = -1;continue;
endif
write (*,'(5X,A,I4,A,A,A,I4,A,I4)') "- Loc n°",i," de nom |",trim(locname) &
&,"| à",ngauss, " points d'intégration dans un espace de dimension ",sdim
t1 = mod(type_geo,100)*sdim
t2 = ngauss*sdim
t3 = ngauss
allocate(refcoo(t1),stat=retmem)
if (retmem .ne. 0) then
print *, "Erreur a l'allocation mémoire de refcoo : "
call efexit(-1)
endif;
allocate(gscoo(t2),stat=retmem)
if (retmem .ne. 0) then
print *, "Erreur a l'allocation mémoire de gscoo : "
call efexit(-1)
endif;
allocate(wg(t3),stat=retmem)
if (retmem .ne. 0) then
print *, "Erreur a l'allocation mémoire de wg : "
call efexit(-1)
endif;
call mlclor(fid, locname,user_interlace,refcoo,gscoo,wg, ret )
if (ret.ne.0) then
print *,"Erreur a la lecture des valeurs de la localisation : " &
& ,locname
cret = -1;
else
write (*,'(5X,A,I4)') "Coordonnees de l'element de reference de type ",type_geo
do j=1,t1
write (*,'(5X,E20.8)') refcoo(j)
enddo
print *,""
write (*,'(5X,A)') "Localisation des points de GAUSS : "
do j=1,t2
write (*,'(5X,E20.8)') gscoo(j)
enddo
print *,""
write (*,'(5X,A)') "Poids associes aux points de GAUSS "
do j=1,t3
write (*,'(5X,E20.8)') wg(j)
enddo
print *,""
endif
deallocate(refcoo)
deallocate(gscoo)
deallocate(wg)
enddo
endif
call mficlo(fid,ret)
!print *,ret
call efexit(cret)
end program test11
integer function getfieldson(fid, nomcha, typcha, ncomp, entite, stockage, ncst)
implicit none
include 'med.hf90'
integer*8 fid
integer ::typcha,ncomp,entite,stockage, ncst
character(LEN=*) nomcha
integer :: itm,j,k,l,m,n,nb_geo,cret,ret,retmem,nvl,nref
integer :: nbpdtnor,pflsize,ngauss,ngroup,nent,nprofile
integer, allocatable, dimension(:) :: pflval
integer, allocatable, dimension(:) :: vale
integer :: numdt,numo,lnsize,nbrefmaa
real*8, allocatable, dimension(:) :: valr
real*8 dt
logical local
character*64 :: pflname,locname,maa_ass,mname
character*16 :: dt_unit
character*255:: lien
integer user_mode
integer :: nmesh,lmesh, mnumdt, mnumit
integer,pointer,dimension(:) :: type_geo
integer,target :: typ_noeud(1) = (/ med_none /)
integer :: my_nof_cell_type = 17
integer :: my_nof_descending_face_type = 5
integer :: my_nof_descending_edge_type = 2
integer,target :: typmai(17) = (/ med_point1,med_seg2, &
& med_seg3,med_tria3, &
& med_quad4,med_tria6, &
& med_quad8,med_tetra4, &
& med_pyra5,med_penta6, &
& med_hexa8,med_tetra10, &
& med_pyra13,med_penta15, &
& med_hexa20,med_polygon,&
& med_polyhedron/)
integer,target :: typfac(5) = (/med_tria3,med_tria6, &
& med_quad4,med_quad8,med_polygon/)
integer,target ::typare(2) = (/med_seg2,med_seg3/)
character(LEN=15),pointer,dimension(:) :: aff
character(LEN=15),target,dimension(17) :: fmed_geometrie_maille_aff = (/&
& "MED_POINT1 ",&
& "MED_SEG2 ",&
& "MED_SEG3 ",&
& "MED_TRIA3 ",&
& "MED_QUAD4 ",&
& "MED_TRIA6 ",&
& "MED_QUAD8 ",&
& "MED_TETRA4 ",&
& "MED_PYRA5 ",&
& "MED_PENTA6 ",&
& "MED_HEXA8 ",&
& "MED_TETRA10 ",&
& "MED_PYRA13 ",&
& "MED_PENTA15 ",&
& "MED_HEXA20 ",&
& "MED_POLYGON ",&
& "MED_POLYHEDRON " /)
character(LEN=15),target,dimension(5) :: fmed_geometrie_face_aff = (/&
& "MED_TRIA3 ",&
& "MED_TRIA6 ",&
& "MED_QUAD4 ",&
& "MED_QUAD8 ",&
& "MED_POLYGON " /)
character(LEN=15),target,dimension(2) :: fmed_geometrie_arete_aff = (/&
& "MED_SEG2 ",&
& "MED_SEG3 " /)
character(LEN=15),target,dimension(1) :: fmed_geometrie_noeud_aff = (/ &
& "(AUCUN) "/)
character(LEN=20),target,dimension(0:4) :: fmed_entite_maillage_aff =(/ &
& "MED_CELL ", &
& "MED_DESCENDING_FACE ", &
& "MED_DESCENDING_EDGE ", &
& "MED_NODE ", &
& "MED_NODE_ELEMENT "/)
parameter(user_mode = med_compact_stmode )
!! write (*,'(A0)') FMED_GEOMETRIE_NOEUD_AFF(1)
!! write (*,'(A0)') FMED_GEOMETRIE_MAILLE_AFF(1)
!! write (*,'(A0)') FMED_GEOMETRIE_FACE_AFF(1)
!! write (*,'(A0)') FMED_GEOMETRIE_ARETE_AFF(1)
locname=''
nbpdtnor=0;pflsize=0;ngauss=0;nent=0
numdt = 0;numo=0;retmem=0
cret=0;ret=0
nullify(type_geo)
nullify(aff)
select case (entite)
case (med_node)
type_geo => typ_noeud
nb_geo = 1
aff => fmed_geometrie_noeud_aff
case (med_cell)
type_geo => typmai
nb_geo = 17
aff => fmed_geometrie_maille_aff
case (med_node_element)
type_geo => typmai
nb_geo = 17
aff => fmed_geometrie_maille_aff
case (med_descending_face)
type_geo => typfac;
nb_geo = 5
aff => fmed_geometrie_face_aff
case (med_descending_edge)
type_geo => typare
nb_geo = my_nof_descending_edge_type
aff => fmed_geometrie_arete_aff
end select
do k=1,nb_geo
! ** Combien de (PDT,NOR) a lire **
nbpdtnor = ncst
if(nbpdtnor < 1 ) continue
do j=1,ncst
call mfdoci(fid,nomcha,j,numdt,numo,dt, nmesh, mname, lmesh, mnumdt, mnumit, ret)
! print *,'ret=',ret
if (ret.ne.0) then
print *, "Erreur a la demande d'information sur (pdt,nor) : " &
& ,nomcha,entite, numdt, numo, dt
cret = -1
end if
do itm=1,nmesh
call mfdonp(fid,nomcha,numdt,numo,entite,type_geo(k),itm,mname,pflname,locname,nprofile,ret)
! print *,'ret=',ret
if (ret.ne.0) then
print *, "Erreur a la lecture du nombre de profil : " &
& ,nomcha,entite, type_geo(k),numdt, numo
cret = -1
call efexit(cret)
end if
do l=1,nprofile
! ** Combien de valeurs à lire ? **
call mfdonv(fid,nomcha,numdt,numo,entite,type_geo(k),mname,l, &
& user_mode,pflname,pflsize,locname,ngauss,nent,ret)
! print *,'ret=',ret
if (ret.ne.0) then
print *,"Erreur a la lecture du nombre de valeurs du champ : " &
& ,nomcha,entite,type_geo(k), &
& numdt, numo
cret = -1; continue
endif
!write(*,'(5X,A,I5,A)') 'Il y a ', nent ,' valeurs a lire '
write(*,'(5X,A,I2,A,I2,A,I2,A,E10.5,A)') 'Étape de calcul n° ',l,' (',numdt,',',numo,'), dt=(',dt,')'
write(*,'(5X,A,I5,A,I2,A,A,A,A,A,A,I2,A,A)') &
& 'Il y a ',nent,' valeurs en mode ',user_mode, &
& '. Chaque entite ',trim(fmed_entite_maillage_aff(entite)), &
& ' de type geometrique ',trim(aff(k)),' associes au profil |',&
& trim(pflname)//'| a ',ngauss,' valeur(s) par entité une localization de nom |',trim(locname)//'|'
print *,'Le maillage associe est ', mname
! **Lecture des valeurs du champ **
if (typcha .eq. med_float64) then
allocate(valr(ncomp*nent*ngauss),stat=retmem)
call mfdorr(fid,nomcha,numdt,numo,entite,type_geo(k),mname,user_mode, &
& pflname,stockage,med_all_constituent,valr,ret)
! print *,'ret=',ret
if (ret.ne.0) then
print *,"Erreur a la lecture des valeurs du champ : ", &
& nomcha,valr,stockage,med_all_constituent, &
& pflname,user_mode,entite,type_geo(k),numdt,numo
cret = -1;
call efexit(cret)
endif
else
allocate(vale(ncomp*nent*ngauss),stat=retmem)
call mfdoir(fid,nomcha,numdt,numo,entite,type_geo(k),mname,user_mode, &
& pflname,stockage,med_all_constituent,vale,ret)
! print *,'ret=',ret
if (ret.ne.0) then
print *,"Erreur a la lecture des valeurs du champ : ",&
& nomcha,vale,stockage,med_all_constituent, &
& pflname,user_mode,entite,type_geo(k),numdt,numo
cret = -1;
endif
endif
if (ngauss .gt. 1 ) then
write (*,'(5X,A,A,A)') "- Modèle de localisation des ", &
& "points de Gauss de nom ", trim(locname)
end if
if ( entite .eq. med_node_element ) then
ngroup = mod(type_geo(k),100)
else
ngroup = ngauss
end if
select case (stockage)
case (med_full_interlace)
write(*,'(5X,A)') "- Valeurs :"; write(*,'(5X,A)') ""
do m=0,nent-1
write(*,*) "|"
do n=0,(ngroup*ncomp-1)
if (typcha .eq. med_float64) then
write (*,'(1X,E20.5,1X)') valr( m*ngroup*ncomp+n +1 )
else
write (*,'(1X,I8,1X)') vale( m*ngroup*ncomp+n +1 )
end if
enddo
enddo
case (med_no_interlace)
write(*,'(5X,A)') "- Valeurs :"; write(*,'(5X,A)') ""
do m=0,ncomp-1
write(*,*) "|"
do n=0,nent-1
if (typcha .eq. med_float64) then
write (*,'(1X,E20.5,1X)') valr(m*nent+n +1)
else
write (*,'(1X,I8,1X)') vale(m*nent+n +1)
endif
enddo
enddo
end select
write(*,*) "|"
if (typcha .eq. med_float64) then
deallocate(valr)
else
deallocate(vale)
endif
!* Profils
if (pflname .eq. med_no_profile) then
!write(*,'(5X,A)') 'Pas de profil'
else
write(*,'(5X,A,A)') 'Profil :',pflname
call mpfpsn(fid,pflname,pflsize,ret)
if (ret .ne. 0) then
print *,"Erreur a la lecture du nombre de valeurs du profil : ", &
& pflname,pflsize
cret = -1;continue
endif
write(*,'(5X,A,I5)') 'Taille du profil : ',pflsize
! ** allocation memoire de pflval **
allocate(pflval(pflsize),stat=retmem)
if (retmem .ne. 0) then
print *, "Erreur a l'allocation mémoire de pflsize : "
call efexit(-1)
endif
call mpfprr(fid,pflname,pflval,ret)
if (cret .ne. 0) write(*,'(I1)') cret
if (ret .ne. 0) then
print *,"Erreur a la lecture du profil : ", &
& pflname,pflval
cret = -1;continue
endif
write(*,'(5X,A)') 'Valeurs du profil : '
do m=1,pflsize
write (*,'(5X,I6)') pflval(m)
enddo
deallocate(pflval)
endif
enddo
enddo
enddo
enddo
print *,""
getfieldson=ret
end function getfieldson
mfdfdi
subroutine mfdfdi(fid, it, fname, mname, lmesh, type, cname, cunit, dtunit, nc, cret)
Cette fonction permet de lire les informations concernant le champ d'indice ind .
Definition medfield.f:248
mfdoci
subroutine mfdoci(fid, fname, it, numdt, numit, dt, nmesh, mname, lmesh, mnumdt, mnumit, cret)
Cette fonction permet de lire les informations caractérisant une étape de calcul : numéro de pas de t...
Definition medfield.f:653
mfdonv
subroutine mfdonv(fid, fname, numdt, numit, etype, gtype, mname, pit, stm, pname, psize, lname, nip, n, cret)
Cette fonction permet de lire le nombre de valeurs à lire dans un champ pour une étape de calcul,...
Definition medfield.f:706
mfdnfd
subroutine mfdnfd(fid, n, cret)
Cette fonction permet de lire le nombre de champs dans un fichier.
Definition medfield.f:180
mfdnfc
subroutine mfdnfc(fid, ind, n, cret)
Cette fonction lit le nombre de composantes d'un champ.
Definition medfield.f:202
mfdonp
subroutine mfdonp(fid, fname, numdt, numit, etype, gtype, it, mname, dpname, dlname, n, cret)
Cette fonction permet de lire le nombre de profils référencés dans un champ pour une étape de calcul,...
Definition medfield.f:678
mfiope
subroutine mfiope(fid, name, access, cret)
Ouverture d'un fichier MED.
Definition medfile.f:42
mficlo
subroutine mficlo(fid, cret)
Fermeture d'un fichier MED.
Definition medfile.f:82
mlnlir
subroutine mlnlir(fid, mname, lname, cret)
Cette routine permet de lire un lien dans un fichier MED.
Definition medlink.f:102
mlnnln
subroutine mlnnln(fid, n, cret)
Cette routine permet la lecture du nombre de lien dans un fichier MED.
Definition medlink.f:38
mlnlni
subroutine mlnlni(fid, it, mname, lsize, cret)
Cette routine permet de lire les informations sur un lien dans un fichier MED.
Definition medlink.f:60
mlcnlc
subroutine mlcnlc(fid, n, cret)
Cette routine permet de lire le nombre de localisations de points d'intégration contenues dans un fic...
Definition medlocalization.f:41
mlclci
subroutine mlclci(fid, it, lname, gtype, sdim, nip, giname, isname, nsmc, sgtype, cret)
Cette routine permet d'obtenir la description de la localisation de points d'intégration n° localizat...
Definition medlocalization.f:64
mmhmii
subroutine mmhmii(fid, it, name, sdim, mdim, mtype, desc, dtunit, stype, nstep, atype, aname, aunit, cret)
Cette routine permet de lire les informations relatives à un maillage dans un fichier.
Definition medmesh.f:110
mpfnpf
subroutine mpfnpf(fid, n, cret)
Cette routine permet de lire le nombre de profils dans un fichier MED.
Definition medprofile.f:39
mpfpsn
subroutine mpfpsn(fid, pname, psize, cret)
Cette routine permet de lire la taille d'un profil dont on connait le nom.
Definition medprofile.f:79
mpfpfi
subroutine mpfpfi(fid, it, pname, psize, cret)
Cette routine permet de lire les informations sur un profil dans un fichier MED.
Definition medprofile.f:61
med_float64
double med_float64
Definition med.h:328
mfdorr
subroutine mfdorr(fid, fname, numdt, numit, etype, gtype, mname, stm, pname, swm, cs, val, cret)
Definition medfield.f:738
mfdoir
subroutine mfdoir(fid, fname, numdt, numit, etype, gtype, mname, stm, pname, swm, cs, val, cret)
Definition medfield.f:763
mlclor
subroutine mlclor(fid, lname, swm, ecoo, ipcoo, wght, cret)
Definition medlocalization.f:106
mpfprr
subroutine mpfprr(fid, pname, profil, cret)
Definition medprofile.f:97
getfieldson
integer function getfieldson(fid, nomcha, typcha, ncomp, entite, stockage, ncst)
Definition test11b.f90:274
test11
program test11
Definition test11b.f90:26