test11.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_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 mmoire 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 stocks : ', 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 mmoire de refcoo : "
call efexit(-1)
endif;
allocate(gscoo(t2),stat=retmem)
if (retmem .ne. 0) then
print *, é"Erreur a l'allocation mmoire de gscoo : "
call efexit(-1)
endif;
allocate(wg(t3),stat=retmem)
if (retmem .ne. 0) then
print *, é"Erreur a l'allocation mmoire 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)') è"- Modle 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 mmoire 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
med_float64
double med_float64
Definition build.python3.12/include/med.h:328
mfdnpf
subroutine mfdnpf(fid, fname, numdt, numit, etype, gtype, dpname, dlname, n, cret)
Definition medfield.f:354
mfdfdi
subroutine mfdfdi(fid, it, fname, mname, lmesh, type, cname, cunit, dtunit, nc, cret)
Definition medfield.f:248
mfdipr
subroutine mfdipr(fid, fname, numdt, numit, etype, gtype, stm, pname, swm, cs, val, cret)
Definition medfield.f:528
mfdrpr
subroutine mfdrpr(fid, fname, numdt, numit, etype, gtype, stm, pname, swm, cs, val, cret)
Definition medfield.f:505
mfdnfd
subroutine mfdnfd(fid, n, cret)
Definition medfield.f:180
mfdnfc
subroutine mfdnfc(fid, ind, n, cret)
Definition medfield.f:202
mfdcsi
subroutine mfdcsi(fid, fname, it, numdt, numit, dt, cret)
Definition medfield.f:290
mfdnvp
subroutine mfdnvp(fid, fname, numdt, numit, etype, gtype, pit, stm, pname, psize, lname, nip, n, cret)
Definition medfield.f:406
mfiope
subroutine mfiope(fid, name, access, cret)
Definition medfile.f:42
mficlo
subroutine mficlo(fid, cret)
Definition medfile.f:82
mlnlir
subroutine mlnlir(fid, mname, lname, cret)
Definition medlink.f:102
mlnnln
subroutine mlnnln(fid, n, cret)
Definition medlink.f:38
mlnlni
subroutine mlnlni(fid, it, mname, lsize, cret)
Definition medlink.f:60
mlcnlc
subroutine mlcnlc(fid, n, cret)
Definition medlocalization.f:41
mlclci
subroutine mlclci(fid, it, lname, gtype, sdim, nip, giname, isname, nsmc, sgtype, cret)
Definition medlocalization.f:64
mlclor
subroutine mlclor(fid, lname, swm, ecoo, ipcoo, wght, cret)
Definition medlocalization.f:106
mmhmii
subroutine mmhmii(fid, it, name, sdim, mdim, mtype, desc, dtunit, stype, nstep, atype, aname, aunit, cret)
Definition medmesh.f:110
mpfprr
subroutine mpfprr(fid, pname, profil, cret)
Definition medprofile.f:97
mpfnpf
subroutine mpfnpf(fid, n, cret)
Definition medprofile.f:39
mpfpsn
subroutine mpfpsn(fid, pname, psize, cret)
Definition medprofile.f:79
mpfpfi
subroutine mpfpfi(fid, it, pname, psize, cret)
Definition medprofile.f:61
getfieldson
integer function getfieldson(fid, nomcha, typcha, ncomp, entite, stockage, ncst)
Definition test11.f90:275
test11
program test11
Definition test11.f90:26