Pass an xml filename argument to readxml without changing code files

Question

I have these lines of code in Intel Fortran-90 and an XML file:

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

And 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

and XML file 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>

I want to know how can I pass an xml filename argument to readxml without changing code files? As an description I want to know the mechanism of Fortran.

Any help will be appreciated. Regards.

Answer 1

I found how Passing an xml filename argument to readxml without changing code files. Below is about fopen and flist and so on function in 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