generic_sources.f90

Go to the documentation of this file.

! + + + + + + + + + + + + + + + + + + + + + + + + + + + +  
! + + + + + + + + + + + + + + + + + + + + + + + + + + + +  
module generic_sources

  USE euitm_schemas
  USE itm_types
  USE allocate_deallocate
  USE deallocate_structures
  USE euitm_xml_parser  
  USE xml_file_reader

  implicit none

  public ecrh, icrh, nbi

  private

  integer, parameter                       :: buflen=256
  REAL(R8),              ALLOCATABLE       :: rho(:), vprime(:), rhonrm(:)
  TYPE (type_param), save                  :: code_parameters
  integer                                  :: nrho
!irena for impurity
      INTEGER                              :: nnucl                 !number of nuclei species
      INTEGER                              :: nion                  !number of ion species
      INTEGER                              :: nimp,     iimp        !number of impurity species
      INTEGER,                 ALLOCATABLE :: nzimp(:)              !number of ionization states for each impurity
      INTEGER                              :: nneut,    ineut       !number of neutrals species
      INTEGER,                 ALLOCATABLE :: ncomp(:)              !number of components for each neutral
      INTEGER,                 ALLOCATABLE :: ntype(:)              !number of types for each neutral

contains

  subroutine ecrh(equilibrium, coreprof, coresource)

    TYPE (type_equilibrium), POINTER         :: equilibrium(:)
    TYPE (type_coreprof),    POINTER         :: coreprof(:)
    TYPE (type_coresource),  POINTER         :: coresource(:)
    character(len=BUFLEN), save              :: j_src_f, qe_exp_f, qe_imp_f
    character(len=BUFLEN), allocatable, save :: qi_exp_f(:), qi_imp_f(:), si_exp_f(:), si_imp_f(:)
!irena for impurity
!    character(len=BUFLEN), allocatable, save :: QZ_EXP_F(:,:), QZ_IMP_F(:,:), SZ_EXP_F(:,:), SZ_IMP_F(:,:)

    character(len=BUFLEN), allocatable, save :: ui_exp_f(:), ui_imp_f(:)
    real(R8), save                           :: j_src_f_int, qe_exp_f_int, qe_imp_f_int
    real(R8), allocatable, save              :: qi_exp_f_int(:), qi_imp_f_int(:), si_exp_f_int(:), si_imp_f_int(:)
!irena for impurity
!    real(R8), allocatable, save              :: QZ_EXP_F_INT(:), QZ_IMP_F_INT(:), SZ_EXP_F_INT(:), SZ_IMP_F_INT(:)

    real(R8), allocatable, save              :: ui_exp_f_int(:), ui_imp_f_int(:)
    integer                                  :: return_status, irho, iion
    logical, save                            :: first=.true.
    REAL(R8)                                 :: integral, integral_err

    write(*,*) 'ECRH module'

    if(associated(equilibrium(1)%profiles_1d%rho_vol)) then
       nrho = size(equilibrium(1)%profiles_1d%rho_vol)
       allocate(rhonrm(nrho))
       rhonrm = equilibrium(1)%profiles_1d%rho_vol
       write(*,*) 'RHONRM based on input equilibrium RHO_VOL'
    elseif(associated(equilibrium(1)%profiles_1d%rho_tor)) then
       nrho = size(equilibrium(1)%profiles_1d%rho_tor)
       rhonrm = equilibrium(1)%profiles_1d%rho_tor / equilibrium(1)%profiles_1d%rho_tor(nrho)
       write(*,*) 'RHONRM based on input equilibrium RHO_TOR'
    elseif(associated(equilibrium(1)%profiles_1d%psi)) then
       nrho = size(equilibrium(1)%profiles_1d%psi)
       rhonrm = equilibrium(1)%profiles_1d%psi / equilibrium(1)%profiles_1d%psi(nrho)
       write(*,*) 'RHONRM based on input equilibrium  PSI'
    else
       write(*,*) 'Could not find a suitable radial coordinate'
       stop
    endif




    if(first) then
       CALL fill_param(code_parameters, 'XML/ecrh.xml', '', 'XML/sources.xsd')
       call assign_code_parameters(code_parameters, return_status, &
            j_src_f, qe_exp_f, qe_imp_f, qi_exp_f, qi_imp_f, &
            si_exp_f, si_imp_f, ui_exp_f, ui_imp_f, &
            j_src_f_int, qe_exp_f_int, qe_imp_f_int, qi_exp_f_int, qi_imp_f_int, &
            si_exp_f_int, si_imp_f_int, ui_exp_f_int, ui_imp_f_int)
       call deallocate_cpo(code_parameters)
       first=.false.
    endif
     
    CALL get_comp_dimensions(coreprof(1)%COMPOSITIONS, nnucl, nion,  nimp,  nzimp, nneut, ntype, ncomp)
    CALL allocate_coresource_cpo(1, nrho, nnucl, nion,  nimp,  nzimp, nneut, ntype, ncomp, coresource)


    allocate(rho(nrho), vprime(nrho))
    rho    = equilibrium(1)%profiles_1d%rho_tor
    vprime = equilibrium(1)%profiles_1d%vprime

    coresource(1)%time                        = coreprof(1)%time
    coresource(1)%VALUES(1)%rho_tor                     = equilibrium(1)%profiles_1d%rho_tor
    coresource(1)%VALUES(1)%j(:)                        = profile(j_src_f, integral, integral_err)
    coresource(1)%VALUES(1)%qe%exp(:)                   = profile(qe_exp_f, integral, integral_err)
    if(qe_exp_f_int.ne.0.0_r8) then
       coresource(1)%VALUES(1)%qe%exp(:) = coresource(1)%VALUES(1)%qe%exp(:) * qe_exp_f_int / integral
       write(*,*) 'Integral Qe rescaled to ', qe_exp_f_int
    ELSE
       write(*,*) 'Integral Qe = ', integral, ' +- ', integral_err
    ENDIF
    coresource(1)%VALUES(1)%qe%imp(:)                   = profile(qe_imp_f, integral, integral_err)
    do iion = 1, nion
       coresource(1)%VALUES(1)%si%exp(:,iion)           = profile(si_exp_f(iion), integral, integral_err)
       if(si_exp_f_int(iion).ne.0.0_r8) then
          coresource(1)%VALUES(1)%si%exp(:,iion) = coresource(1)%VALUES(1)%si%exp(:,iion) * si_exp_f_int(iion) / integral
          write(*,*) 'Integral Si (',iion,') rescaled to ', si_exp_f_int(iion)
       ELSE
          write(*,*) 'Integral Si (',iion,') = ', integral, ' +- ', integral_err
       ENDIF
       coresource(1)%VALUES(1)%si%imp(:,iion)           = profile(si_imp_f(iion), integral, integral_err)
       coresource(1)%VALUES(1)%qi%exp(:,iion)           = profile(qi_exp_f(iion), integral, integral_err)
       if(qi_exp_f_int(iion).ne.0.0_r8) then
          coresource(1)%VALUES(1)%qi%exp(:,iion) = coresource(1)%VALUES(1)%qi%exp(:,iion) * qi_exp_f_int(iion) / integral
          write(*,*) 'Integral Qi (',iion,') rescaled to ', qi_exp_f_int(iion)
       ELSE
          write(*,*) 'Integral Qi (',iion,') = ', integral, ' +- ', integral_err
       ENDIF
       coresource(1)%VALUES(1)%qi%imp(:,iion)           = profile(qi_imp_f(iion), integral, integral_err)
       coresource(1)%VALUES(1)%ui%exp(:,iion)           = profile(ui_exp_f(iion), integral, integral_err)
       if(ui_exp_f_int(iion).ne.0.0_r8) then
          coresource(1)%VALUES(1)%ui%exp(:,iion) = coresource(1)%VALUES(1)%ui%exp(:,iion) * ui_exp_f_int(iion) / integral
          write(*,*) 'Integral Ui (',iion,') rescaled to ', ui_exp_f_int(iion)
       ELSE
          write(*,*) 'Integral Ui (',iion,') = ', integral, ' +- ', integral_err
       ENDIF
       coresource(1)%VALUES(1)%UI%IMP(:,iion)           = profile(ui_imp_f(iion), integral, integral_err)
    enddo
  
    deallocate(rhonrm, rho, vprime)

  end subroutine ecrh

  subroutine icrh(equilibrium, coreprof, coresource)

    TYPE (type_equilibrium), POINTER         :: equilibrium(:)
    TYPE (type_coreprof),    POINTER         :: coreprof(:)
    TYPE (type_coresource),  POINTER         :: coresource(:)
    character(len=BUFLEN), save              :: j_src_f, qe_exp_f, qe_imp_f
    character(len=BUFLEN), allocatable, save :: qi_exp_f(:), qi_imp_f(:), si_exp_f(:), si_imp_f(:)
    character(len=BUFLEN), allocatable, save :: ui_exp_f(:), ui_imp_f(:)
    real(R8), save                           :: j_src_f_int, qe_exp_f_int, qe_imp_f_int
    real(R8), allocatable, save              :: qi_exp_f_int(:), qi_imp_f_int(:), si_exp_f_int(:), si_imp_f_int(:)
    real(R8), allocatable, save              :: ui_exp_f_int(:), ui_imp_f_int(:)
    integer                                  :: return_status, irho, iion
    logical, save                            :: first=.true.
    REAL(R8)                                 :: integral, integral_err

    write(*,*) 'ICRH module'

    if(associated(equilibrium(1)%profiles_1d%rho_vol)) then
       nrho = size(equilibrium(1)%profiles_1d%rho_vol)
       allocate(rhonrm(nrho))
       rhonrm = equilibrium(1)%profiles_1d%rho_vol
       write(*,*) 'RHONRM based on input equilibrium RHO_VOL'
    elseif(associated(equilibrium(1)%profiles_1d%rho_tor)) then
       nrho = size(equilibrium(1)%profiles_1d%rho_tor)
       rhonrm = equilibrium(1)%profiles_1d%rho_tor / equilibrium(1)%profiles_1d%rho_tor(nrho)
       write(*,*) 'RHONRM based on input equilibrium RHO_TOR'
    elseif(associated(equilibrium(1)%profiles_1d%psi)) then
       nrho = size(equilibrium(1)%profiles_1d%psi)
       rhonrm = equilibrium(1)%profiles_1d%psi / equilibrium(1)%profiles_1d%psi(nrho)
       write(*,*) 'RHONRM based on input equilibrium  PSI'
    else
       write(*,*) 'Could not find a suitable radial coordinate'
       stop
    endif

    if(first) then
       CALL fill_param(code_parameters, 'XML/icrh.xml', '', 'XML/sources.xsd')
       call assign_code_parameters(code_parameters, return_status, &
            j_src_f, qe_exp_f, qe_imp_f, qi_exp_f, qi_imp_f, &
            si_exp_f, si_imp_f, ui_exp_f, ui_imp_f, &
            j_src_f_int, qe_exp_f_int, qe_imp_f_int, qi_exp_f_int, qi_imp_f_int, &
            si_exp_f_int, si_imp_f_int, ui_exp_f_int, ui_imp_f_int)
       call deallocate_cpo(code_parameters)
       first=.false.
    endif
     
    CALL get_comp_dimensions(coreprof(1)%COMPOSITIONS, nnucl, nion,  nimp,  nzimp, nneut, ntype, ncomp)
    CALL allocate_coresource_cpo(1, nrho, nnucl, nion,  nimp,  nzimp, nneut, ntype, ncomp, coresource)
    allocate(rho(nrho), vprime(nrho))
    rho    = equilibrium(1)%profiles_1d%rho_tor
    vprime = equilibrium(1)%profiles_1d%vprime

    coresource(1)%time                        = coreprof(1)%time
    coresource(1)%VALUES(1)%rho_tor                     = equilibrium(1)%profiles_1d%rho_tor
    coresource(1)%VALUES(1)%j(:)                        = profile(j_src_f, integral, integral_err)
    coresource(1)%VALUES(1)%qe%exp(:)                   = profile(qe_exp_f, integral, integral_err)
    if(qe_exp_f_int.ne.0.0_r8) then
       coresource(1)%VALUES(1)%qe%exp(:) = coresource(1)%VALUES(1)%qe%exp(:) * qe_exp_f_int / integral
       write(*,*) 'Integral Qe rescaled to ', qe_exp_f_int
    ELSE
       write(*,*) 'Integral Qe = ', integral, ' +- ', integral_err
    ENDIF
    coresource(1)%VALUES(1)%qe%imp(:)                   = profile(qe_imp_f, integral, integral_err)
    do iion = 1, nion
       coresource(1)%VALUES(1)%si%exp(:,iion)           = profile(si_exp_f(iion), integral, integral_err)
       if(si_exp_f_int(iion).ne.0.0_r8) then
          coresource(1)%VALUES(1)%si%exp(:,iion) = coresource(1)%VALUES(1)%si%exp(:,iion) * si_exp_f_int(iion) / integral
          write(*,*) 'Integral Si (',iion,') rescaled to ', si_exp_f_int(iion)
       ELSE
          write(*,*) 'Integral Si (',iion,') = ', integral, ' +- ', integral_err
       ENDIF
       coresource(1)%VALUES(1)%si%imp(:,iion)           = profile(si_imp_f(iion), integral, integral_err)
       coresource(1)%VALUES(1)%qi%exp(:,iion)           = profile(qi_exp_f(iion), integral, integral_err)
       if(qi_exp_f_int(iion).ne.0.0_r8) then
          coresource(1)%VALUES(1)%qi%exp(:,iion) = coresource(1)%VALUES(1)%qi%exp(:,iion) * qi_exp_f_int(iion) / integral
          write(*,*) 'Integral Qi (',iion,') rescaled to ', qi_exp_f_int(iion)
       ELSE
          write(*,*) 'Integral Qi (',iion,') = ', integral, ' +- ', integral_err
       ENDIF
       coresource(1)%VALUES(1)%qi%imp(:,iion)           = profile(qi_imp_f(iion), integral, integral_err)
       coresource(1)%VALUES(1)%ui%exp(:,iion)           = profile(ui_exp_f(iion), integral, integral_err)
       if(ui_exp_f_int(iion).ne.0.0_r8) then
          coresource(1)%VALUES(1)%ui%exp(:,iion) = coresource(1)%VALUES(1)%ui%exp(:,iion) * ui_exp_f_int(iion) / integral
          write(*,*) 'Integral Ui (',iion,') rescaled to ', ui_exp_f_int(iion)
       ELSE
          write(*,*) 'Integral Ui (',iion,') = ', integral, ' +- ', integral_err
       ENDIF
       coresource(1)%VALUES(1)%ui%imp(:,iion)           = profile(ui_imp_f(iion), integral, integral_err)
    enddo
  
    deallocate(rhonrm, rho, vprime)

  end subroutine icrh

  subroutine nbi(equilibrium, coreprof, coresource)

    TYPE (type_equilibrium), POINTER         :: equilibrium(:)
    TYPE (type_coreprof),    POINTER         :: coreprof(:)
    TYPE (type_coresource),  POINTER         :: coresource(:)
    character(len=BUFLEN), save              :: j_src_f, qe_exp_f, qe_imp_f
    character(len=BUFLEN), allocatable, save :: qi_exp_f(:), qi_imp_f(:), si_exp_f(:), si_imp_f(:)
    character(len=BUFLEN), allocatable, save :: ui_exp_f(:), ui_imp_f(:)
    real(R8), save                           :: j_src_f_int, qe_exp_f_int, qe_imp_f_int
    real(R8), allocatable, save              :: qi_exp_f_int(:), qi_imp_f_int(:), si_exp_f_int(:), si_imp_f_int(:)
    real(R8), allocatable, save              :: ui_exp_f_int(:), ui_imp_f_int(:)
    integer                                  :: return_status, irho, iion
    logical, save                            :: first=.true.
    REAL(R8)                                 :: integral, integral_err

    write(*,*) 'NBI module'

    if(associated(equilibrium(1)%profiles_1d%rho_vol)) then
       nrho = size(equilibrium(1)%profiles_1d%rho_vol)
       allocate(rhonrm(nrho))
       rhonrm = equilibrium(1)%profiles_1d%rho_vol
       write(*,*) 'RHONRM based on input equilibrium RHO_VOL'
    elseif(associated(equilibrium(1)%profiles_1d%rho_tor)) then
       nrho = size(equilibrium(1)%profiles_1d%rho_tor)
       rhonrm = equilibrium(1)%profiles_1d%rho_tor / equilibrium(1)%profiles_1d%rho_tor(nrho)
       write(*,*) 'RHONRM based on input equilibrium RHO_TOR'
    elseif(associated(equilibrium(1)%profiles_1d%psi)) then
       nrho = size(equilibrium(1)%profiles_1d%psi)
       rhonrm = equilibrium(1)%profiles_1d%psi / equilibrium(1)%profiles_1d%psi(nrho)
       write(*,*) 'RHONRM based on input equilibrium  PSI'
    else
       write(*,*) 'Could not find a suitable radial coordinate'
       stop
    endif

    if(first) then
       CALL fill_param(code_parameters, 'XML/nbi.xml', '', 'XML/sources.xsd')
       call assign_code_parameters(code_parameters, return_status, &
            j_src_f, qe_exp_f, qe_imp_f, qi_exp_f, qi_imp_f, &
            si_exp_f, si_imp_f, ui_exp_f, ui_imp_f, &
            j_src_f_int, qe_exp_f_int, qe_imp_f_int, qi_exp_f_int, qi_imp_f_int, &
            si_exp_f_int, si_imp_f_int, ui_exp_f_int, ui_imp_f_int)
       call deallocate_cpo(code_parameters)
       first=.false.
    endif
     
    CALL get_comp_dimensions(coreprof(1)%COMPOSITIONS, nnucl, nion,  nimp,  nzimp, nneut, ntype, ncomp)
    CALL allocate_coresource_cpo(1, nrho, nnucl, nion,  nimp,  nzimp, nneut, ntype, ncomp, coresource)

    allocate(rho(nrho), vprime(nrho))
    rho    = equilibrium(1)%profiles_1d%rho_tor
    vprime = equilibrium(1)%profiles_1d%vprime

    coresource(1)%time                        = coreprof(1)%time
    coresource(1)%VALUES(1)%rho_tor                     = equilibrium(1)%profiles_1d%rho_tor
    coresource(1)%VALUES(1)%j(:)                        = profile(j_src_f, integral, integral_err)
    coresource(1)%VALUES(1)%qe%exp(:)                   = profile(qe_exp_f, integral, integral_err)
    if(qe_exp_f_int.ne.0.0_r8) then
       coresource(1)%VALUES(1)%qe%exp(:) = coresource(1)%VALUES(1)%qe%exp(:) * qe_exp_f_int / integral
       write(*,*) 'Integral Qe rescaled to ', qe_exp_f_int
    ELSE
       write(*,*) 'Integral Qe = ', integral, ' +- ', integral_err
    ENDIF
    coresource(1)%VALUES(1)%qe%imp(:)                   = profile(qe_imp_f, integral, integral_err)
    do iion = 1, nion
       coresource(1)%VALUES(1)%si%exp(:,iion)           = profile(si_exp_f(iion), integral, integral_err)
       if(si_exp_f_int(iion).ne.0.0_r8) then
          coresource(1)%VALUES(1)%si%exp(:,iion) = coresource(1)%VALUES(1)%si%exp(:,iion) * si_exp_f_int(iion) / integral
          write(*,*) 'Integral Si (',iion,') rescaled to ', si_exp_f_int(iion)
       ELSE
          write(*,*) 'Integral Si (',iion,') = ', integral, ' +- ', integral_err
       ENDIF
       coresource(1)%VALUES(1)%si%imp(:,iion)           = profile(si_imp_f(iion), integral, integral_err)
       coresource(1)%VALUES(1)%qi%exp(:,iion)           = profile(qi_exp_f(iion), integral, integral_err)
       if(qi_exp_f_int(iion).ne.0.0_r8) then
          coresource(1)%VALUES(1)%qi%exp(:,iion) = coresource(1)%VALUES(1)%qi%exp(:,iion) * qi_exp_f_int(iion) / integral
          write(*,*) 'Integral Qi (',iion,') rescaled to ', qi_exp_f_int(iion)
       ELSE
          write(*,*) 'Integral Qi (',iion,') = ', integral, ' +- ', integral_err
       ENDIF
       coresource(1)%VALUES(1)%qi%imp(:,iion)           = profile(qi_imp_f(iion), integral, integral_err)
       coresource(1)%VALUES(1)%ui%exp(:,iion)           = profile(ui_exp_f(iion), integral, integral_err)
       if(ui_exp_f_int(iion).ne.0.0_r8) then
          coresource(1)%VALUES(1)%ui%exp(:,iion) = coresource(1)%VALUES(1)%ui%exp(:,iion) * ui_exp_f_int(iion) / integral
          write(*,*) 'Integral Ui (',iion,') rescaled to ', ui_exp_f_int(iion)
       ELSE
          write(*,*) 'Integral Ui (',iion,') = ', integral, ' +- ', integral_err
       ENDIF
       coresource(1)%VALUES(1)%ui%imp(:,iion)           = profile(ui_imp_f(iion), integral, integral_err)
    enddo
  
    deallocate(rhonrm, rho, vprime)

  end subroutine nbi

  function profile(function_string, integral, integral_err)

  use fortranparser, only : equationparser

    real(R8)               :: profile(1:nrho), integral, integral_err
    character (len=BUFLEN) :: function_string

    type(equationparser)            :: function_descriptor
    character(len=10)               :: variables(1) = ['x']

    integer                :: i

    function_descriptor = equationparser(trim(function_string), variables)
!    if(.not.c_associated(function_descriptor)) then
!       write(*,*) 'Invalid function ', trim(function_string)
!       stop
!    endif

    do i = 1, nrho
       profile(i) = function_descriptor%evaluate([rhonrm(i)])
    enddo

!    call evaluator_destroy(function_descriptor)

    call cubint(nrho, rho, vprime*profile, 1, nrho, integral, integral_err)

  end function profile

  subroutine assign_code_parameters(codeparameters, return_status, &
       j_src_f, qe_exp_f, qe_imp_f, qi_exp_f, qi_imp_f, &
       si_exp_f, si_imp_f, ui_exp_f, ui_imp_f, &
       j_src_f_int, qe_exp_f_int, qe_imp_f_int, qi_exp_f_int, qi_imp_f_int, &
       si_exp_f_int, si_imp_f_int, ui_exp_f_int, ui_imp_f_int)

    use mod_f90_kind

    implicit none

    character(len=BUFLEN)              :: j_src_f, qe_exp_f, qe_imp_f
    character(len=BUFLEN), allocatable :: qi_exp_f(:), qi_imp_f(:), si_exp_f(:), si_imp_f(:)
    character(len=BUFLEN), allocatable :: ui_exp_f(:), ui_imp_f(:)
    real(R8)                           :: j_src_f_int, qe_exp_f_int, qe_imp_f_int
    real(R8), allocatable              :: qi_exp_f_int(:), qi_imp_f_int(:), si_exp_f_int(:), si_imp_f_int(:)
    real(R8), allocatable              :: ui_exp_f_int(:), ui_imp_f_int(:)

    type (type_param), intent(in) :: codeparameters
    integer(ikind), intent(out) :: return_status 

    type(tree) :: parameter_list
    type(element), pointer :: temp_pointer
    integer(ikind) :: i, nparm, n_values
    character(len = 132) :: cname
    character (len=256), allocatable :: tmp_string(:)
    integer :: lng

    j_src_f='0.0'
    qe_exp_f='0.0'
    qe_imp_f='0.0'
    allocate(qi_exp_f(nion)) ; lng=nion ; qi_exp_f='0.0'
    allocate(qi_imp_f(nion)) ; lng=nion ; qi_imp_f='0.0'
    allocate(si_exp_f(nion)) ; lng=nion ; si_exp_f='0.0'
    allocate(si_imp_f(nion)) ; lng=nion ; si_imp_f='0.0'
    allocate(ui_exp_f(nion)) ; lng=nion ; ui_exp_f='0.0'
    allocate(ui_imp_f(nion)) ; lng=nion ; ui_imp_f='0.0'
    j_src_f_int=0.0_r8
    qe_exp_f_int=0.0_r8
    qe_imp_f_int=0.0_r8
    allocate(qi_exp_f_int(nion)) ; lng=nion ; qi_exp_f_int=0.0_r8
    allocate(qi_imp_f_int(nion)) ; lng=nion ; qi_imp_f_int=0.0_r8
    allocate(si_exp_f_int(nion)) ; lng=nion ; si_exp_f_int=0.0_r8
    allocate(si_imp_f_int(nion)) ; lng=nion ; si_imp_f_int=0.0_r8
    allocate(ui_exp_f_int(nion)) ; lng=nion ; ui_exp_f_int=0.0_r8
    allocate(ui_imp_f_int(nion)) ; lng=nion ; ui_imp_f_int=0.0_r8

    return_status = 0      ! no error

      !-- parse xml-string codeparameters%parameters

    write(*,*) 'Calling euitm_xml_parse'
    call euitm_xml_parse(code_parameters, nparm, parameter_list)
    write(*,*) 'Called euitm_xml_parse'

      !-- assign variables

    temp_pointer => parameter_list%first

    outer: do
       cname = char2str(temp_pointer%cname)   ! necessary for AIX
       select case (cname)
       case ('parameters')
          temp_pointer => temp_pointer%child
          cycle

!--   coresource parameters
         case ('coresource')
            temp_pointer => temp_pointer%child
            cycle
         case ('j')
            if (allocated(temp_pointer%cvalue)) &
                 j_src_f = char2str(temp_pointer%cvalue)
         case ('qe_exp')
            if (allocated(temp_pointer%cvalue)) &
                 qe_exp_f = char2str(temp_pointer%cvalue)
         case ('qe_imp')
            if (allocated(temp_pointer%cvalue)) &
                 qe_imp_f = char2str(temp_pointer%cvalue)
         case ('qi_exp')
            if (allocated(temp_pointer%cvalue)) &
                 call scan_str2str(char2str(temp_pointer%cvalue), 256, qi_exp_f, lng)
         case ('qi_imp')
            if (allocated(temp_pointer%cvalue)) &
                 call scan_str2str(char2str(temp_pointer%cvalue), 256, qi_imp_f, lng)
         case ('si_exp')
            if (allocated(temp_pointer%cvalue)) &
                 call scan_str2str(char2str(temp_pointer%cvalue), 256, si_exp_f, lng)
         case ('si_imp')
            if (allocated(temp_pointer%cvalue)) &
                 call scan_str2str(char2str(temp_pointer%cvalue), 256, si_imp_f, lng)
         case ('ui_exp')
            if (allocated(temp_pointer%cvalue)) &
                 call scan_str2str(char2str(temp_pointer%cvalue), 256, ui_exp_f, lng)
         case ('ui_imp')
            if (allocated(temp_pointer%cvalue)) &
                 call scan_str2str(char2str(temp_pointer%cvalue), 256, ui_imp_f, lng)
         case ('j_int')
            if (allocated(temp_pointer%cvalue)) &
                 call char2num(temp_pointer%cvalue, j_src_f_int)
         case ('qe_exp_int')
            if (allocated(temp_pointer%cvalue)) &
                 call char2num(temp_pointer%cvalue, qe_exp_f_int)
         case ('qe_imp_int')
            if (allocated(temp_pointer%cvalue)) &
                 call char2num(temp_pointer%cvalue, qe_imp_f_int)
         case ('qi_exp_int')
            if (allocated(temp_pointer%cvalue)) &
                 call scan_str2real(char2str(temp_pointer%cvalue), qi_exp_f_int, lng)
         case ('qi_imp_int')
            if (allocated(temp_pointer%cvalue)) &
                 call scan_str2real(char2str(temp_pointer%cvalue), qi_imp_f_int, lng)
         case ('si_exp_int')
            if (allocated(temp_pointer%cvalue)) &
                 call scan_str2real(char2str(temp_pointer%cvalue), si_exp_f_int, lng)
         case ('si_imp_int')
            if (allocated(temp_pointer%cvalue)) &
                 call scan_str2real(char2str(temp_pointer%cvalue), si_imp_f_int, lng)
         case ('ui_exp_int')
            if (allocated(temp_pointer%cvalue)) &
                 call scan_str2real(char2str(temp_pointer%cvalue), ui_exp_f_int, lng)
         case ('ui_imp_int')
            if (allocated(temp_pointer%cvalue)) &
                 call scan_str2real(char2str(temp_pointer%cvalue), ui_imp_f_int, lng)

!--  default
       case default
          write(*, *) 'ERROR: invalid parameter', cname
          return_status = 1
          exit
         end select
         do
            if (associated(temp_pointer%sibling)) then
               temp_pointer => temp_pointer%sibling
               exit
            end if
            if (associated(temp_pointer%parent, parameter_list%first )) &
                 exit outer
            if (associated(temp_pointer%parent)) then
               temp_pointer => temp_pointer%parent
            else
               write(*, *) 'ERROR: broken list.'
               return
            end if
         end do
      end do outer
      
      !-- destroy tree
      call destroy_xml_tree(parameter_list)
      
      return

    end subroutine assign_code_parameters

end module generic_sources