test11.f90
Aller à la documentation de ce fichier.
!* This file is part of MED.
!*
!* COPYRIGHT (C) 1999 - 2021 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_pflmode)
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
write(*,'(5X,A,I1)') 'Nombre de composantes = ',ncomp
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) &
&,"| et nbr. de pts Gauss ",ngauss,"| et 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 :: 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
character*16 :: dt_unit
character*255:: lien
integer user_mode
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 mfdcsi(fid,nomcha,j,numdt,numo,dt,ret)
!print *,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
call mfdnpf(fid,nomcha,numdt,numo,entite,type_geo(k),pflname,locname,nprofile,ret)
!print *,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 mfdnvp(fid,nomcha,numdt,numo,entite,type_geo(k),l,user_mode,pflname,pflsize,locname,ngauss,nent,ret)
!print *,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é, et une localization de nom |',trim(locname)//'|'
! **Lecture des valeurs du champ **
if (typcha .eq. med_float64) then
allocate(valr(ncomp*nent*ngauss),stat=retmem)
call mfdrpr(fid,nomcha,numdt,numo,entite,type_geo(k),user_mode, &
& pflname,stockage,med_all_constituent,valr,ret)
!print *,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 mfdipr(fid,nomcha,numdt,numo,entite,type_geo(k),user_mode, &
& pflname,stockage,med_all_constituent,vale,ret)
!print *,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
print *,""
getfieldson=ret
end function getfieldson
mpfnpf
subroutine mpfnpf(fid, n, cret)
Cette routine permet de lire le nombre de profils dans un fichier MED.
Definition: medprofile.f:39
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
getfieldson
integer function getfieldson(fid, nomcha, typcha, ncomp, entite, stockage, ncst)
Definition: test11.f90:275
mficlo
subroutine mficlo(fid, cret)
Fermeture d'un fichier MED.
Definition: medfile.f:82
mfdnfd
subroutine mfdnfd(fid, n, cret)
Cette fonction permet de lire le nombre de champs dans un fichier.
Definition: medfield.f:180
mfdcsi
subroutine mfdcsi(fid, fname, it, numdt, numit, dt, cret)
Cette fonction permet de lire les informations caractérisant une étape de calcul : numéro de pas de t...
Definition: medfield.f:290
test11
program test11
Definition: test11.f90:26
mfiope
subroutine mfiope(fid, name, access, cret)
Ouverture d'un fichier MED.
Definition: medfile.f:42
mfdipr
subroutine mfdipr(fid, fname, numdt, numit, etype, gtype, stm, pname, swm, cs, val, cret)
Cette fonction permet de lire les valeurs d'un champ définies sur des entités d'un maillage pour une ...
Definition: medfield.f:528
mfdrpr
subroutine mfdrpr(fid, fname, numdt, numit, etype, gtype, stm, pname, swm, cs, val, cret)
Cette fonction permet de lire les valeurs d'un champ définies sur des entités d'un maillage pour une ...
Definition: medfield.f:505
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
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
mpfprr
subroutine mpfprr(fid, pname, profil, cret)
Cette routine permet de lire un profil dans un fichier MED.
Definition: medprofile.f:97
mlnlir
subroutine mlnlir(fid, mname, lname, cret)
Cette routine permet de lire un lien dans un fichier MED.
Definition: medlink.f:102
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
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
mlnnln
subroutine mlnnln(fid, n, cret)
Cette routine permet la lecture du nombre de lien dans un fichier MED.
Definition: medlink.f:38
mfdnfc
subroutine mfdnfc(fid, ind, n, cret)
Cette fonction lit le nombre de composantes d'un champ.
Definition: medfield.f:202
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
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
mfdnvp
subroutine mfdnvp(fid, fname, numdt, numit, etype, gtype, 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:406
mfdnpf
subroutine mfdnpf(fid, fname, numdt, numit, etype, gtype, 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:354
mlclor
subroutine mlclor(fid, lname, swm, ecoo, ipcoo, wght, cret)
Cette routine permet la lecture d'une localisation localizationname de points d'intégration dans/auto...
Definition: medlocalization.f:106
med_float64
double med_float64
Definition: med.h:337