我在英特尔Fortran-90中有这些代码行和XML文件：
Principal.f90：
!---------------------------------------------------------------------------
! `
! GOAL : Solve, by means of finite elements, the electrostatics 3D
! PDE with different boundary conditions and charges
!
! | -div(permi grad(V))=f
! (1) | V = V+ on Dirichlet boundary
! | permi d(V)/dn=g
!
! Dolores Gomez
! MC Mu�iz
! Jose Luis Ferrin Gonzalez
!
!---------------------------------------------------------------------------
program ppalelectros3D
use fich_electros3D
use electros3D
use cargavol
use cargacur
use cargapun
use permitividad
use bloqueo
use derivados3D
use malla_3DP1
use external_electros3D
use module_writeVTU
use comprobaciones
use module_convers
use module_fem_extract
use module_conver3d, only: conver3d
use LIB_VTK_IO_READ
use module_readUNV
use module_compiler_dependant
implicit none
integer :: i,istat, p, nnod,DIMS,LNN,LNV,LNE,LNF,nnd,nco,npieces,nverteta,iformat
integer, allocatable :: nn(:,:)
real(real64), allocatable :: evtun(:)
!---------------------------------------------------------------------------
! INPUT DATA
!---------------------------------------------------------------------------
if (command_argument_count() == 0) then
call endat3D()
else
call readxml()
end if
! INPUT DATA VERIFICATION, FOR ENDAT & READXML
if (.not. comprueba()) then
write(error_unit,*) 'Input data check failed'
stop 1
else
write(output_unit,*) 'Input data check passed'
endif
call calculate_funs()
! 0.0 IS ASSIGNED TO THE LAST VERTEX IN CASE OF NOT HAVING DIRICHLET CONDITIONS
if (blocking_node() < 0) then
write(error_unit,*) 'Error assigning blocking node'
stop 1
endif
!---------------------------------------------------------------------------
! ELECTROMAGNETIC MESH READING
!---------------------------------------------------------------------------
call calindc(indc,inda)
p = index(fichma, '.', back=.true.)
if (p == 0) stop 'Mesh file has not extension: unable to identify mesh format'
select case (lcase(fichma(p+1:len_trim(fichma))))
case('mfm')
iformat=1
call leema3D(iformat)
case('mum')
iformat=2
call leema3D(iformat)
case('unv')
call readUNV(fichma,nel,nnod,nver,dims,LNN,LNV,LNE,LNF,nn,mm,nrc,nra,nrv,z,nsd)
call conver3d(nel, nver, mm, z, nemm, det, binv, ib, jb)
case default
stop 'Unrecognized mesh file extension'
end select
call alloc_after_mesh()
!---------------------------------------------------------------------------
! TEMPERATURE READING
!---------------------------------------------------------------------------
if (iopteta == 1) call leetmp()
!---------------------------------------------------------------------------
! COMPUTATIONS
!---------------------------------------------------------------------------
if (iopblo.eq.1.and.iopblo1.eq.1) then
call calprebloqueof(nrd,irefd)
endif
if (iopblo.eq.1.and.iopblo2.eq.1) then
call calprebloqueoc(blofron%numero,blofron%referencias)
endif
call electrostatica3D()
if(allocated(vexac))deallocate(vexac)
allocate(vexac(nver),stat=ierror)
if (ierror.ne.0) then
print*,'Error while allocating array vexac',nver
stop 1
endif
if(allocated(err))deallocate(err)
allocate(err(nver),stat=ierror)
if (ierror.ne.0) then
print*,'Error while allocating array err',nver
stop 1
endif
! call wrtcmp(nver,sol,10,fichsol)
! call writeVTU(nel,nver,mm,z,'tetra',sol,'solucion','scalar', &
! 'node',trim(fichsol)//'.vtu')
! -1: mixed functions
! 0: no data
! 1: User defined / Function defined by user
! ...
if (dir%funs > 1.or.&
neu%funs > 1.or.&
vol%funs > 1.or.&
sup%funs > 1.or.&
cur%funs > 1) then
do i=1,nver
vexac(i) = fexac(z(1,i),z(2,i),z(3,i))
err(i) = dabs(vexac(i)-sol(i))
enddo
if (dir%funs == 7) then ! 'Example 6'
vexac(376) = sol(376)
vexac(193) = sol(193)
err(193) = dabs(vexac(193)-sol(193))
err(376) = dabs(vexac(376)-sol(376))
elseif (dir%funs == 6) then ! 'Example 5'
vexac(1292) = sol(1292)
err(1292) = dabs(vexac(1292)-sol(1292))
endif
call norl2_3D(sol,xnorexac)
call norl2_3D(vexac,xnorexac)
call norl2_3D(err,xnorerr)
rel = xnorerr/xnorexac
print*,'Relative error (%)',100*rel
endif
! COMPUTATION OF THE ELECTRIC FIELD
call ef()
!---------------------------------------------------------------------------
! RESULTS OUTPUT
!---------------------------------------------------------------------------
call wrtcmp(nver,sol,10,fichsol)
call writeVTU(nel,nver,mm,z,'tetra',sol,'Potential (V)','scalar', &
'node',trim(fichsol)//'.vtu')
call wrtcmpv(nel,e,10,fichgradsol)
if(allocated(evtu))deallocate(evtu)
allocate(evtu(3*nel),STAT=istat)
if (istat.ne.0) stop 'Error while allocating evtu in principal'
evtu(1:nel*3:3)=e(1,1:nel)
evtu(2:nel*3:3)=e(2,1:nel)
evtu(3:nel*3:3)=e(3,1:nel)
call cell2node(nver, mm, evtu, evtun)
call writeVTU(nel,nver,mm,z,'tetra',evtun,'Electric field (V/m)',&
'vector','node',trim(fichgradsol)//'.vtu')
deallocate(evtu,STAT=istat)
if (istat.ne.0) stop 'Error while deallocating in principal'
deallocate(sol,STAT=istat)
if (istat.ne.0) stop 'Error while deallocating in principal'
deallocate(e,STAT=istat)
if (istat.ne.0) stop 'Error while deallocating in principal'
stop 'End of the execution'
end
readxml.f90
!-----------------------------------------------------------------------
! procedure for reading the solver variables
!-----------------------------------------------------------------------
subroutine readxml()
use module_SO_DEPENDANT
use module_REPORT
use module_xml_parser
!Solver modules
use fich_electros3D
use electros3D, DOUBLElocal1 => DOUBLE
use cargavol, DOUBLElocal2 => DOUBLE
use cargacur, DOUBLElocal3 => DOUBLE
use cargapun, DOUBLElocal4 => DOUBLE
use permitividad, DOUBLElocal5 => DOUBLE
use bloqueo, DOUBLElocal6 => DOUBLE
use derivados3D, DOUBLElocal7 => DOUBLE
use auxiliar_cargas
implicit none
integer :: i, j, pos, ide, im, fnum
real(DOUBLE) :: cval
real(DOUBLE), dimension(:), allocatable :: xcp, aux
character(len=MAXPATH) :: matxml, sval, tval
character(len=MAXPATH), dimension(:), allocatable :: list, list2, list3, refs
call set_SO()
call set_report_level(REPORT_STDOUT)
! inicializacion de variables (array)
! fun_0 == User defined / Function defined by user
dir%fun = 1
neu%fun = 1
vol%fun = 1
sup%fun = 1
cur%fun = 1
ide = fopen()
!Mesh
call fread(ide, '/Mesh/Open/Mesh file', fichma)
!Boundary Condicions
print*,'Neumann'
!Neumann conditions
iopneu = 0; iopneu1 = 0; iopneu2 = 0
nrn = 0
neuman%numero = 0
call flist(ide, '/Boundary conditions/Neumann/Conditions/', list)
do i = 1, size(list,1) !loop for defined Neumann BC's
call flist(ide, '/Boundary conditions/Neumann/Conditions/'//trim(list(i)), list2)
do j = 1, size(list2,1) !loop for data type for each BC
select case(trim(list2(j)))
case('A function')
!References
call fread_alloc(ide, '/Boundary conditions/Neumann/Conditions/'//trim(list(i))//&
&'/A function/Surface references', refs, realloc=.true.)
if (size(refs,1)>0) then
iopneu = 1
iopneu1 = 1 ! ok
!Function
call fread(ide, '/Boundary conditions/Neumann/Conditions/'//trim(list(i))//&
&'/A function/Function name', sval)
pos = nrn + 1
irefn(pos:pos+size(refs,1)-1) = int(refs)
fnum = function_number(sval,functions)
if (fnum == 0) call error('readxml: unknown function: '//sval)
neu%fun(pos:pos+size(refs,1)-1) = fnum
nrn = nrn + size(refs,1)
else
print * , 'Function Neumann B.C. with 0 references: skipping'
endif
case('A constant')
!References
call fread_alloc(ide, '/Boundary conditions/Neumann/Conditions/'//trim(list(i))//&
&'/A constant/Surface references', refs, realloc=.true.)
if (size(refs,1)>0) then
iopneu = 1
iopneu2 = 1 ! ok
!Constant value
call fread(ide, '/Boundary conditions/Neumann/Conditions/'//trim(list(i))//&
&'/A constant/Constant value', cval)
pos = neuman%numero + 1
neuman%referencias(pos:pos+size(refs,1)-1) = int(refs)
neuman%numero = neuman%numero + size(refs,1)
neuman%valor(pos:pos+size(refs,1)-1) = cval
else
print * , 'Constant Neumann B.C. with 0 references: skipping'
endif
case default; call error('readxml: Case not implemented.')
end select
enddo
enddo
print*,'Dirichlet'
!Potential (Dirichlet) conditions
iopblo = 0; iopblo1 = 0; iopblo2 = 0; iopblo3 = 0
nrd = 0
blofron%numero = 0
blopun%numero = 0
call flist(ide, '/Boundary conditions/Dirichlet/Conditions', list)
do i = 1, size(list,1) !loop for defined potential BC's
call flist(ide, '/Boundary conditions/Dirichlet/Conditions/'//trim(list(i)), list2)
do j = 1, size(list2,1) !loop for data type for each BC
select case(trim(list2(j)))
case('A function')
!References
call fread_alloc(ide, '/Boundary conditions/Dirichlet/Conditions/'//trim(list(i))//&
&'/A function/Surface references', refs, realloc=.true.)
if (size(refs,1)>0) then
iopblo = 1
iopblo1 = 1 ! ok
!Function
call fread(ide, '/Boundary conditions/Dirichlet/Conditions/'//trim(list(i))//&
&'/A function/Function name', sval)
pos = nrd + 1
irefd(pos:pos+size(refs,1)-1) = int(refs)
fnum = function_number(sval,functions)
if (fnum == 0) call error('readxml: unknown function: '//sval)
dir%fun(pos:pos+size(refs,1)-1) = fnum
nrd = nrd + size(refs,1)
else
print * , 'Function Dirichlet B.C. with 0 references: skipping'
endif
case('A constant')
!References
call fread_alloc(ide, '/Boundary conditions/Dirichlet/Conditions/'//trim(list(i))//&
&'/A constant/Surface references', refs, realloc=.true.)
if (size(refs,1)>0) then
iopblo = 1
iopblo2 = 1 ! ok
!Constant value
call fread(ide, '/Boundary conditions/Dirichlet/Conditions/'//trim(list(i))//&
&'/A constant/Constant value', cval)
pos = blofron%numero + 1
blofron%referencias(pos:pos+size(refs,1)-1) = int(refs)
blofron%numero = blofron%numero + size(refs,1)
blofron%valor(pos:pos+size(refs,1)-1) = cval
else
print * , 'Constant Dirichlet B.C. with 0 references: skipping'
endif
! case('Point')
! iopblo3 = 1 ! ok
! !References
! call fread_alloc('/B.C./Define.../B.C. type/Potential/'//trim(list(i))//&
! &'/Point/Reference number(s)', refs, realloc=.true.)
! !Constant value
! call fread('/B.C./Define.../B.C. type/Potential/'//trim(list(i))//&
! &'/Point/Constant value', cval)
! if (size(refs,1)>0)
! iopblo3 = 1 ! ok
! pos = blopun%numero + 1
! blopun%referencias(pos:pos+size(refs,1)-1) = int(refs)
! blopun%numero = blopun%numero + size(refs,1)
! blopun%valor(pos:pos+size(refs,1)-1) = cval
! else
! print * , 'Dirichlet B.C. with 0 references: skipping'
! endif
case default; call error('readxml: Case not implemented.')
end select
enddo
enddo
! 2010-02-08,11: Blocking node and Blocking value
! 2010-09-21: comentado
!print*,'Blocking node and blocking value'
! call fread_alloc(ide, '/Data/Blocking for Neumann problem/'//&
! &'Blocking for Neumann problem/Blocking node', xcp, realloc=.true.)
! call fread_alloc(ide, '/Data/Blocking for Neumann problem/'//&
! &'Blocking for Neumann problem/Blocking value', aux, realloc=.true.)
! if ( size(xcp,1) > 1 ) call error('readxml: Only 0 or 1 blocking node allowed')
! if ( size(aux,1) > 1 ) call error('readxml: Only 0 or 1 blocking value allowed')
! if ( ( size(xcp,1) == 1 ) .and. ( size(aux,1) /= 1 ) )&
! &call error('readxml: Found blocking node but no blocking value')
! if ( ( size(aux,1) == 1 ) .and. ( size(xcp,1) /= 1 ) )&
! &call error('readxml: Found blocking value but no blocking node')
! if ( ( size(xcp,1) == 1 ) .and. ( size(aux,1) == 1 ) ) then
! iopblo = 1
! iopblo3 = 1
! blopun%numero = blopun%numero + 1
! blopun%referencias(blopun%numero) = int(xcp(1))
! blopun%valor(blopun%numero) = aux(1)
! end if
!Sources
print*,'Volume sources'
!Volumic sources
iopvol = 0 ! 1 => hai volumic sources
carvol%numero = 0
call flist(ide, '/Sources/Volumetric/Volumetric sources', list)
do i = 1, size(list,1) !loop for defined volumic sources
call flist(ide, '/Sources/Volumetric/Volumetric sources/'//trim(list(i)), list2)
if (size(list2,1)/=1) call error('readxml: Incorrect number of childs in volume source.')
if (trim(list2(1)) == 'A function') then
!References
call fread_alloc(ide, '/Sources/Volumetric/Volumetric sources/'//trim(list(i))//&
&'/A function/Domain references', refs, realloc=.true.)
if (size(refs,1)>0) then
iopvol = 1
!Function
call fread(ide, '/Sources/Volumetric/Volumetric sources/'//trim(list(i))//&
&'/A function/Function name', sval)
pos = carvol%numero + 1
carvol%referencias(pos:pos+size(refs,1)-1) = int(refs)
carvol%numero = carvol%numero + size(refs,1)
carvol%valor(pos:pos+size(refs,1)-1) = 0.d0
fnum = function_number(sval,functions)
if (fnum == 0) call error('readxml: unknown function: '//sval)
vol%fun(pos:pos+size(refs,1)-1) = fnum
carvol%constante(pos:pos+size(refs,1)-1) = .FALSE.
else
print * , 'Function volume source with 0 references: skipping'
endif
elseif (trim(list2(1)) == 'A constant') then
!References
call fread_alloc(ide, '/Sources/Volumetric/Volumetric sources/'//trim(list(i))//&
&'/A constant/Domain references', refs, realloc=.true.)
if (size(refs,1)>0) then
iopvol = 1
!Constant value
call fread(ide, '/Sources/Volumetric/Volumetric sources/'//trim(list(i))//&
&'/A constant/Constant value', cval)
pos = carvol%numero + 1
carvol%referencias(pos:pos+size(refs,1)-1) = int(refs)
carvol%numero = carvol%numero + size(refs,1)
carvol%valor(pos:pos+size(refs,1)-1) = cval
carvol%constante(pos:pos+size(refs,1)-1) = .TRUE.
else
print * , 'Constant volume source with 0 references: skipping'
endif
else
call error('readxml: Incorrect volume source child: '//trim(list2(1))//'.')
endif
enddo
print*,'Surface sources'
!Surface sources
iopsup = 0 ! 1 => hai surface sources
carsup%numero = 0
call flist(ide, '/Sources/Surface/Surface sources', list)
do i = 1, size(list,1) !loop for defined surface sources
call flist(ide, '/Sources/Surface/Surface sources/'//trim(list(i)), list2)
if (size(list2,1)/=1) call error('readxml: Incorrect number of childs in surface source.')
if (trim(list2(1)) == 'A function') then
!References
call fread_alloc(ide, '/Sources/Surface/Surface sources/'//trim(list(i))//&
&'/A function/Surface references', refs, realloc=.true.)
if (size(refs,1)>0) then
iopsup = 1
!Function
call fread(ide, '/Sources/Surface/Surface sources/'//trim(list(i))//&
&'/A function/Function name', sval)
pos = carsup%numero + 1
carsup%referencias(pos:pos+size(refs,1)-1) = int(refs)
carsup%numero = carsup%numero + size(refs,1)
carsup%valor(pos:pos+size(refs,1)-1) = 0.d0
fnum = function_number(sval,functions)
if (fnum == 0) call error('readxml: unknown function: '//sval)
sup%fun(pos:pos+size(refs,1)-1) = fnum
carsup%constante(pos:pos+size(refs,1)-1) = .FALSE.
else
print * , 'Function surface source with 0 references: skipping'
endif
elseif (trim(list2(1)) == 'A constant') then
!References
call fread_alloc(ide, '/Sources/Surface/Surface sources/'//trim(list(i))//&
&'/A constant/Surface references', refs, realloc=.true.)
if (size(refs,1)>0) then
iopsup = 1
!Constant value
call fread(ide, '/Sources/Surface/Surface sources/'//trim(list(i))//&
&'/A constant/Constant value', cval)
pos = carsup%numero + 1
carsup%referencias(pos:pos+size(refs,1)-1) = int(refs)
carsup%numero = carsup%numero + size(refs,1)
carsup%valor(pos:pos+size(refs,1)-1) = cval
carsup%constante(pos:pos+size(refs,1)-1) = .TRUE.
else
print * , 'Constant surface source with 0 references: skipping'
endif
else
call error('readxml: Incorrect surface source child: '//trim(list2(1))//'.')
endif
enddo
print*,'Line sources'
!Curvilinear sources
iopcur = 0 ! 1 => hai line sources
carcur%numero = 0
...
end subroutine
和XML文件 local.dat.xml ：
<?xml version="1.0" encoding="ISO-8859-15"?>
-<data>
-<menu name="Materials file">
-<submenu name="Open">
-<leaf name="materialsDB" type="file" totalnum="1">
<elements> materials.dat.xml </elements>
</leaf>
</submenu>
</menu>
-<menu name="Mesh">
-<submenu name="Open">
-<leaf name="Mesh file" type="file" totalnum="1" subtype="mesh">
<elements> malla3Dcs_tet.mfm </elements>
</leaf>
</submenu>
</menu>
-<menu name="Properties">
-<submenu name="Materials">
-<struct name="Materials">
-<leaf name="1" type="charlist" totalnum="1">
<elements> Test Material 2 </elements>
</leaf>
-<leaf name="2" type="charlist" totalnum="1">
<elements> Test Material 3 </elements>
</leaf>
</struct>
</submenu>
</menu>
-<menu name="Boundary conditions">
-<submenu name="Dirichlet">
-<struct name="Conditions">
-<struct name="Condition 1">
-<struct name="A constant">
-<leaf name="Surface references" type="charlist" totalnum="8">
<elements> 1 2 3 4 9 10 13 16 </elements>
</leaf>
-<leaf name="Constant value" type="float" totalnum="1">
<elements> 5.64716513 </elements>
</leaf>
</struct>
</struct>
</struct>
</submenu>
-<submenu name="Neumann">
<struct name="Conditions"> </struct>
</submenu>
</menu>
-<menu name="Sources">
-<submenu name="Volumetric">
-<struct name="Volumetric sources">
-<struct name="Source 1">
-<struct name="A constant">
-<leaf name="Domain references" type="charlist" totalnum="1">
<elements> 2 </elements>
</leaf>
-<leaf name="Constant value" type="float" totalnum="1">
<elements> 3d-10 </elements>
</leaf>
</struct>
</struct>
</struct>
</submenu>
-<submenu name="Surface">
<struct name="Surface sources"> </struct>
</submenu>
-<submenu name="Line">
<struct name="Line sources"> </struct>
</submenu>
-<submenu name="Point">
<struct name="Point sources"> </struct>
</submenu>
</menu>
-<menu name="Data">
-<submenu name="Temperature">
-<leaf name="Field" type="file" totalnum="0" subtype="field">
<elements> </elements>
</leaf>
</submenu>
</menu>
-<menu name="Solver">
<submenu name="Run"> </submenu>
<submenu name="Run remote"> </submenu>
<submenu name="Stop"> </submenu>
</menu>
-<menu name="Visualization">
-<submenu name="Mesh">
-<struct name="Mesh">
<struct name="Triangulation"> </struct>
-<leaf name="Domain references" type="charlist" totalnum="0">
<elements> </elements>
</leaf>
-<leaf name="Surface references" type="charlist" totalnum="0">
<elements> </elements>
</leaf>
-<leaf name="Line references" type="charlist" totalnum="0">
<elements> </elements>
</leaf>
-<leaf name="Point references" type="charlist" totalnum="0">
<elements> </elements>
</leaf>
-<leaf name="Element numbering" type="float" totalnum="0">
<elements> </elements>
</leaf>
-<leaf name="Vertex numbering" type="float" totalnum="0">
<elements> </elements>
</leaf>
<struct name="Materials"> </struct>
<struct name="Slice"> </struct>
<struct name="Cut"> </struct>
<struct name="Rough cut"> </struct>
</struct>
</submenu>
-<submenu name="Temperature field, T (°C, scalar)">
-<struct name="Temperature">
<struct name="Filled"> </struct>
<struct name="Threshold"> </struct>
<struct name="Isosurfaces"> </struct>
<struct name="Plot over line"> </struct>
<struct name="Slice"> </struct>
<struct name="Cut"> </struct>
<struct name="Rough cut"> </struct>
</struct>
</submenu>
-<submenu name="Potential, V (V, scalar)">
-<struct name="Potential">
<struct name="Filled"> </struct>
<struct name="Threshold"> </struct>
<struct name="Isosurfaces"> </struct>
<struct name="Plot over line"> </struct>
<struct name="Slice"> </struct>
<struct name="Cut"> </struct>
<struct name="Rough cut"> </struct>
</struct>
</submenu>
-<submenu name="Electric field, E (V⁄m, vector)">
-<struct name="Electric field">
<struct name="Vectors"> </struct>
-<struct name="Vector components">
-<struct name="X component">
<struct name="Filled"> </struct>
<struct name="Threshold"> </struct>
<struct name="Isosurfaces"> </struct>
<struct name="Plot over line"> </struct>
<struct name="Slice"> </struct>
<struct name="Cut"> </struct>
<struct name="Rough cut"> </struct>
</struct>
-<struct name="Y component">
<struct name="Filled"> </struct>
<struct name="Threshold"> </struct>
<struct name="Isosurfaces"> </struct>
<struct name="Plot over line"> </struct>
<struct name="Slice"> </struct>
<struct name="Cut"> </struct>
<struct name="Rough cut"> </struct>
</struct>
-<struct name="Z component">
<struct name="Filled"> </struct>
<struct name="Threshold"> </struct>
<struct name="Isosurfaces"> </struct>
<struct name="Plot over line"> </struct>
<struct name="Slice"> </struct>
<struct name="Cut"> </struct>
<struct name="Rough cut"> </struct>
</struct>
-<struct name="Modulus">
<struct name="Filled"> </struct>
<struct name="Threshold"> </struct>
<struct name="Isosurfaces"> </struct>
<struct name="Plot over line"> </struct>
<struct name="Slice"> </struct>
<struct name="Cut"> </struct>
<struct name="Rough cut"> </struct>
</struct>
</struct>
</struct>
</submenu>
<submenu name="Close all"> </submenu>
</menu>
</data>
我想知道如何在不更改代码文件的情况下将xml filename参数传递给readxml？作为描述，我想知道Fortran的机制。
任何帮助将不胜感激。 问候。
答案 0 :(得分：0)
我发现如何在不更改代码文件的情况下将xml filename参数传递给readxml。以下是关于fopen中的flist和module_xml_parser.f90等函数：
module module_xml_parser
!-----------------------------------------------------------------------
! Module for reading xml files
! Last update: 26/04/2009
!-----------------------------------------------------------------------
use module_ALLOC
use module_CONVERS
use module_REPORT
use module_FILES
implicit none
!Constants
character(len=*), dimension(4), parameter, private :: OPEN_MARK_MEMBERS = &
(/ '<menu ', '<submenu','<struct ', '<leaf ' /)
character(len=*), dimension(4), parameter, private :: CLOSE_MARK_MEMBERS = &
(/ '</menu ', '</submenu','</struct ', '</leaf ' /)
character(len=*), dimension(1), parameter, private :: OPEN_MARK_LEAF = (/ '<leaf' /)
character(len=*), dimension(1), parameter, private :: CLOSE_MARK_LEAF = (/ '</leaf' /)
character(len=*), dimension(1), parameter, private :: OPEN_MARK_ELEMENT = (/ '<element' /)
character(len=*), dimension(1), parameter, private :: CLOSE_MARK_ELEMENT = (/ '</element' /)
!Class attributes
!Private methods
private :: search_mark_once, search_mark, search_close_mark, follow_path, &
last_part, cut_end_delimiter
private :: fread_real, fread_vreal, fread_vreal_alloc, &
fread_complex, fread_vcomplex, fread_vcomplex_alloc, &
fread_char, fread_vchar, fread_vchar_alloc
!Interfaces
interface fread; module procedure fread_real; end interface
interface fread; module procedure fread_vreal; end interface
interface fread; module procedure fread_complex; end interface
interface fread; module procedure fread_vcomplex; end interface
interface fread; module procedure fread_char; end interface
interface fread; module procedure fread_vchar; end interface
interface fread_alloc; module procedure fread_vreal_alloc; end interface
interface fread_alloc; module procedure fread_vcomplex_alloc; end interface
interface fread_alloc; module procedure fread_vchar_alloc; end interface
contains
!-----------------------------------------------------------------------
! fopen: open a xml file
!-----------------------------------------------------------------------
function fopen(datxml) result(un)
character(len=*), intent(in), optional :: datxml !file name
character(len=MAXPATH) :: xmlfile, arg1
integer :: un !associated unit number
integer :: ios, length, status
!find a valid xmlfile
xmlfile = ' '
if (present(datxml)) then
xmlfile = datxml
else
if (command_argument_count() == 2) then
call get_command_argument(1, arg1, length, status)
if (status /= 0) call error('fopen/get_command_argument, '&
&//'the first command argument cannot be read')
if (trim(adjustl(arg1)) == '-xml') then
call get_command_argument(2, xmlfile, length, status)
if (status /= 0) call error('fopen/get_command_argument, '&
&//'the second command argument cannot be read')
else
call error('fopen/get_command_argument, '&
&//'the first command argument is not recognized (must be -xml)')
endif
elseif (command_argument_count() == 1) then
call get_command_argument(1, arg1, length, status)
if (status /= 0) call error('fopen/get_command_argument, '&
&//'the first command argument cannot be read')
if (trim(adjustl(arg1)) == '-xml') then
xmlfile = 'local.dat.xml'
else
call error('fopen/get_command_argument, '&
&//'the first command argument is not recognized (must be -xml)')
endif
elseif (command_argument_count() == 0) then
xmlfile = 'local.dat.xml'
else
call error('fopen/get_command_argument, '&
&//'too many arguments')
end if
end if
if (len_trim(xmlfile)==0) call error('fopen, filename is empty')
call info('fopen (xmlfile), '//trim(xmlfile))
! open xmlfile
un = get_unit()
open (unit=un, file=xmlfile, form='formatted', iostat=ios, &
status='old', position='rewind')
if (ios /= 0) call error('fopen, #'//trim(string(ios)))
end function
!-----------------------------------------------------------------------
! fread: read data from xml file
!-----------------------------------------------------------------------
subroutine fread_real(un, path, var)
integer, intent(in) :: un
character(len=*), intent(in) :: path
real(DOUBLE), intent(out) :: var
integer :: res, tn = 1
call follow_path(un, path, back = .true.)
if (.not.search_mark_once(un, path, OPEN_MARK_LEAF, name = last_part(path), &
typ='float', tnum=tn)) call error(trim(path)//'), not found')
!get_elements
if (.not.search_mark_once(un, path, OPEN_MARK_ELEMENT)) call error(trim(path)//', not found')
read (un, *, iostat=res) var
if (res /= 0) call error('fread_real/read ('//trim(path)//'), #'//trim(string(res)))
if (.not.search_mark_once(un, path,CLOSE_MARK_ELEMENT)) call error(trim(path)//', not found')
call info('fread_real ('//trim(path)//'), '//trim(string(var)))
end subroutine
!-----------------------------------------------------------------------
! fread: read data from xml file
!-----------------------------------------------------------------------
subroutine fread_vreal(un, path, var)
integer, intent(in) :: un
character(len=*), intent(in) :: path
real(DOUBLE), dimension(:), intent(out) :: var
integer :: res, tn, i
call follow_path(un, path, back = .true.)
!get the total number
tn = -1; if (.not.search_mark_once(un, path, OPEN_MARK_LEAF, name = last_part(path), &
typ='float', tnum=tn)) call error(trim(path)//'), not found')
if (tn > size(var,1)) call error('fread_vreal ('//trim(path)//'), found totalnum '//&
trim(string(tn))//' is bigger than expected '//trim(string(size(var,1))))
!get elements
if (.not.search_mark_once(un, path, OPEN_MARK_ELEMENT)) call error(trim(path)//', not found')
if (tn>0) then
read (un, *, iostat=res) var(1:tn)
if (res /= 0) call error('fread_vreal/read ('//trim(path)//'), #'//trim(string(res)))
endif
if (.not.search_mark_once(un, path,CLOSE_MARK_ELEMENT)) call error(trim(path)//', not found')
do i = 1, tn
call info('fread_vreal ('//trim(path)//'), '//trim(string(var(i))))
enddo
end subroutine
!-----------------------------------------------------------------------
! fread: read data from xml file
!-----------------------------------------------------------------------
subroutine fread_vreal_alloc(un, path, var, realloc)
integer, intent(in) :: un
character(len=*), intent(in) :: path
real(DOUBLE), dimension(:), intent(inout), allocatable :: var
logical, intent(in), optional :: realloc
integer :: res, tn, i
call follow_path(un, path, back = .true.)
!get the total number
tn = -1; if (.not.search_mark_once(un, path, OPEN_MARK_LEAF, name = last_part(path), &
typ='float', tnum=tn)) call error(trim(path)//'), not found')
if (present(realloc)) then; if (realloc) then
if (allocated(var)) call dealloc(var)
endif; endif
if (.not. allocated(var)) call alloc(var, tn)
if (tn > size(var,1)) call error('fread_vreal_alloc ('//trim(path)//'), found totalnum '//&
trim(string(tn))//' is bigger than expected '//trim(string(size(var,1))))
!get elements
if (.not.search_mark_once(un, path, OPEN_MARK_ELEMENT)) call error(trim(path)//', not found')
if (tn>0) then
read (un, *, iostat=res) var(1:tn)
if (res /= 0) call error('fread_vreal/read ('//trim(path)//'), #'//trim(string(res)))
endif
if (.not.search_mark_once(un, path,CLOSE_MARK_ELEMENT)) call error(trim(path)//', not found')
do i = 1, tn
call info('fread_vreal_alloc ('//trim(path)//'), '//trim(string(var(i))))
enddo
end subroutine
!-----------------------------------------------------------------------
! fread: read data from xml file
!-----------------------------------------------------------------------
subroutine fread_complex(un, path, var)
integer, intent(in) :: un
character(len=*), intent(in) :: path
character(len=128) :: tempstring
complex(DOUBLE), intent(out) :: var
integer :: res, tn = 1
call follow_path(un, path, back = .true.)
if (.not.search_mark_once(un, path, OPEN_MARK_LEAF, name = last_part(path), &
typ='complex', tnum=tn)) call error(trim(path)//'), not found')
!get_elements
if (.not.search_mark_once(un, path, OPEN_MARK_ELEMENT)) call error(trim(path)//', not found')
read (un, *, iostat=res) var
if (res /= 0) call error('fread_complex/read ('//trim(path)//'), #'//trim(string(res)))
if (.not.search_mark_once(un, path,CLOSE_MARK_ELEMENT)) call error(trim(path)//', not found')
write(tempstring,*) var
call info('fread_complex ('//trim(path)//'), '//trim(tempstring))
end subroutine
!-----------------------------------------------------------------------
! fread: read data from xml file
!-----------------------------------------------------------------------
subroutine fread_vcomplex(un, path, var)
integer, intent(in) :: un
character(len=*), intent(in) :: path
character(len=128) :: tempstring
complex(DOUBLE), dimension(:), intent(out) :: var
integer :: res, tn, i
call follow_path(un, path, back = .true.)
!get the total number
tn = -1; if (.not.search_mark_once(un, path, OPEN_MARK_LEAF, name = last_part(path), &
typ='complex', tnum=tn)) call error(trim(path)//'), not found')
if (tn > size(var,1)) call error('fread_vcomplex ('//trim(path)//'), found totalnum '//&
trim(string(tn))//' is bigger than expected '//trim(string(size(var,1))))
!get elements
if (.not.search_mark_once(un, path, OPEN_MARK_ELEMENT)) call error(trim(path)//', not found')
if (tn>0) then
read (un, *, iostat=res) var(1:tn)
if (res /= 0) call error('fread_vcomplex/read ('//trim(path)//'), #'//trim(string(res)))
endif
if (.not.search_mark_once(un, path,CLOSE_MARK_ELEMENT)) call error(trim(path)//', not found')
do i = 1, tn
write(tempstring,*) var(i)
call info('fread_vcomplex ('//trim(path)//'), '//trim(tempstring))
enddo
end subroutine
!-----------------------------------------------------------------------
! fread: read data from xml file
!-----------------------------------------------------------------------
subroutine fread_vcomplex_alloc(un, path, var, realloc)
integer, intent(in) :: un
character(len=*), intent(in) :: path
character(len=128) :: tempstring
complex(DOUBLE), dimension(:), intent(inout), allocatable :: var
logical, intent(in), optional :: realloc
integer :: res, tn, i
call follow_path(un, path, back = .true.)
!get the total number
tn = -1; if (.not.search_mark_once(un, path, OPEN_MARK_LEAF, name = last_part(path), &
typ='complex', tnum=tn)) call error(trim(path)//'), not found')
if (present(realloc)) then; if (realloc) then
if (allocated(var)) deallocate(var)
endif; endif
if (.not. allocated(var)) allocate(var(tn))
if (tn > size(var,1)) call error('fread_vcomplex_alloc ('//trim(path)//'), found totalnum '//&
trim(string(tn))//' is bigger than expected '//trim(string(size(var,1))))
!get elements
if (.not.search_mark_once(un, path, OPEN_MARK_ELEMENT)) call error(trim(path)//', not found')
if (tn>0) then
read (un, *, iostat=res) var(1:tn)
if (res /= 0) call error('fread_vcomplex_alloc/read ('//trim(path)//'), #'//trim(string(res)))
endif
if (.not.search_mark_once(un, path,CLOSE_MARK_ELEMENT)) call error(trim(path)//', not found')
do i = 1, tn
write(tempstring,*) var(i)
call info('fread_vcomplex_alloc ('//trim(path)//'), '//trim(tempstring))
enddo
end subroutine
!-----------------------------------------------------------------------
! fread: read data from xml file
!-----------------------------------------------------------------------
subroutine fread_char(un, path, var)
integer, intent(in) :: un
character(len=*), intent(in) :: path
character(len=*), intent(out) :: var
integer :: res, tn = 1
call follow_path(un, path, back = .true.)
if (.not.search_mark_once(un, path, OPEN_MARK_LEAF, name = last_part(path), tnum=tn)) & !typ can be diverse
call error(trim(path)//'), not found')
!get_elements
if (.not.search_mark_once(un, path, OPEN_MARK_ELEMENT)) call error(trim(path)//', not found')
read (un, '(a)', iostat=res) var
var = adjustlt(var)
if (res /= 0) call error('fread_char/read ('//trim(path)//'), #'//trim(string(res)))
if (.not.search_mark_once(un, path,CLOSE_MARK_ELEMENT)) call error(trim(path)//', not found')
call info('fread_char ('//trim(path)//'), '//trim(var))
end subroutine
!-----------------------------------------------------------------------
! fread: read data from xml file
!-----------------------------------------------------------------------
subroutine fread_vchar(un, path, var)
integer, intent(in) :: un
character(len=*), intent(in) :: path
character(len=*), dimension(:), intent(inout) :: var
integer :: res, tn, i
call follow_path(un, path, back = .true.)
!get the total number
tn = -1; if (.not. search_mark_once(un, path, OPEN_MARK_LEAF, name = last_part(path), tnum=tn)) & !typ can be diverse
call error('fread_vchar ('//trim(path)//'), not found')
if (tn > size(var,1)) call error('fread_vchar ('//trim(path)//'), found totalnum '//&
trim(string(tn))//' is bigger than expected '//trim(string(size(var,1))))
!get elements
if (.not.search_mark_once(un, path, OPEN_MARK_ELEMENT)) call error(trim(path)//', not found')
if (tn>0) then
read (un, '(a'//trim(string(len(var(1))))//')', iostat=res) var(1:tn)
if (res /= 0) call error('fread_vreal/read ('//trim(path)//'), #'//trim(string(res)))
endif
if (.not.search_mark_once(un, path,CLOSE_MARK_ELEMENT)) call error(trim(path)//', not found')
do i = 1, tn
var(i) = adjustlt(var(i))
call info('fread_vchar ('//trim(path)//'), '//trim(var(i)))
enddo
end subroutine
!-----------------------------------------------------------------------
! fread: read data from xml file
!-----------------------------------------------------------------------
subroutine fread_vchar_alloc(un, path, var, realloc)
integer, intent(in) :: un
character(len=*), intent(in) :: path
character(len=*), intent(inout), dimension(:), allocatable :: var
logical, intent(in), optional :: realloc
integer :: res, tn, i
call follow_path(un, path, back = .true.)
!get the total number
tn = -1; if (.not. search_mark_once(un, path, OPEN_MARK_LEAF, name = last_part(path), tnum=tn)) & !typ can be diverse
call error('fread_vchar_alloc ('//trim(path)//'), not found')
if (present(realloc)) then; if (realloc) then
if (allocated(var)) call dealloc(var)
endif; endif
if (.not. allocated(var)) call alloc(var, tn)
if (tn > size(var,1)) call error('fread_vreal_alloc ('//trim(path)//'), found totalnum '//&
trim(string(tn))//' is bigger than expected '//trim(string(size(var,1))))
!get elements
if (.not.search_mark_once(un, path, OPEN_MARK_ELEMENT)) call error(trim(path)//', not found')
if (tn>0) then
read (un, '(a'//trim(string(len(var(1))))//')', iostat=res) var(1:tn)
if (res /= 0) call error('fread_vchar/read ('//trim(path)//'), #'//trim(string(res)))
endif
if (.not.search_mark_once(un, path,CLOSE_MARK_ELEMENT)) call error(trim(path)//', not found')
do i = 1, tn
var(i) = adjustlt(var(i))
call info('fread_vchar_alloc ('//trim(path)//'), '//trim(var(i)))
enddo
end subroutine
!-----------------------------------------------------------------------
! flist: list the members of a structure
!-----------------------------------------------------------------------
subroutine flist(un, path, var)
integer, intent(in) :: un
character(len=*), intent(in) :: path
character(len=*), allocatable, dimension(:) :: var
character(len=MAXPATH), allocatable, dimension(:) :: tmp
integer :: p, n, res
character(len=MAXPATH) :: line
logical :: close_mark_found
n = 0
!initial allocation of tmp
if (.not. allocated(tmp)) call alloc(tmp, 10)
!follow the path (advancing the last line)
call follow_path(un, path)
!check whether a close mark is reached
close_mark_found = search_mark_once(un, path, CLOSE_MARK_MEMBERS, back = .true.)
!loop to catch members
do while (.not. close_mark_found)
!searchs a new member
call search_mark(un, path, OPEN_MARK_MEMBERS, back=.true.)
!stores the name
read (un, fmt='(A)', iostat=res) line
if (res /= 0) call error('flist/read ('//trim(path)//'), #'//trim(string(res)))
p = index(line, 'name=')
n = n + 1; if (n > size(tmp, 1)) call extend(tmp, 10)
tmp(n) = trim(string(cut_end_delimiter(line(p+5:),'>')))
!searchs the end of the member
call search_close_mark(un, path)
!check whether a close mark is reached
close_mark_found = search_mark_once(un, path, CLOSE_MARK_MEMBERS, back = .true.)
enddo
!advance one line in file
close_mark_found = search_mark_once(un, path, CLOSE_MARK_MEMBERS)
!final result
if (allocated(var)) call dealloc(var)
call alloc(var, n)
var(1:n) = tmp(1:n)
end subroutine
!-----------------------------------------------------------------------
! fclose: close a xml file
!-----------------------------------------------------------------------
subroutine fclose(un)
integer, intent(in) :: un
integer :: ios
close(unit=un, iostat=ios)
if (ios /= 0) call error('read_xml/close, #'//trim(string(ios)))
end subroutine
!***********************************************************************
! PRIVATE PROCEDURES
!***********************************************************************
!-----------------------------------------------------------------------
! search_mark_once: searchs a mark only once
! RETURN: .true. if the mark is found
! .false. otherwise
!-----------------------------------------------------------------------
recursive function search_mark_once(un, path, marks, name, typ, tnum, advance, back) result(res)
integer, intent(in) :: un
character(len=*), intent(in) :: path
character(len=*), intent(in), dimension(:) :: marks
character(len=*), intent(in), optional :: name, typ
integer, intent(inout), optional :: tnum
logical, intent(in), optional :: back, advance
logical :: res
integer :: ios, i, p
character(len=MAXPATH) :: line
res = .false.
!read a line
read (un, fmt='(A)', iostat=ios) line
if (ios /= 0) call error('search_mark_once/read ('//trim(path)//'), #'//trim(string(ios)))
!backspace
if (present(back)) then
if (back) then
backspace(unit=un, iostat=ios)
if (ios /= 0) call error('search_mark_once/backspace ('//trim(path)//'), #'//trim(string(ios)))
endif
endif
do i = 1, size(marks, 1)
if (index(line, trim(marks(i))) > 0) then
!check name
if (present(name)) then
p = index(line, 'name=')
if (trim(name) /= trim(string(cut_end_delimiter(line(p+5:),'>')))) then
if (present(advance)) then
if (advance) call search_close_mark(un, path)
endif
cycle
endif
endif
!check type
if (present(typ)) then
p = index(line, 'type=')
if (trim(typ) /= trim(string(cut_end_delimiter(line(p+5:),'>')))) then
if (present(advance)) then
if (advance) call search_close_mark(un, path)
endif
cycle
endif
endif
!check totalnum
if (present(tnum)) then
p = index(line, 'totalnum=')
if (tnum > 0) then
if (tnum /= int(string(cut_end_delimiter(line(p+9:),'>')))) then
if (present(advance)) then
if (advance) call search_close_mark(un, path)
endif
cycle
endif
else
tnum = int(string(cut_end_delimiter(line(p+9:),'>')))
endif
endif
!the mark, name, type and/or tnum matches
res = .true.; return
endif
enddo
end function
!-----------------------------------------------------------------------
! search_mark: searchs a mark
!-----------------------------------------------------------------------
subroutine search_mark(un, path, marks, name, typ, tnum, back, advance)
integer, intent(in) :: un
character(len=*), intent(in) :: path
character(len=*), intent(in), dimension(:) :: marks
character(len=*), intent(in), optional :: name, typ
integer, intent(inout), optional :: tnum
logical, intent(in), optional :: back, advance
integer :: ios
do
if (search_mark_once(un, path, marks, name, typ, tnum, advance, back=.false.)) then
!backspace
if (present(back)) then; if (back) then
backspace(unit=un, iostat=ios)
if (ios /= 0) call error('search_mark/backspace, ('//trim(path)//') #'//trim(string(ios)))
endif; endif
return
endif
!ends the loop if a close mark is found
if (search_mark_once(un, path, CLOSE_MARK_MEMBERS, back = .true.)) exit
enddo
!mark not found
call error('search_mark ('//trim(path)//'), not found')
end subroutine
!-----------------------------------------------------------------------
! search_close_mark: search a close mark
!-----------------------------------------------------------------------
recursive subroutine search_close_mark(un, path)
integer, intent(in) :: un
character(len=*), intent(in) :: path
integer :: n
n = 1 !number of open marks
do while (n > 0)
if (search_mark_once(un, path, OPEN_MARK_MEMBERS, back=.true.)) n = n + 1
if (search_mark_once(un, path, CLOSE_MARK_MEMBERS)) n = n - 1
enddo
end subroutine
!-----------------------------------------------------------------------
! follow_path: follow the path
!-----------------------------------------------------------------------
subroutine follow_path(un, path, back)
integer, intent(in) :: un
character(len=*), intent(in) :: path
logical, optional, intent(in) :: back
character(len=len(path)) :: lpath, parte
character(len=1) :: separador
integer :: p, res
rewind(un)
separador = path(1:1)
lpath = path(2:)
parte = lpath
do while (len_trim(parte) > 0)
p = index(lpath, separador)
if (p > 0) then
parte = lpath(:p-1); lpath = lpath(p+1:)
else
parte = lpath; lpath = ' '
endif
call search_mark(un, path, OPEN_MARK_MEMBERS, parte, advance=.true.)
parte = lpath
enddo
if (present(back)) then; if (back) then
backspace(unit=un, iostat=res)
if (res /= 0) call error('follow_path/backspace ('//trim(path)//'), #'//trim(string(res)))
endif; endif
end subroutine
!-----------------------------------------------------------------------
! last_part: extracts the last part of a path
!-----------------------------------------------------------------------
function last_part(path) result(res)
character(len=*), intent(in) :: path
character(len=len(path)) :: res
character(len=1) :: separador
integer :: p
separador = path(1:1)
p = index(path, separador, back=.true.)
res = path(p+1:)
end function
!-----------------------------------------------------------------------
! cut_end_delimiter: cuts an end delimiter
!-----------------------------------------------------------------------
function cut_end_delimiter(str, delimiter) result(res)
character(len=*), intent(in) :: str, delimiter
character(len=len(str)) :: res
integer :: p
res = str
p = index(str, delimiter)
if (p > 0) res = str(:p-1)
end function
end module