!======================================================================!
!                                                                      !
!    Software Name : FrontCOMP_cure   Ver. 3.1                         !
!                                                                      !
!      Module Name : m_fstr_setup                                      !
!      Category    : I/O and Utility                                   !
!                                                                      !
!      Developed based on "FrontSTR" of RSS21 project                  !
!                                                                      !
!                     Written by Noboru Imai,        2006/06/01        !
!                                Tomotaka Ogasawara, 2013/03/26        !
!                                                                      !
!     Contact address :  IIS,The University of Tokyo, CISS             !
!                                                                      !
!    "Composite Material Strength & Reliability Evaluation Simulator"  !
!                                                                      !
!======================================================================!

module m_fstr_setup
use m_fstr
use fstr_setup_util
use fstr_ctrl
include 'fstr_ctrl_util_f.inc'

        type fstr_param_pack
                type(hecmwST_local_mesh), pointer :: MESH
                type(hecmwST_matrix), pointer     :: MAT
                type(fstr_param), pointer         :: PARAM
                type(fstr_solid), pointer         :: SOLID
                type(fstr_heat), pointer          :: HEAT
                ! type(fstr_eigen), pointer       :: EIGEN
                type(lczparam), pointer           :: EIGEN
                type(fstr_dynamic), pointer       :: DYN
                type(fstr_couple), pointer        :: CPL
!                type(fstr_mpc_rigid), pointer     :: MPC_RD
        end type fstr_param_pack

contains

!=============================================================================!
! FSTR_SETUP                                                                  !
!=============================================================================!
! JP-0
! JP-1
! JP-2
! JP-3
! JP-4
! JP-5

subroutine fstr_setup( cntl_filename, hecMESH, hecMAT, &
        fstrPARAM, fstrSOLID, fstrEIG, fstrHEAT, fstrDYNAMIC, fstrCPL) !, fstrMPCRIGID )
        implicit none
        character(len=HECMW_FILENAME_LEN) :: cntl_filename
        type(hecmwST_local_mesh),target :: hecMESH
        type(hecmwST_matrix),target :: hecMAT
        type(fstr_param),target :: fstrPARAM
        type(fstr_solid),target :: fstrSOLID
        type(lczparam),target :: fstrEIG
        ! type(fstr_eigen),target :: fstrEIG
        type(fstr_heat),target :: fstrHEAT
        type(fstr_dynamic),target :: fstrDYNAMIC
        type(fstr_couple),target :: fstrCPL
!        type(fstr_mpc_rigid),target :: fstrMPCRIGID
        integer(kind=kint) :: ctrl
        type(fstr_param_pack) :: P

        external fstr_ctrl_get_c_h_name
        integer(kind=kint) :: fstr_ctrl_get_c_h_name

        integer(kind=kint) :: rcode
        character(len=HECMW_NAME_LEN) :: header_name

        ! counters
        integer(kind=kint) :: c_solution, c_solver, c_step, c_write, c_echo
        integer(kind=kint) :: c_static, c_boundary, c_cload, c_dload, c_temperature, c_reftemp
        integer(kind=kint) :: c_heat, c_fixtemp, c_cflux, c_dflux, c_sflux, c_film, c_sfilm, c_radiate, c_sradiate
        integer(kind=kint) :: c_eigen
        integer(kind=kint) :: c_dynamic, c_velocity, c_acceleration
        integer(kind=kint) :: c_couple
        integer(kind=kint) :: c_mpc
        integer(kind=kint) :: c_visco, c_ortho_solid, c_resin_solid 
        integer(kind=kint) :: c_heat_plus, c_ortho_heat, c_resin_heat 

        ! packaging!!
        P%MESH   => hecMESH
        P%MAT    => hecMAT
        P%PARAM  => fstrPARAM
        P%SOLID  => fstrSOLID
        P%EIGEN  => fstrEIG
        P%HEAT   => fstrHEAT
        P%DYN    => fstrDYNAMIC
        P%CPL    => fstrCPL
!        P%MPC_RD => fstrMPCRIGID

        c_solution = 0; c_solver   = 0; c_step   = 0; c_write = 0; c_echo = 0;
        c_static   = 0; c_boundary = 0; c_cload  = 0; c_dload = 0; c_temperature = 0; c_reftemp = 0
        c_heat     = 0; c_fixtemp  = 0; c_cflux  = 0; c_dflux = 0; c_sflux = 0
        c_film     = 0; c_sfilm    = 0; c_radiate= 0; c_sradiate = 0
        c_eigen    = 0
        c_dynamic  = 0; c_velocity = 0; c_acceleration = 0
        c_couple   = 0
        c_mpc      = 0
        c_visco     = 0; c_ortho_solid = 0; c_resin_solid = 0
        c_heat_plus = 0; c_ortho_heat  = 0; c_resin_heat  = 0

        call fstr_setup_init( P )

        ctrl = fstr_ctrl_open( cntl_filename)
        if( ctrl < 0 ) then
                write(*,*) '### Error: Cannot open FSTR control file : ', cntl_filename
                write(ILOG,*) '### Error: Cannot open FSTR control file : ', cntl_filename
                STOP
        end if

        do
                rcode = fstr_ctrl_get_c_h_name( ctrl, header_name, HECMW_NAME_LEN )
                if(     header_name == '!SOLUTION' ) then
                        c_solution = c_solution + 1
                        call fstr_setup_SOLUTION( ctrl, c_solution, P )
                else if( header_name == '!SOLVER' ) then
                        c_solver = c_solver + 1
                        call fstr_setup_SOLVER( ctrl, c_solver, P )
                else if( header_name == '!STEP' ) then
                        c_step = c_step + 1
                        call fstr_setup_STEP( ctrl, c_step, P )
                else if( header_name == '!WRITE' ) then
                        c_write = c_write + 1
                        call fstr_setup_WRITE( ctrl, c_write, P )
                else if( header_name == '!ECHO' ) then
                        c_echo = c_echo + 1
                        call fstr_setup_ECHO( ctrl, c_echo, P )

                !--------------- for static -------------------------

                else if( header_name == '!STATIC' ) then
                        c_static = c_static + 1
                        call fstr_setup_STATIC( ctrl, c_static, P )
                else if( header_name == '!BOUNDARY' ) then
                        c_boundary = c_boundary + 1
                        call fstr_setup_BOUNDARY( ctrl, c_boundary, P )
                else if( header_name == '!CLOAD' ) then
                        c_cload = c_cload + 1
                        call fstr_setup_CLOAD( ctrl, c_cload, P )
                else if( header_name == '!DLOAD' ) then
                        c_dload = c_dload + 1
                        call fstr_setup_DLOAD( ctrl, c_dload, P )
                else if( header_name == '!TEMPERATURE' ) then
                        c_temperature = c_temperature + 1
                        call fstr_setup_TEMPERATURE( ctrl, c_temperature, P )
                else if( header_name == '!REFTEMP' ) then
                        c_reftemp = c_reftemp + 1
                        call fstr_setup_REFTEMP( ctrl, c_reftemp, P )
                else if( header_name == '!VISCO' ) then
                        c_visco = c_visco + 1
                        call fstr_setup_VISCO( ctrl, c_visco, P )
                else if( header_name == '!ORTHO_SOLID' ) then
                        c_ortho_solid = c_ortho_solid + 1
                        call fstr_setup_ORTHO_SOLID( ctrl, c_ortho_solid, P )
                else if( header_name == '!RESIN_SOLID' ) then
                        c_resin_solid = c_resin_solid + 1
                        call fstr_setup_RESIN_SOLID( ctrl, c_resin_solid, P )

                !--------------- for heat -------------------------

                else if( header_name == '!HEAT' ) then
                        c_heat = c_heat + 1
                        call fstr_setup_HEAT( ctrl, c_heat, P )
                else if( header_name == '!FIXTEMP' ) then
                        c_fixtemp = c_fixtemp + 1
                        call fstr_setup_FIXTEMP( ctrl, c_fixtemp, P )
                else if( header_name == '!CFLUX' ) then
                        c_cflux = c_cflux + 1
                        call fstr_setup_CFLUX( ctrl, c_cflux, P )
                else if( header_name == '!DFLUX' ) then
                        c_dflux = c_dflux + 1
                        call fstr_setup_DFLUX( ctrl, c_dflux, P )
                else if( header_name == '!SFLUX' ) then
                        c_sflux = c_sflux + 1
                        call fstr_setup_SFLUX( ctrl, c_sflux, P )
                else if( header_name == '!FILM' ) then
                        c_film = c_film + 1
                        call fstr_setup_FILM( ctrl, c_film, P )
                else if( header_name == '!SFILM' ) then
                        c_sfilm = c_sfilm + 1
                        call fstr_setup_SFILM( ctrl, c_sfilm, P )
                else if( header_name == '!RADIATE' ) then
                        c_radiate = c_radiate + 1
                        call fstr_setup_RADIATE( ctrl, c_radiate, P )
                else if( header_name == '!SRADIATE' ) then
                        c_sradiate = c_sradiate + 1
                        call fstr_setup_SRADIATE( ctrl, c_sradiate, P )
                else if( header_name == '!HEAT_PLUS' ) then
                        c_heat_plus = c_heat_plus + 1
                        call fstr_setup_HEAT_PLUS( ctrl, c_heat_plus, P )
                else if( header_name == '!ORTHO_HEAT' ) then
                        c_ortho_heat = c_ortho_heat + 1
                        call fstr_setup_ORTHO_HEAT( ctrl, c_ortho_heat, P )
                else if( header_name == '!RESIN_HEAT' ) then
                        c_resin_heat = c_resin_heat + 1
                        call fstr_setup_RESIN_HEAT( ctrl, c_resin_heat, P )

                !--------------- for eigen -------------------------

                else if( header_name == '!EIGEN' ) then
                        c_eigen = c_eigen + 1
                        call fstr_setup_EIGEN( ctrl, c_eigen, P )

                !--------------- for dynamic -------------------------

                else if( header_name == '!DYNAMIC' ) then
                        c_dynamic = c_dynamic + 1
                        call fstr_setup_DYNAMIC( ctrl, c_dynamic, P )
                else if( header_name == '!VELOCITY' ) then
                        c_velocity = c_velocity + 1
                        call fstr_setup_VELOCITY( ctrl, c_velocity, P )
                else if( header_name == '!ACCELERATION' ) then
                        c_acceleration = c_acceleration + 1
                        call fstr_setup_ACCELERATION( ctrl, c_acceleration, P )

                !--------------- for couple -------------------------

                else if( header_name == '!COUPLE' ) then
                        c_couple = c_couple + 1
                        call fstr_setup_COUPLE( ctrl, c_couple, P )
                !--------------- for mpc -------------------------

                else if( header_name == '!MPC' ) then
                        c_mpc = c_mpc + 1
                        call fstr_setup_MPC( ctrl, c_mpc, P )

                !--------------------- END -------------------------

                else if( header_name == '!END' ) then
                        exit
                end if

                ! next
                if( fstr_ctrl_seek_next_header(ctrl) == 0) exit
        end do

        call fstr_setup_post( ctrl, P )
        rcode = fstr_ctrl_close( ctrl )
end subroutine fstr_setup

!-----------------------------------------------------------------------------!
! init

subroutine fstr_setup_init( P )
        implicit none
        type(fstr_param_pack), target :: P

        ! ----  default setting of global params ---

        DT = 1
        ETIME = 1
        ITMAX = 20
        EPS = 1.0e-6

        ! -------  grobal pointer setting ----------

        IPROC    => P%PARAM%iproc
        INCMAX   => P%PARAM%incmax
        REF_TEMP => P%PARAM%ref_temp
        IECHO    => P%PARAM%fg_echo
        IRESULT  => P%PARAM%fg_result
        IVISUAL  => P%PARAM%fg_visual

        ! for heat ...
        INEUTRAL => P%PARAM%fg_neutral
        IRRES    => P%PARAM%fg_irres
        IWRES    => P%PARAM%fg_iwres
        NRRES    => P%PARAM%nrres
        NPRINT   => P%PARAM%nprint

        ! ------- initial value setting -------------

        call fstr_mat_init  ( P%MAT   )
        call fstr_param_init( P%PARAM, P%MESH )
        call fstr_solid_init( P%SOLID )
        call fstr_eigen_init( P%EIGEN )
        call fstr_heat_init ( P%HEAT  )
        call fstr_dynamic_init ( P%DYN  )
!        call fstr_mpc_rigid_init( P%MPC_RD )

end subroutine fstr_setup_init

subroutine fstr_mat_init( hecMAT )
        implicit none
        type(hecmwST_matrix) :: hecMAT

        hecMAT%Iarray(1) =  100    ! = nier
        hecMAT%Iarray(2) =    1    ! = method
        hecMAT%Iarray(3) =    1    ! = precond
        hecMAT%Iarray(4) =    0    ! = nset
        hecMAT%Iarray(5) =    0    ! = iterpremax
        hecMAT%Iarray(6) =   10    ! = nrest
        hecMAT%Iarray(21)=  kNO    ! = iterlog
        hecMAT%Iarray(22)=  kNO    ! = timelog

        hecMAT%Rarray(1) =  1.0e-8 ! = resid
        hecMAT%Rarray(2) =  1.0    ! = sigma_diag
        hecMAT%Rarray(3) =  0.0    ! = sigma
        hecMAT%Rarray(4) =  0.1    ! = thresh
        hecMAT%Rarray(5) =  0.1    ! = filter
        hecMAT%Rarray(11)=  1.0e+4 ! = penalty

        hecMAT%Iarray(99) = kYES   ! indirect method

end subroutine fstr_mat_init


subroutine fstr_param_init( fstrPARAM, hecMESH )
        implicit none
        type(fstr_param) :: fstrPARAM
        type(hecmwST_local_mesh) :: hecMESH
        integer(kind=kint) :: i
        external fstr_sort_index

        fstrPARAM%solution_type = kstSTATIC
        fstrPARAM%solver_method = ksmCG

        !!STEP
        fstrPARAM%incmax = 100
        fstrPARAM%iproc  = kipSTANDARD

        !!STATIC !HEAT
        fstrPARAM%analysis_n = 0
        fstrPARAM%ref_temp   = 0

        ! output control
        fstrPARAM%fg_echo       = kOFF
        fstrPARAM%fg_result     = kOFF
        fstrPARAM%fg_visual     = kOFF

        ! for heat ...
        fstrPARAM%fg_neutral    = kOFF
        fstrPARAM%fg_irres      = kNO
        fstrPARAM%fg_iwres      = kNO
        fstrPARAM%nrres         = 1
        fstrPARAM%nprint        = 1

        ! for couple
        fstrPARAM%fg_couple      = 0
        fstrPARAM%fg_couple_first= 0

        ! index table for global node ID sorting

        fstrPARAM%n_node = hecMESH%n_node;
        fstrPARAM%nn_internal = hecMESH%nn_internal;
        allocate( fstrPARAM%global_local_ID(2,hecMESH%nn_internal))
        do i = 1, hecMESH%nn_internal
                fstrPARAM%global_local_ID(1,i) = hecMESH%global_node_ID(i)
                fstrPARAM%global_local_ID(2,i) = i
        end do
        call fstr_sort_index( fstrPARAM%global_local_ID, hecMESH%nn_internal )

end subroutine fstr_param_init


subroutine fstr_solid_init( fstrSOLID )
        implicit none
        type(fstr_solid) :: fstrSOLID
        integer(kind=kint) :: i,j

        fstrSOLID%file_type = kbcfFSTR
        fstrSOLID%BOUNDARY_ngrp_tot = 0
        fstrSOLID%CLOAD_ngrp_tot    = 0
        fstrSOLID%DLOAD_ngrp_tot    = 0
        fstrSOLID%TEMP_ngrp_tot     = 0
        fstrSOLID%VELOCITY_ngrp_tot = 0
        fstrSOLID%ACCELERATION_ngrp_tot = 0
        fstrSOLID%COUPLE_ngrp_tot   = 0

        fstrSOLID%idx_elpl    = 0
        fstrSOLID%sig_y0      = 1.0
        fstrSOLID%h_dash      = 1.0
        fstrSOLID%restart_nout= 0
        fstrSOLID%nout        = 10000
        fstrSOLID%nout_monit  = 10000
        fstrSOLID%node_monit_1= 1
        fstrSOLID%elem_monit_1= 1
        fstrSOLID%intg_monit_1= 1
        fstrSOLID%iout_list   = 0
!--- frp
       fstrSOLID%idx_temp   =   0
       fstrSOLID%idx_visco  =   0
       fstrSOLID%sub_intvl  =   1
       fstrSOLID%idx_stres  =   1
       fstrSOLID%idx_stran  =   0
       fstrSOLID%idx_young  =   0
       fstrSOLID%idx_cte    =   0
       fstrSOLID%idx_out_cood_st = 0
!--- resin
       fstrSOLID%ccc_rl     =   0.0

       fstrSOLID%ccc_rl ( 1)=   1.0
       fstrSOLID%ccc_rl ( 2)=   0.0 
       fstrSOLID%ccc_rl ( 3)=   1.0 
       fstrSOLID%ccc_rl ( 4)=   0.0 
       fstrSOLID%ccc_rl ( 5)=   0.0 
       fstrSOLID%ccc_rl ( 6)=   0.0 
       fstrSOLID%ccc_rl ( 7)=   0.0 
       fstrSOLID%ccc_rl ( 8)=   0.0 
       fstrSOLID%ramd_chm   =   0.0
       fstrSOLID%ccc_rl ( 9)=   1.0
       fstrSOLID%ccc_rl (10)=   1.0 
!--- material coord.
       fstrSOLID%mat_otho       =   1.0  
       fstrSOLID%mat_beta       =   0.0 
       fstrSOLID%mat_iso_num    =   0

       fstrSOLID%GBARU_matrl        =  0.0
       do i = 1,10
        do j = 1,3
         fstrSOLID%GBARU_matrl(j,j,i) =  1.0
        end do
       end do

end subroutine fstr_solid_init

subroutine fstr_heat_init( fstrHEAT )
        implicit none
        type(fstr_heat) :: fstrHEAT
        integer(kind=kint) :: i,j

        fstrHEAT%STEPtot     = 0
        fstrHEAT%MATERIALtot = 0
        fstrHEAT%AMPLITUDEtot= 0
        fstrHEAT%T_FIX_tot   = 0
        fstrHEAT%Q_NOD_tot   = 0
        fstrHEAT%Q_VOL_tot   = 0
        fstrHEAT%Q_SUF_tot   = 0
        fstrHEAT%R_SUF_tot   = 0
        fstrHEAT%H_SUF_tot   = 0
!--- frp
      fstrHEAT%idx_cure     =    0
      fstrHEAT%restart_nout =    0
      fstrHEAT%nout         =  10000
      fstrHEAT%nout_monit   =  10000
      fstrHEAT%nout_sta     =  10000
      fstrHEAT%node_monit_1 =    1 
      fstrHEAT%elem_monit_1 =    1 
      fstrHEAT%intg_monit_1 =    1
      fstrHEAT%iout_list    =    0
!--- resin
      fstrHEAT%idx_dadt     =    0
      fstrHEAT%ccc_rl       =    1.0
!--- material coord.
      fstrHEAT%mat_k        =  1.0
      fstrHEAT%mat_iso_num  =  0

       fstrHEAT%GBARU_matrl        =  0.0
       do i = 1,10
        do j = 1,3
         fstrHEAT%GBARU_matrl(j,j,i) =  1.0
        end do
       end do

end subroutine fstr_heat_init

subroutine fstr_eigen_init( fstrEIG )
        implicit none
        type(lczparam) :: fstrEIG
        ! type(fstr_eigen) :: fstrEIG

        fstrEIG%eqset       = 0
        fstrEIG%nget        = 5
        fstrEIG%lczsgm      = 0.0
        fstrEIG%lczmax      = 60
        fstrEIG%lcztol      = 1.0e-8
        fstrEIG%lczrod      = 1.0
        fstrEIG%lczrot      = 0.0
        fstrEIG%iluetol     = 0
end subroutine fstr_eigen_init

subroutine fstr_dynamic_init( fstrDYNAMIC )
        implicit none
        type(fstr_dynamic) :: fstrDYNAMIC

        fstrDYNAMIC%idx_eqa  = 1
        fstrDYNAMIC%idx_resp = 1
        fstrDYNAMIC%n_step   = 1
        fstrDYNAMIC%t_start  = 0.0
        fstrDYNAMIC%t_end    = 1.0
        fstrDYNAMIC%t_delta  = 1.0
        fstrDYNAMIC%ganma    = 0.5
        fstrDYNAMIC%beta     = 0.25
        fstrDYNAMIC%idx_mas  = 1
        fstrDYNAMIC%idx_dmp  = 1
        fstrDYNAMIC%ray_m    = 0.0
        fstrDYNAMIC%ray_k    = 0.0
        fstrDYNAMIC%restart_nout = 0
        fstrDYNAMIC%nout         = 10000
        fstrDYNAMIC%node_monit_1 = 1
        fstrDYNAMIC%nout_monit   = 10000
        fstrDYNAMIC%iout_list(1) = 0
        fstrDYNAMIC%iout_list(2) = 0
        fstrDYNAMIC%iout_list(3) = 0
        fstrDYNAMIC%iout_list(4) = 0
        fstrDYNAMIC%iout_list(5) = 0
        fstrDYNAMIC%iout_list(6) = 0

end subroutine fstr_dynamic_init

!subroutine fstr_mpc_rigid_init( fstrMPCRIGID )
!        implicit none
!        type( fstr_mpc_rigid ) :: fstrMPCRIGID
!
!        fstrMPCRIGID%nmpc = 0
!
!end subroutine fstr_mpc_rigid_init

!-----------------------------------------------------------------------------!
! post

subroutine fstr_setup_post( ctrl, P )
        implicit none
        integer(kind=kint) :: ctrl
        type(fstr_param_pack) :: P

                                           ! JP-6
        if( P%PARAM%solution_type == kstSTATIC &
         .or. P%PARAM%solution_type == kstEIGEN  &
         .or. P%PARAM%solution_type == kstDYNAMIC ) then
                ! Memory Allocation for Result Vectors ------------
                if( P%MESH%n_dof == 6 ) then
                        allocate ( P%SOLID%DISP    (6*P%MESH%n_node))
                        allocate ( P%SOLID%STRAIN  (10*P%MESH%n_node))
                        allocate ( P%SOLID%STRESS  (12*P%MESH%n_node))
                        allocate ( P%SOLID%ESTRAIN  (10*P%MESH%n_elem))
                        allocate ( P%SOLID%ESTRESS  (12*P%MESH%n_elem))
                else
                        allocate ( P%SOLID%DISP    (3*P%MESH%n_node))
                        allocate ( P%SOLID%STRAIN  (6*P%MESH%n_node))
                        allocate ( P%SOLID%STRESS  (7*P%MESH%n_node))
                        allocate ( P%SOLID%ESTRAIN  (6*P%MESH%n_elem))
                        allocate ( P%SOLID%ESTRESS  (7*P%MESH%n_elem))
                end if
                P%SOLID%DISP = 0.d0
                P%SOLID%STRAIN = 0.d0
                P%SOLID%STRESS = 0.d0
                P%SOLID%ESTRAIN = 0.d0
                P%SOLID%ESTRESS = 0.d0
        end if

        P%EIGEN%iluetol = P%MAT%Rarray(1) ! solver tolerance
        if( P%PARAM%solution_type == kstEIGEN ) then
            P%EIGEN%eqset = 1
        else
            P%EIGEN%eqset = 0
        endif

        if( P%PARAM%fg_visual == kON .and. P%MESH%my_rank == 0) then
                call fstr_setup_visualize( ctrl )
        end if

        call hecmw_barrier( P%MESH ) ! JP-7

        if( P%HEAT%STEPtot == 0 ) then ! No !HEAT Input
                if( P%PARAM%analysis_n == 0 ) then  ! No !STATIC Input
                        call reallocate_real( P%PARAM%dtime, 1)
                        call reallocate_real( P%PARAM%etime, 1)
                        call reallocate_real( P%PARAM%dtmin, 1)
                        call reallocate_real( P%PARAM%delmax,1)
                        call reallocate_integer( P%PARAM%itmax, 1)
                        call reallocate_real( P%PARAM%eps,   1)
                        P%PARAM%analysis_n = 1
                        P%PARAM%dtime = 0
                        P%PARAM%etime = 0
                        P%PARAM%dtmin = 0
                        P%PARAM%delmax = 0
                        P%PARAM%itmax = 20
                        P%PARAM%eps = 1.0e-6
                end if
                P%HEAT%STEPtot = 1
                call reallocate_real( P%HEAT%STEP_DLTIME, 1)
                call reallocate_real( P%HEAT%STEP_EETIME, 1)
                call reallocate_real( P%HEAT%STEP_DELMIN, 1)
                call reallocate_real( P%HEAT%STEP_DELMAX, 1)
                P%HEAT%STEP_DLTIME = 0
                P%HEAT%STEP_EETIME = 0
                P%HEAT%STEP_DELMIN = 0
                P%HEAT%STEP_DELMAX = 0
        end if
end subroutine fstr_setup_post

!*****************************************************************************!
!* GENERAL HEADERS ***********************************************************!
!*****************************************************************************!

!-----------------------------------------------------------------------------!
! FSTR_SETUP_SOLUTION                                                         !
!-----------------------------------------------------------------------------!

subroutine fstr_setup_SOLUTION( ctrl, counter, P )
        implicit none
        integer(kind=kint) :: ctrl
        integer(kind=kint) :: counter
        type(fstr_param_pack) :: P

        integer(kind=kint) :: rcode

        rcode = fstr_ctrl_get_SOLUTION( ctrl, P%PARAM%solution_type )
        if( rcode /= 0 ) call fstr_ctrl_err_stop

end subroutine fstr_setup_SOLUTION

!-----------------------------------------------------------------------------!
! FSTR_SETUP_SOLVER                                                           !
!-----------------------------------------------------------------------------!

subroutine fstr_setup_SOLVER( ctrl, counter, P )
        implicit none
        integer(kind=kint) :: ctrl
        integer(kind=kint) :: counter
        type(fstr_param_pack),target :: P

        integer(kind=kint) :: rcode
        integer(kind=kint),pointer :: method, precond, nset, iterlog, timelog
        integer(kind=kint),pointer :: nier, iterpremax, nrest
        real(kind=kreal),pointer   :: resid, sigma_diag, sigma
        real(kind=kreal),pointer   :: thresh, filter

        if( counter >= 2 ) then
                write(ILOG,*) '### Error : !SOLVER exists twice in FSTR control file.'
                STOP
        endif

        nier       => P%MAT%Iarray(1)
        method     => P%MAT%Iarray(2)
        precond    => P%MAT%Iarray(3)
        nset       => P%MAT%Iarray(4)
        iterpremax => P%MAT%Iarray(5)
        nrest      => P%MAT%Iarray(6)
        iterlog    => P%MAT%Iarray(21)
        timelog    => P%MAT%Iarray(22)

        resid      => P%MAT%Rarray(1)
        sigma_diag => P%MAT%Rarray(2)
        sigma      => P%MAT%Rarray(3)
        thresh     => P%MAT%Rarray(4)
        filter     => P%MAT%Rarray(5)

        rcode = fstr_ctrl_get_SOLVER( ctrl,                      &
                        method, precond, nset, iterlog, timelog, &
                        nier, iterpremax, nrest,                 &
                        resid, sigma_diag, sigma,                &
                        thresh, filter )
        if( rcode /= 0 ) call fstr_ctrl_err_stop

        if( method < 100 ) then
                P%MAT%Iarray(99) = 1  ! indirect method
        else
                P%MAT%Iarray(99) = 2  ! direct method
        end if

end subroutine fstr_setup_SOLVER


!-----------------------------------------------------------------------------!
! FSTR_SETUP_STEP                                                             !
!-----------------------------------------------------------------------------!

subroutine fstr_setup_STEP( ctrl, counter, P )
        implicit none
        integer(kind=kint) :: ctrl
        integer(kind=kint) :: counter
        type(fstr_param_pack) :: P
        character(HECMW_NAME_LEN) :: amp
        integer(kind=kint) :: amp_id

        integer(kind=kint) :: rcode

        amp = ' '
        rcode = fstr_ctrl_get_STEP( ctrl, amp, P%PARAM%iproc, P%PARAM%incmax )
        if( rcode /= 0 ) call fstr_ctrl_err_stop
        call amp_name_to_id( P%MESH, '!STEP', amp, amp_id )
        P%SOLID%NLSTATIC_ngrp_amp = amp_id;

end subroutine fstr_setup_STEP


!-----------------------------------------------------------------------------!
! FSTR_SETUP_WRITE                                                            !
!-----------------------------------------------------------------------------!

subroutine fstr_setup_WRITE( ctrl, counter, P )
        implicit none
        integer(kind=kint) :: ctrl
        integer(kind=kint) :: counter
        type(fstr_param_pack) :: P
        integer(kind=kint) :: res, visual, neutral

        integer(kind=kint) :: rcode

        rcode = fstr_ctrl_get_WRITE( ctrl, res, visual, neutral )
        if( rcode /= 0 ) call fstr_ctrl_err_stop
        if( res == 1 ) P%PARAM%fg_result = 1
        if( visual == 1 ) P%PARAM%fg_visual = 1
        if( neutral == 1 ) P%PARAM%fg_neutral = 1

end subroutine fstr_setup_WRITE


!-----------------------------------------------------------------------------!
! FSTR_SETUP_ECHO                                                             !
!-----------------------------------------------------------------------------!

subroutine fstr_setup_ECHO( ctrl, counter, P )
        implicit none
        integer(kind=kint) :: ctrl
        integer(kind=kint) :: counter
        type(fstr_param_pack) :: P

        integer(kind=kint) :: rcode

        rcode = fstr_ctrl_get_ECHO( ctrl,        &
                                P%PARAM%fg_echo )
        if( rcode /= 0 ) call fstr_ctrl_err_stop

end subroutine fstr_setup_ECHO


!-----------------------------------------------------------------------------!
! FSTR_SETUP_COUPLE                                                           !
!-----------------------------------------------------------------------------!

subroutine fstr_setup_COUPLE( ctrl, counter, P )
        implicit none
        integer(kind=kint) :: ctrl
        integer(kind=kint) :: counter
        type(fstr_param_pack) :: P
        integer(kind=kint) :: rcode
        character(HECMW_NAME_LEN), pointer :: grp_id_name(:)
        integer(kind=kint) :: i, n, old_size, new_size

        if( P%SOLID%file_type /= kbcfFSTR ) return

        n = fstr_ctrl_get_data_line_n( ctrl )
        if( n == 0 ) return
        old_size = P%SOLID%COUPLE_ngrp_tot
        new_size = old_size + n
        P%SOLID%COUPLE_ngrp_tot = new_size

        call fstr_expand_integer_array ( P%SOLID%COUPLE_ngrp_ID,  old_size, new_size )

        allocate( grp_id_name(n))
        rcode = fstr_ctrl_get_COUPLE( ctrl,           &
                        P%PARAM%fg_couple_first,      &
                        grp_id_name, HECMW_NAME_LEN  )
        if( rcode /= 0 ) call fstr_ctrl_err_stop

        call surf_grp_name_to_id_ex( P%MESH, '!COUPLE', &
                        n, grp_id_name, P%SOLID%COUPLE_ngrp_ID(old_size+1:))

        deallocate( grp_id_name )
        P%PARAM%fg_couple = 1

end subroutine fstr_setup_COUPLE


!*****************************************************************************!
!* HEADERS FOR STATIC ANALYSIS ***********************************************!
!*****************************************************************************!

!-----------------------------------------------------------------------------!
! FSTR_SETUP_STATIC                                                           !
!-----------------------------------------------------------------------------!

subroutine fstr_setup_STATIC( ctrl, counter, P )
        implicit none
        integer(kind=kint) :: ctrl
        integer(kind=kint) :: counter
        type(fstr_param_pack) :: P
        integer(kind=kint) :: rcode

        if( counter > 1 ) then
                write(*,*) 
        endif

        rcode = fstr_ctrl_get_STATIC( ctrl, &
                        DT, ETIME, ITMAX, EPS, P%SOLID%restart_nout, &
                        P%SOLID%idx_elpl, &
                        P%SOLID%iout_list, &
                        P%SOLID%sig_y0, P%SOLID%h_dash, &
                        P%SOLID%nout, P%SOLID%nout_monit, P%SOLID%node_monit_1, &
                        P%SOLID%elem_monit_1, P%SOLID%intg_monit_1,             &
                        P%SOLID%idx_stres, P%SOLID%idx_stran )

        if( rcode /= 0 ) call fstr_ctrl_err_stop
        
end subroutine fstr_setup_STATIC

!-----------------------------------------------------------------------------!
! FSTR_SETUP_BOUNDARY                                                         !
!-----------------------------------------------------------------------------!

subroutine fstr_setup_BOUNDARY( ctrl, counter, P )
        implicit none
        integer(kind=kint) :: ctrl
        integer(kind=kint) :: counter
        type(fstr_param_pack) :: P

        integer(kind=kint) :: rcode
        integer(kind=kint) :: type = 0
        character(HECMW_NAME_LEN) :: amp
        integer(kind=kint) :: amp_id
        character(HECMW_NAME_LEN), pointer :: grp_id_name(:)
        integer(kind=kint),pointer :: dof_ids (:)
        integer(kind=kint),pointer :: dof_ide (:)
        real(kind=kreal),pointer :: val_ptr(:)
        integer(kind=kint) :: i, n, old_size, new_size

        rcode = fstr_ctrl_get_param_ex( ctrl, 'TYPE ', 'FSTR,NASTRAN ', 0, 'P', type )
        if( rcode < 0 ) call fstr_ctrl_err_stop

        if( rcode == 1 ) type = 0 ! PARAM_NOTHING

        if( type == 0 ) then

                ! ENTIRE -----------------------------------------------
                
                P%SOLID%file_type = kbcfFSTR

                n = fstr_ctrl_get_data_line_n( ctrl )
                if( n == 0 ) return
                old_size = P%SOLID%BOUNDARY_ngrp_tot
                new_size = old_size + n
                P%SOLID%BOUNDARY_ngrp_tot = new_size
                call fstr_expand_integer_array (P%SOLID%BOUNDARY_ngrp_ID,  old_size, new_size )
                call fstr_expand_integer_array (P%SOLID%BOUNDARY_ngrp_type,old_size, new_size )
                call fstr_expand_real_array    (P%SOLID%BOUNDARY_ngrp_val, old_size, new_size )
                call fstr_expand_integer_array (P%SOLID%BOUNDARY_ngrp_amp, old_size, new_size )

                allocate( grp_id_name(n))
                allocate( dof_ids (n))
                allocate( dof_ide (n))

                amp = ' '
                val_ptr => P%SOLID%BOUNDARY_ngrp_val(old_size+1:)
                val_ptr = 0
                rcode = fstr_ctrl_get_BOUNDARY( ctrl,  amp,   &
                                grp_id_name, HECMW_NAME_LEN,  &
                                dof_ids, dof_ide, val_ptr) 
                if( rcode /= 0 ) call fstr_ctrl_err_stop
                call amp_name_to_id( P%MESH, '!BOUNDARY', amp, amp_id )
                call node_grp_name_to_id_ex( P%MESH, '!BOUNDARY', &
                        n, grp_id_name, P%SOLID%BOUNDARY_ngrp_ID(old_size+1:))

                do i = 1, n
                        if( (dof_ids(i) < 1).or.(6 < dof_ids(i)).or.(dof_ide(i) < 1).or.(6 < dof_ide(i)) ) then
                            write(ILOG,*) 'fstr contol file error : !BOUNDRAY : range of dof_ids and dof_ide is from 1 to 6'
                            STOP
                        end if
                        P%SOLID%BOUNDARY_ngrp_type(old_size+i) = 10 * dof_ids(i) + dof_ide(i)
                        P%SOLID%BOUNDARY_ngrp_amp(old_size+i) = amp_id
                end do

                deallocate( grp_id_name )
                deallocate( dof_ids )
                deallocate( dof_ide )
        else
                ! NASTRAN ---------------------------------------------

                P%SOLID%file_type = kbcfNASTRAN
                call fstr_setup_solid_nastran( ctrl, P%MESH, P%SOLID )
        end if

end subroutine fstr_setup_BOUNDARY


!-----------------------------------------------------------------------------!
! FSTR_SETUP_CLOAD                                                            !
!-----------------------------------------------------------------------------!

subroutine fstr_setup_CLOAD( ctrl, counter, P )
        implicit none
        integer(kind=kint) :: ctrl
        integer(kind=kint) :: counter
        type(fstr_param_pack) :: P

        integer(kind=kint) :: rcode
        character(HECMW_NAME_LEN) :: amp
        integer(kind=kint) :: amp_id
        character(HECMW_NAME_LEN), pointer :: grp_id_name(:)
        real(kind=kreal),pointer :: val_ptr(:)
        integer(kind=kint),pointer :: id_ptr(:)
        integer(kind=kint) :: i, n, old_size, new_size

        if( P%SOLID%file_type /= kbcfFSTR ) return

        n = fstr_ctrl_get_data_line_n( ctrl )
        if( n == 0 ) return
        old_size = P%SOLID%CLOAD_ngrp_tot
        new_size = old_size + n
        P%SOLID%CLOAD_ngrp_tot = new_size

        call fstr_expand_integer_array ( P%SOLID%CLOAD_ngrp_ID,  old_size, new_size )
        call fstr_expand_integer_array ( P%SOLID%CLOAD_ngrp_DOF, old_size, new_size )
        call fstr_expand_real_array    ( P%SOLID%CLOAD_ngrp_val, old_size, new_size )
        call fstr_expand_integer_array ( P%SOLID%CLOAD_ngrp_amp, old_size, new_size )

        allocate( grp_id_name(n))
        amp = ' '
        val_ptr => P%SOLID%CLOAD_ngrp_val(old_size+1:)
        id_ptr =>P%SOLID%CLOAD_ngrp_DOF(old_size+1:)
        val_ptr = 0
        rcode = fstr_ctrl_get_CLOAD( ctrl, amp,      &
                        grp_id_name, HECMW_NAME_LEN, &
                        id_ptr, val_ptr )
        if( rcode /= 0 ) call fstr_ctrl_err_stop

        call amp_name_to_id( P%MESH, '!CLOAD', amp, amp_id ) 
        do i=1,n
                P%SOLID%CLOAD_ngrp_amp(old_size+i) = amp_id
        end do
        call node_grp_name_to_id_ex( P%MESH, '!CLOAD', &
                        n, grp_id_name, P%SOLID%CLOAD_ngrp_ID(old_size+1:))

        deallocate( grp_id_name )

end subroutine fstr_setup_CLOAD

!-----------------------------------------------------------------------------!
! FSTR_SETUP_DLOAD                                                            !
!-----------------------------------------------------------------------------!

subroutine fstr_expand_dload_array( array, old_size, new_size )
        implicit none
        real(kind=kreal), pointer :: array(:,:)
        integer(kind=kint) :: old_size, new_size, i, j
        real(kind=kreal), pointer :: temp(:,:)

        if( old_size >= new_size ) then
                return
        end if

        if( associated( array ) ) then
                allocate(temp(0:6, old_size))
                temp = array
                deallocate(array)
                allocate(array(0:6, new_size))
                array = 0
                do i=1,old_size
                        do j=0,6
                                array(j,i) = temp(j,i)
                        end do
                end do
                deallocate(temp)
        else
                allocate(array(0:6, new_size))
                array = 0
        end if
end subroutine fstr_expand_dload_array


subroutine fstr_setup_DLOAD( ctrl, counter, P )
        implicit none
        integer(kind=kint) :: ctrl
        integer(kind=kint) :: counter
        type(fstr_param_pack) :: P

        integer(kind=kint) :: rcode
        character(HECMW_NAME_LEN) :: amp
        integer(kind=kint) :: amp_id
        character(HECMW_NAME_LEN), pointer :: grp_id_name(:)
        real(kind=kreal),pointer :: new_params(:,:)
        logical,pointer :: fg_surface(:)
        integer(kind=kint),pointer :: lid_ptr(:)
        integer(kind=kint) :: i, j, n, old_size, new_size

        if( P%SOLID%file_type /= kbcfFSTR ) return

        n = fstr_ctrl_get_data_line_n( ctrl )
        if( n == 0 ) return
        old_size = P%SOLID%DLOAD_ngrp_tot
        new_size = old_size + n
        P%SOLID%DLOAD_ngrp_tot = new_size
        call fstr_expand_integer_array ( P%SOLID%DLOAD_ngrp_ID,  old_size, new_size )
        call fstr_expand_integer_array ( P%SOLID%DLOAD_ngrp_LID, old_size, new_size )
        call fstr_expand_integer_array ( P%SOLID%DLOAD_ngrp_amp, old_size, new_size )
        call fstr_expand_dload_array ( P%SOLID%DLOAD_ngrp_params, old_size, new_size )

        allocate( grp_id_name(n))
        allocate( new_params(0:6,n))
        allocate( fg_surface(n))
        new_params = 0
        amp = ' '
        lid_ptr => P%SOLID%DLOAD_ngrp_LID(old_size+1:)
        rcode = fstr_ctrl_get_DLOAD( ctrl, amp,         &
                        grp_id_name, HECMW_NAME_LEN,    &
                        lid_ptr, new_params )
        if( rcode /= 0 ) call fstr_ctrl_err_stop
        call amp_name_to_id( P%MESH, '!DLOAD', amp, amp_id ) 
        do i=1,n
                P%SOLID%DLOAD_ngrp_amp(old_size+i) = amp_id
                do j=0, 6
                        P%SOLID%DLOAD_ngrp_params(j,old_size+i) = new_params(j,i)
                end do
                fg_surface(i) =  ( lid_ptr(i) == 100 )
        end do
        call dload_grp_name_to_id_ex( P%MESH, n, grp_id_name, fg_surface, P%SOLID%DLOAD_ngrp_ID(old_size+1:))
        deallocate( grp_id_name )
        deallocate( new_params )
        deallocate( fg_surface )
end subroutine fstr_setup_DLOAD


!-----------------------------------------------------------------------------!
! FSTR_SETUP_TEMPERATURE                                                      !
!-----------------------------------------------------------------------------!

subroutine fstr_setup_TEMPERATURE( ctrl, counter, P )
        implicit none
        integer(kind=kint) :: ctrl
        integer(kind=kint) :: counter
        type(fstr_param_pack) :: P

        integer(kind=kint) :: rcode
        character(HECMW_NAME_LEN), pointer :: grp_id_name(:)
        real(kind=kreal),pointer :: val_ptr(:)
        integer(kind=kint) :: n, old_size, new_size

        if( P%SOLID%file_type /= kbcfFSTR ) return

        n = fstr_ctrl_get_data_line_n( ctrl )
        if( n == 0 ) return
        old_size = P%SOLID%TEMP_ngrp_tot
        new_size = old_size + n
        P%SOLID%TEMP_ngrp_tot = new_size
        call fstr_expand_integer_array ( P%SOLID%TEMP_ngrp_ID, old_size, new_size )
        call fstr_expand_real_array    ( P%SOLID%TEMP_ngrp_val,old_size, new_size )

        allocate( grp_id_name(n))
        val_ptr => P%SOLID%TEMP_ngrp_val( old_size+1: )
        rcode = fstr_ctrl_get_TEMPERATURE( ctrl,      &
                        grp_id_name, HECMW_NAME_LEN,  &
                        val_ptr )
        if( rcode /= 0 ) call fstr_ctrl_err_stop
        call node_grp_name_to_id_ex( P%MESH, '!TEMPERATURE', &
                n, grp_id_name, P%SOLID%TEMP_ngrp_ID(old_size+1:))
        deallocate( grp_id_name )

end subroutine fstr_setup_TEMPERATURE


!-----------------------------------------------------------------------------!
! FSTR_SETUP_REFTEMP                                                          !
!-----------------------------------------------------------------------------!

subroutine fstr_setup_REFTEMP( ctrl, counter, P )
        implicit none
        integer(kind=kint) :: ctrl
        integer(kind=kint) :: counter
        type(fstr_param_pack) :: P

        integer(kind=kint) :: rcode

        rcode = fstr_ctrl_get_REFTEMP( ctrl, P%PARAM%ref_temp )
        if( rcode /= 0 ) call fstr_ctrl_err_stop

end subroutine fstr_setup_REFTEMP

!-----------------------------------------------------------------------------!
! FSTR_SETUP_VISCO                                                            !
!-----------------------------------------------------------------------------!

subroutine fstr_setup_VISCO( ctrl, counter, P )
        implicit none
        integer(kind=kint) :: ctrl
        integer(kind=kint) :: counter
        type(fstr_param_pack) :: P
        integer(kind=kint) :: rcode

        rcode = fstr_ctrl_get_VISCO( ctrl, &
                P%SOLID%idx_visco,         &
                P%SOLID%ccc_rl )

        if( rcode /= 0) call fstr_ctrl_err_stop

end subroutine fstr_setup_VISCO 

!-----------------------------------------------------------------------------!
! FSTR_SETUP_ORTHO_SOLID                                                      !
!-----------------------------------------------------------------------------!

subroutine fstr_setup_ORTHO_SOLID( ctrl, counter, P )
        implicit none
        integer(kind=kint) :: ctrl
        integer(kind=kint) :: counter
        type(fstr_param_pack) :: P
        integer(kind=kint) :: rcode

        rcode = fstr_ctrl_get_ORTHO_SOLID( ctrl, &
                P%SOLID%idx_out_cood_st,         &
                P%SOLID%mat_iso_num,             &
                P%SOLID%GBARU_matrl,             &
                P%SOLID%mat_otho,                &
                P%SOLID%mat_beta )

        if( rcode /= 0) call fstr_ctrl_err_stop

end subroutine fstr_setup_ORTHO_SOLID

!-----------------------------------------------------------------------------!
! FSTR_SETUP_RESIN_SOLID                                                      !
!-----------------------------------------------------------------------------!

subroutine fstr_setup_RESIN_SOLID( ctrl, counter, P )
        implicit none
        integer(kind=kint) :: ctrl
        integer(kind=kint) :: counter
        type(fstr_param_pack) :: P
        integer(kind=kint) :: rcode

        rcode = fstr_ctrl_get_RESIN_SOLID( ctrl, &
                P%SOLID%idx_temp,         &
                P%SOLID%sub_intvl,        &
                P%SOLID%idx_young,         &
                P%SOLID%idx_cte,         &
                P%SOLID%ccc_rl,         &
                P%SOLID%ramd_chm )

        if( rcode /= 0) call fstr_ctrl_err_stop

end subroutine fstr_setup_RESIN_SOLID 


!*****************************************************************************!
!* HEADERS FOR HEAT ANALYSIS *************************************************!
!*****************************************************************************!

!-----------------------------------------------------------------------------!
! FSTR_SETUP_HEAT                                                             !
!-----------------------------------------------------------------------------!

subroutine fstr_setup_HEAT( ctrl, counter, P )
        implicit none
        integer(kind=kint) :: ctrl
        integer(kind=kint) :: counter
        type(fstr_param_pack) :: P

        integer(kind=kint) :: rcode
        integer(kind=kint) :: n

        n = fstr_ctrl_get_data_line_n( ctrl )

        if( n == 0 ) return

        call reallocate_real( P%PARAM%dtime, n)
        call reallocate_real( P%PARAM%etime, n)
        call reallocate_real( P%PARAM%dtmin, n)
        call reallocate_real( P%PARAM%delmax,n)
        call reallocate_integer( P%PARAM%itmax, n)
        call reallocate_real( P%PARAM%eps,   n)
        P%PARAM%analysis_n = n

        P%PARAM%dtime = 0
        P%PARAM%etime = 0
        P%PARAM%dtmin = 0
        P%PARAM%delmax = 0
        P%PARAM%itmax = 20
        P%PARAM%eps = 1.0e-6

        rcode = fstr_ctrl_get_HEAT(   ctrl,        &
                                P%PARAM%fg_irres,  &
                                P%PARAM%dtime,     &
                                P%PARAM%etime,     &
                                P%PARAM%dtmin,     &
                                P%PARAM%delmax,    &
                                P%PARAM%itmax,     &
                                P%PARAM%eps )
        if( rcode /= 0 ) then
                call fstr_ctrl_err_stop
        end if

        call reallocate_real( P%HEAT%STEP_DLTIME, n)
        call reallocate_real( P%HEAT%STEP_EETIME, n)
        call reallocate_real( P%HEAT%STEP_DELMIN, n)
        call reallocate_real( P%HEAT%STEP_DELMAX, n)
        P%HEAT%STEPtot = n

        P%HEAT%STEP_DLTIME = P%PARAM%dtime
        P%HEAT%STEP_EETIME = P%PARAM%etime
        P%HEAT%STEP_DELMIN = P%PARAM%dtmin
        P%HEAT%STEP_DELMAX = P%PARAM%delmax

end subroutine fstr_setup_HEAT

!-----------------------------------------------------------------------------!
! FSTR_SETUP_FIXTEMP                                                          !
!-----------------------------------------------------------------------------!

subroutine fstr_setup_FIXTEMP( ctrl, counter, P )
        implicit none
        integer(kind=kint) :: ctrl
        integer(kind=kint) :: counter
        type(fstr_param_pack),target :: P

        integer(kind=kint) :: rcode
        character(HECMW_NAME_LEN) :: amp
        integer(kind=kint) :: amp_id
        character(HECMW_NAME_LEN), pointer :: grp_id_name(:)
        real(kind=kreal),pointer :: value(:)
        integer(kind=kint) :: i, j, n, m, head, id, member_n, old_size, new_size
        integer(kind=kint),pointer :: member(:)
        integer(kind=kint) :: local_id, rtc
        ! ------------------------------------------------

        n = fstr_ctrl_get_data_line_n( ctrl )
        if( n == 0 ) return

        allocate( grp_id_name(n))
        allocate( value(n))

        amp = ' '
        rcode = fstr_ctrl_get_FIXTEMP( ctrl, amp, &
                        grp_id_name, HECMW_NAME_LEN, value )
        if( rcode /= 0 ) call fstr_ctrl_err_stop

        call amp_name_to_id( P%MESH, '!FIXTEMP', amp, amp_id ) 

        m = 0
        do i = 1, n
                rtc = get_local_member_index( P%MESH, 'node', grp_id_name(i), local_id )
                if( rtc > 0 ) then
                        m = m + 1
                else if( rtc < 0 ) then
                        m = m + get_grp_member_n( P%MESH, 'node_grp', grp_id_name(i) )
                end if
        end do

        if (m == 0) then
                deallocate( grp_id_name )
                deallocate( value )
                return
        endif

        ! JP-8
        old_size = P%HEAT%T_FIX_tot
        new_size = old_size + m
        call fstr_expand_integer_array( P%HEAT%T_FIX_node, old_size, new_size )
        call fstr_expand_integer_array( P%HEAT%T_FIX_ampl, old_size, new_size )
        call fstr_expand_real_array(    P%HEAT%T_FIX_val,  old_size, new_size )
        P%HEAT%T_FIX_tot = new_size

        head = old_size + 1
        member => P%HEAT%T_FIX_node(head:)
        id = head
        do i = 1, n
                rtc = get_local_member_index( P%MESH, 'node', grp_id_name(i), local_id )
                if( rtc > 0 ) then
                        member(1) = local_id
                        member_n = 1
                else if( rtc < 0 ) then
                        member_n = get_grp_member( P%MESH, 'node_grp', grp_id_name(i), member )
                else
                        cycle
                end if
                if( i<n ) then
                        member => member( member_n+1 : )
                endif
                do j = 1, member_n
                        P%HEAT%T_FIX_val  (id) = value(i)
                        P%HEAT%T_FIX_ampl (id) = amp_id
                        id = id + 1
                end do
        end do

        deallocate( grp_id_name )
        deallocate( value )
end subroutine fstr_setup_FIXTEMP


!-----------------------------------------------------------------------------!
! FSTR_SETUP_CFLUX                                                            !
!-----------------------------------------------------------------------------!

subroutine fstr_setup_CFLUX( ctrl, counter, P )
        implicit none
        integer(kind=kint) :: ctrl
        integer(kind=kint) :: counter
        type(fstr_param_pack) :: P

        integer(kind=kint) :: rcode
        character(HECMW_NAME_LEN) :: amp
        integer(kind=kint) :: amp_id
        character(HECMW_NAME_LEN), pointer :: grp_id_name(:)
        real(kind=kreal),pointer :: value(:)
        integer(kind=kint) :: i, j, n, m, head, id, member_n, old_size, new_size
        integer(kind=kint),pointer :: member(:)
        integer(kind=kint) :: local_id, rtc
        ! ------------------------------------------------

        n = fstr_ctrl_get_data_line_n( ctrl )
        if( n == 0 ) return

        allocate( grp_id_name(n))
        allocate( value(n))

        amp = ' '
        rcode = fstr_ctrl_get_CFLUX( ctrl, amp, &
                        grp_id_name, HECMW_NAME_LEN, value )
        if( rcode /= 0 ) call fstr_ctrl_err_stop

        call amp_name_to_id( P%MESH, '!CFLUX', amp, amp_id ) 

        m = 0

        do i = 1, n
                rtc = get_local_member_index( P%MESH, 'node', grp_id_name(i), local_id )
                if( rtc > 0 ) then
                        m = m + 1
                else if( rtc < 0 ) then
                        m = m + get_grp_member_n( P%MESH, 'node_grp', grp_id_name(i) )
                end if
        end do

        if (m == 0) then
                deallocate( grp_id_name )
                deallocate( value )
                return
        endif

        ! JP-9
        old_size = P%HEAT%Q_NOD_tot
        new_size = old_size + m
        call fstr_expand_integer_array( P%HEAT%Q_NOD_node, old_size, new_size )
        call fstr_expand_integer_array( P%HEAT%Q_NOD_ampl, old_size, new_size )
        call fstr_expand_real_array(    P%HEAT%Q_NOD_val,  old_size, new_size )
        P%HEAT%Q_NOD_tot = new_size

        head = old_size + 1
        member => P%HEAT%Q_NOD_node(head:)
        id = head
        do i = 1, n
                rtc = get_local_member_index( P%MESH, 'node', grp_id_name(i), local_id )
                if( rtc > 0 ) then
                        member(1) = local_id
                        member_n = 1
                else if( rtc < 0 ) then
                        member_n = get_grp_member( P%MESH, 'node_grp', grp_id_name(i), member )
                else
                        cycle
                end if
                if( i<n ) member => member( member_n+1 : )
                do j = 1, member_n
                        P%HEAT%Q_NOD_val  (id) = value(i)
                        P%HEAT%Q_NOD_ampl (id) = amp_id
                        id = id + 1
                end do
        end do

        deallocate( grp_id_name )
        deallocate( value )
end subroutine fstr_setup_CFLUX


!-----------------------------------------------------------------------------!
! FSTR_SETUP_DFLUX                                                            !
!-----------------------------------------------------------------------------!


subroutine fstr_setup_DFLUX( ctrl, counter, P )
        implicit none
        integer(kind=kint) :: ctrl
        integer(kind=kint) :: counter
        type(fstr_param_pack) :: P

        integer(kind=kint) :: rcode
        character(HECMW_NAME_LEN) :: amp
        integer(kind=kint) :: amp_id
        character(HECMW_NAME_LEN), pointer :: grp_id_name(:)
        integer(kind=kint),pointer :: load_type(:)
        real(kind=kreal),pointer :: value(:)
        integer(kind=kint) :: i, j, n, m, head, id, member_n, old_size, new_size
        integer(kind=kint),pointer :: member(:)
        integer(kind=kint) :: local_id, rtc
        ! ------------------------------------------------

        n = fstr_ctrl_get_data_line_n( ctrl )
        if( n == 0 ) return

        allocate( grp_id_name(n))
        allocate( load_type(n))
        allocate( value(n))

        amp = ' '
        rcode = fstr_ctrl_get_DFLUX( ctrl, amp, &
                        grp_id_name, HECMW_NAME_LEN, load_type, value )
        if( rcode /= 0 ) call fstr_ctrl_err_stop

        call amp_name_to_id( P%MESH, '!DFLUX', amp, amp_id ) 

        m = 0
        do i = 1, n
                rtc = get_local_member_index( P%MESH, 'element', grp_id_name(i), local_id )
                if( rtc > 0 ) then
                        m = m + 1
                else if( rtc < 0 ) then
                        m = m + get_grp_member_n( P%MESH, 'elem_grp', grp_id_name(i) )
                end if
        end do

        if (m == 0) then
                deallocate( grp_id_name )
                deallocate( load_type )
                deallocate( value )
                return
        endif

        ! JP-10
        old_size = P%HEAT%Q_SUF_tot
        new_size = old_size + m
        call fstr_expand_integer_array( P%HEAT%Q_SUF_elem, old_size, new_size )
        call fstr_expand_integer_array( P%HEAT%Q_SUF_ampl, old_size, new_size )
        call fstr_expand_integer_array( P%HEAT%Q_SUF_surf, old_size, new_size )
        call fstr_expand_real_array(    P%HEAT%Q_SUF_val,  old_size, new_size )
        P%HEAT%Q_SUF_tot = new_size

        head = old_size + 1
        member => P%HEAT%Q_SUF_elem(head:)
        id = head
        do i = 1, n
                rtc = get_local_member_index( P%MESH, 'element', grp_id_name(i), local_id )
                if( rtc > 0 ) then
                        member(1) = local_id
                        member_n = 1
                else if( rtc < 0 ) then
                        member_n = get_grp_member( P%MESH, 'elem_grp', grp_id_name(i), member )
                else
                        cycle
                end if
                if( i<n ) member => member( member_n+1 : )
                do j = 1, member_n
                        P%HEAT%Q_SUF_surf (id) = load_type(i)
                        P%HEAT%Q_SUF_val  (id) = value(i)
                        P%HEAT%Q_SUF_ampl (id) = amp_id
                        id = id + 1
                end do
        end do

        deallocate( grp_id_name )
        deallocate( load_type )
        deallocate( value )
end subroutine fstr_setup_DFLUX


!-----------------------------------------------------------------------------!
! FSTR_SETUP_SFLUX                                                            !
!-----------------------------------------------------------------------------!


subroutine fstr_setup_SFLUX( ctrl, counter, P )
        implicit none
        integer(kind=kint) :: ctrl
        integer(kind=kint) :: counter
        type(fstr_param_pack) :: P

        integer(kind=kint) :: rcode
        character(HECMW_NAME_LEN) :: amp
        integer(kind=kint) :: amp_id
        character(HECMW_NAME_LEN), pointer :: grp_id_name(:)
        real(kind=kreal),pointer :: value(:)
        integer(kind=kint) :: i, j, n, m, head, id, member_n, old_size, new_size
        integer(kind=kint),pointer :: member1(:), member2(:)
        ! ------------------------------------------------

        n = fstr_ctrl_get_data_line_n( ctrl )
        if( n == 0 ) return

        allocate( grp_id_name(n))
        allocate( value(n))

        amp = ' '
        rcode = fstr_ctrl_get_SFLUX( ctrl, amp, &
                        grp_id_name, HECMW_NAME_LEN, value )
        if( rcode /= 0 ) call fstr_ctrl_err_stop

        call amp_name_to_id( P%MESH, '!SFLUX', amp, amp_id ) 

        m = 0
        do i = 1, n
                m = m + get_grp_member_n( P%MESH, 'surf_grp', grp_id_name(i) )
        end do

        if (m == 0) then
                deallocate( grp_id_name )
                deallocate( value )
                return
        endif

        ! JP-11
        old_size = P%HEAT%Q_SUF_tot
        new_size = old_size + m
        call fstr_expand_integer_array( P%HEAT%Q_SUF_elem, old_size, new_size )
        call fstr_expand_integer_array( P%HEAT%Q_SUF_ampl, old_size, new_size )
        call fstr_expand_integer_array( P%HEAT%Q_SUF_surf, old_size, new_size )
        call fstr_expand_real_array(    P%HEAT%Q_SUF_val,  old_size, new_size )
        P%HEAT%Q_SUF_tot = new_size

        head = old_size + 1
        member1 => P%HEAT%Q_SUF_elem(head:)
        member2 => P%HEAT%Q_SUF_surf(head:)
        id = head
        do i = 1, n
                member_n = get_grp_member( P%MESH, 'surf_grp', grp_id_name(i), member1, member2 )
                if( i<n ) then
                        member1 => member1( member_n+1 : )
                        member2 => member2( member_n+1 : )
                end if
                do j = 1, member_n
                        P%HEAT%Q_SUF_val  (id) = value(i)
                        P%HEAT%Q_SUF_ampl (id) = amp_id
                        id = id + 1
                end do
        end do

        deallocate( grp_id_name )
        deallocate( value )
end subroutine fstr_setup_SFLUX


!-----------------------------------------------------------------------------!
! FSTR_SETUP_FILM                                                             !
!-----------------------------------------------------------------------------!


subroutine fstr_setup_FILM( ctrl, counter, P )
        implicit none
        integer(kind=kint) :: ctrl
        integer(kind=kint) :: counter
        type(fstr_param_pack) :: P

        integer(kind=kint) :: rcode
        character(HECMW_NAME_LEN) :: amp1, amp2
        integer(kind=kint) :: amp_id1, amp_id2
        character(HECMW_NAME_LEN), pointer :: grp_id_name(:)
        integer(kind=kint),pointer :: load_type(:)
        real(kind=kreal),pointer :: value(:)
        real(kind=kreal),pointer :: shink(:)
        integer(kind=kint) :: i, j, n, m, head, id, member_n, old_size, new_size
        integer(kind=kint),pointer :: member(:)
        integer(kind=kint) :: local_id, rtc
        ! ------------------------------------------------

        n = fstr_ctrl_get_data_line_n( ctrl )
        if( n == 0 ) return

        allocate( grp_id_name(n))
        allocate( load_type(n))
        allocate( value(n))
        allocate( shink(n))

        amp1 = ' '
        amp2 = ' '

        rcode = fstr_ctrl_get_FILM( ctrl, amp1, amp2, &
                        grp_id_name, HECMW_NAME_LEN, load_type, value, shink )
        if( rcode /= 0 ) call fstr_ctrl_err_stop

        call amp_name_to_id( P%MESH, '!FILM', amp1, amp_id1 ) 
        call amp_name_to_id( P%MESH, '!FILM', amp2, amp_id2 ) 

        m = 0
        do i = 1, n
                rtc = get_local_member_index( P%MESH, 'element', grp_id_name(i), local_id )
                if( rtc > 0 ) then
                        m = m + 1
                else if( rtc < 0 ) then
                        m = m + get_grp_member_n( P%MESH, 'elem_grp', grp_id_name(i) )
                end if
        end do

        if (m == 0) then
                deallocate( grp_id_name )
                deallocate( load_type )
                deallocate( value )
                deallocate( shink )
                return
        endif

        ! JP-12
        old_size = P%HEAT%H_SUF_tot
        new_size = old_size + m
        call fstr_expand_integer_array(  P%HEAT%H_SUF_elem,    old_size, new_size )
        call fstr_expand_integer_array2( P%HEAT%H_SUF_ampl, 2, old_size, new_size )
        call fstr_expand_integer_array(  P%HEAT%H_SUF_surf,    old_size, new_size )
        call fstr_expand_real_array2(    P%HEAT%H_SUF_val,  2, old_size, new_size )
        P%HEAT%H_SUF_tot = new_size

        head = old_size + 1
        member => P%HEAT%H_SUF_elem(head:)
        id = head
        do i = 1, n
                rtc = get_local_member_index( P%MESH, 'element', grp_id_name(i), local_id )
                if( rtc > 0 ) then
                        member(1) = local_id
                        member_n = 1
                else if( rtc < 0 ) then
                        member_n = get_grp_member( P%MESH, 'elem_grp', grp_id_name(i), member )
                else
                        cycle
                end if
                if( i<n ) member => member( member_n+1 : )
                do j = 1, member_n
                        P%HEAT%H_SUF_surf (id)   = load_type(i)
                        P%HEAT%H_SUF_val  (id,1) = value(i)
                        P%HEAT%H_SUF_val  (id,2) = shink(i)
                        P%HEAT%H_SUF_ampl (id,1) = amp_id1
                        P%HEAT%H_SUF_ampl (id,2) = amp_id2
                        id= id + 1
                end do
        end do

        deallocate( grp_id_name )
        deallocate( load_type )
        deallocate( value )
        deallocate( shink )
end subroutine fstr_setup_FILM


!-----------------------------------------------------------------------------!
! FSTR_SETUP_SFILM                                                            !
!-----------------------------------------------------------------------------!


subroutine fstr_setup_SFILM( ctrl, counter, P )
        implicit none
        integer(kind=kint) :: ctrl
        integer(kind=kint) :: counter
        type(fstr_param_pack) :: P

        integer(kind=kint) :: rcode
        character(HECMW_NAME_LEN) :: amp1, amp2
        integer(kind=kint) :: amp_id1, amp_id2
        character(HECMW_NAME_LEN), pointer :: grp_id_name(:)
        real(kind=kreal),pointer :: value(:)
        real(kind=kreal),pointer :: shink(:)
        integer(kind=kint) :: i, j, n, m, head, id, member_n, old_size, new_size
        integer(kind=kint),pointer :: member1(:), member2(:)
        ! ------------------------------------------------

        n = fstr_ctrl_get_data_line_n( ctrl )
        if( n == 0 ) return

        allocate( grp_id_name(n))
        allocate( value(n))
        allocate( shink(n))

        amp1 = ' '
        amp2 = ' '
        rcode = fstr_ctrl_get_SFILM( ctrl, amp1, amp2, &
                        grp_id_name, HECMW_NAME_LEN, value, shink )
        if( rcode /= 0 ) call fstr_ctrl_err_stop

        call amp_name_to_id( P%MESH, '!SFILM', amp1, amp_id1 ) 
        call amp_name_to_id( P%MESH, '!SFILM', amp2, amp_id2 ) 

        m = 0
        do i = 1, n
                m = m + get_grp_member_n( P%MESH, 'surf_grp', grp_id_name(i) )
        end do

        if (m == 0) then
                deallocate( grp_id_name )
                deallocate( value )
                deallocate( shink )
                return
        endif

        ! JP-13
        old_size = P%HEAT%H_SUF_tot
        new_size = old_size + m
        call fstr_expand_integer_array(  P%HEAT%H_SUF_elem,    old_size, new_size )
        call fstr_expand_integer_array2( P%HEAT%H_SUF_ampl, 2, old_size, new_size )
        call fstr_expand_integer_array(  P%HEAT%H_SUF_surf,    old_size, new_size )
        call fstr_expand_real_array2(    P%HEAT%H_SUF_val,  2, old_size, new_size )
        P%HEAT%H_SUF_tot = new_size

        head = old_size + 1
        member1 => P%HEAT%H_SUF_elem(head:)
        member2 => P%HEAT%H_SUF_surf(head:)
        id = head
        do i = 1, n
                member_n = get_grp_member( P%MESH, 'surf_grp', grp_id_name(i), member1, member2 )
                if( i<n ) then
                        member1 => member1( member_n+1 : )
                        member2 => member2( member_n+1 : )
                end if
                do j = 1, member_n
                        P%HEAT%H_SUF_val  (id,1) = value(i)
                        P%HEAT%H_SUF_val  (id,2) = shink(i)
                        P%HEAT%H_SUF_ampl (id,1) = amp_id1
                        P%HEAT%H_SUF_ampl (id,2) = amp_id2
                        id = id + 1
                end do
        end do

        deallocate( grp_id_name )
        deallocate( value )
        deallocate( shink )
end subroutine fstr_setup_SFILM


!-----------------------------------------------------------------------------!
! FSTR_SETUP_RADIATE                                                          !
!-----------------------------------------------------------------------------!


subroutine fstr_setup_RADIATE( ctrl, counter, P )
        implicit none
        integer(kind=kint) :: ctrl
        integer(kind=kint) :: counter
        type(fstr_param_pack) :: P

        integer(kind=kint) :: rcode
        character(HECMW_NAME_LEN) :: amp1, amp2
        integer(kind=kint) :: amp_id1, amp_id2
        character(HECMW_NAME_LEN), pointer :: grp_id_name(:)
        integer(kind=kint),pointer :: load_type(:)
        real(kind=kreal),pointer :: value(:)
        real(kind=kreal),pointer :: shink(:)
        integer(kind=kint) :: i, j, n, m, head, id, member_n, old_size, new_size
        integer(kind=kint),pointer :: member(:)
        integer(kind=kint) :: local_id, rtc
        ! ------------------------------------------------

        n = fstr_ctrl_get_data_line_n( ctrl )
        if( n == 0 ) return

        allocate( grp_id_name(n))
        allocate( load_type(n))
        allocate( value(n))
        allocate( shink(n))

        amp1 = ' '
        amp2 = ' '
        rcode = fstr_ctrl_get_RADIATE( ctrl, amp1, amp2, &
                        grp_id_name, HECMW_NAME_LEN, load_type, value, shink )
        if( rcode /= 0 ) call fstr_ctrl_err_stop

        call amp_name_to_id( P%MESH, '!RADIATE', amp1, amp_id1 ) 
        call amp_name_to_id( P%MESH, '!RADIATE', amp2, amp_id2 ) 

        m = 0
        do i = 1, n
                rtc = get_local_member_index( P%MESH, 'element', grp_id_name(i), local_id )
                if( rtc > 0 ) then
                        m = m + 1
                else if( rtc < 0 ) then
                        m = m + get_grp_member_n( P%MESH, 'elem_grp', grp_id_name(i) )
                end if
        end do

        if (m == 0) then
                deallocate( grp_id_name )
                deallocate( load_type )
                deallocate( value )
                deallocate( shink )
                return
        endif

        ! JP-14
        old_size = P%HEAT%R_SUF_tot
        new_size = old_size + m
        call fstr_expand_integer_array(  P%HEAT%R_SUF_elem,    old_size, new_size )
        call fstr_expand_integer_array2( P%HEAT%R_SUF_ampl, 2, old_size, new_size )
        call fstr_expand_integer_array(  P%HEAT%R_SUF_surf,    old_size, new_size )
        call fstr_expand_real_array2(    P%HEAT%R_SUF_val,  2, old_size, new_size )
        P%HEAT%R_SUF_tot = new_size

        head = old_size + 1
        member => P%HEAT%R_SUF_elem(head:)
        id = head
        do i = 1, n
                rtc = get_local_member_index( P%MESH, 'element', grp_id_name(i), local_id )
                if( rtc > 0 ) then
                        member(1) = local_id
                        member_n = 1
                else if( rtc < 0 ) then
                        member_n = get_grp_member( P%MESH, 'elem_grp', grp_id_name(i), member )
                else
                        cycle
                end if
                if( i<n ) member => member( member_n+1 : )
                do j = 1, member_n
                        P%HEAT%R_SUF_surf (id)   = load_type(i)
                        P%HEAT%R_SUF_val  (id,1) = value(i)
                        P%HEAT%R_SUF_val  (id,2) = shink(i)
                        P%HEAT%R_SUF_ampl (id,1) = amp_id1
                        P%HEAT%R_SUF_ampl (id,2) = amp_id2
                        id = id + 1
                end do
        end do

        deallocate( grp_id_name )
        deallocate( load_type )
        deallocate( value )
        deallocate( shink )
end subroutine fstr_setup_RADIATE


!-----------------------------------------------------------------------------!
! FSTR_SETUP_SRADIATE                                                         !
!-----------------------------------------------------------------------------!


subroutine fstr_setup_SRADIATE( ctrl, counter, P )
        implicit none
        integer(kind=kint) :: ctrl
        integer(kind=kint) :: counter
        type(fstr_param_pack) :: P

        integer(kind=kint) :: rcode
        character(HECMW_NAME_LEN) :: amp1, amp2
        integer(kind=kint) :: amp_id1, amp_id2
        character(HECMW_NAME_LEN), pointer :: grp_id_name(:)
        real(kind=kreal),pointer :: value(:)
        real(kind=kreal),pointer :: shink(:)
        integer(kind=kint) :: i, j, n, m, head, id, member_n, old_size, new_size
        integer(kind=kint),pointer :: member1(:), member2(:)
        ! ------------------------------------------------

        n = fstr_ctrl_get_data_line_n( ctrl )
        if( n == 0 ) return

        allocate( grp_id_name(n))
        allocate( value(n))
        allocate( shink(n))

        amp1 = ' '
        amp2 = ' '
        rcode = fstr_ctrl_get_SRADIATE( ctrl, amp1, amp2, grp_id_name, HECMW_NAME_LEN, value, shink )
        if( rcode /= 0 ) call fstr_ctrl_err_stop

        call amp_name_to_id( P%MESH, '!SRADIATE', amp1, amp_id1 ) 
        call amp_name_to_id( P%MESH, '!SRADIATE', amp2, amp_id2 ) 

        m = 0
        do i = 1, n
                m = m + get_grp_member_n( P%MESH, 'surf_grp', grp_id_name(i) )
        end do

        if (m == 0) then
                deallocate( grp_id_name )
                deallocate( value )
                deallocate( shink )
                return
        endif

        ! JP-15
        old_size = P%HEAT%R_SUF_tot
        new_size = old_size + m
        call fstr_expand_integer_array(  P%HEAT%R_SUF_elem,    old_size, new_size )
        call fstr_expand_integer_array2( P%HEAT%R_SUF_ampl, 2, old_size, new_size )
        call fstr_expand_integer_array(  P%HEAT%R_SUF_surf,    old_size, new_size )
        call fstr_expand_real_array2(    P%HEAT%R_SUF_val,  2, old_size, new_size )
        P%HEAT%R_SUF_tot = new_size

        head = old_size + 1
        member1 => P%HEAT%R_SUF_elem(head:)
        member2 => P%HEAT%R_SUF_surf(head:)
        id = head
        do i = 1, n
                member_n = get_grp_member( P%MESH, 'surf_grp', grp_id_name(i), member1, member2 )
                if( i<n ) then
                        member1 => member1( member_n+1 : )
                        member2 => member2( member_n+1 : )
                end if
                do j = 1, member_n
                        P%HEAT%R_SUF_val  (id,1) = value(i)
                        P%HEAT%R_SUF_val  (id,2) = shink(i)
                        P%HEAT%R_SUF_ampl (id,1) = amp_id1
                        P%HEAT%R_SUF_ampl (id,2) = amp_id2
                        id = id + 1
                end do
        end do

        deallocate( grp_id_name )
        deallocate( value )
        deallocate( shink )
end subroutine fstr_setup_SRADIATE

!-----------------------------------------------------------------------------!
! FSTR_SETUP_HEAT_PLUS                                                        !
!-----------------------------------------------------------------------------!

subroutine fstr_setup_HEAT_PLUS( ctrl, counter, P )
        implicit none
        integer(kind=kint) :: ctrl
        integer(kind=kint) :: counter
        type(fstr_param_pack) :: P
        integer(kind=kint) :: rcode

        rcode = fstr_ctrl_get_HEAT_PLUS( ctrl, &
                P%HEAT%restart_nout, &
                P%HEAT%nout,         &
                P%HEAT%nout_monit,   &
                P%HEAT%node_monit_1, &
                P%HEAT%elem_monit_1, &
                P%HEAT%intg_monit_1, &
                P%HEAT%iout_list )

        if( rcode /= 0) call fstr_ctrl_err_stop

end subroutine fstr_setup_HEAT_PLUS

!-----------------------------------------------------------------------------!
! FSTR_SETUP_ORTHO_HEAT                                                       !
!-----------------------------------------------------------------------------!

subroutine fstr_setup_ORTHO_HEAT( ctrl, counter, P )
        implicit none
        integer(kind=kint) :: ctrl
        integer(kind=kint) :: counter
        type(fstr_param_pack) :: P
        integer(kind=kint) :: rcode

        rcode = fstr_ctrl_get_ORTHO_HEAT( ctrl, &
                P%HEAT%mat_iso_num,         &
                P%HEAT%GBARU_matrl,         &
                P%HEAT%mat_k )

        if( rcode /= 0) call fstr_ctrl_err_stop

end subroutine fstr_setup_ORTHO_HEAT

!-----------------------------------------------------------------------------!
! FSTR_SETUP_RESIN_HEAT                                                       !
!-----------------------------------------------------------------------------!

subroutine fstr_setup_RESIN_HEAT( ctrl, counter, P )
        implicit none
        integer(kind=kint) :: ctrl
        integer(kind=kint) :: counter
        type(fstr_param_pack) :: P
        integer(kind=kint) :: rcode

        rcode = fstr_ctrl_get_RESIN_HEAT( ctrl, &
                P%HEAT%idx_cure,         &
                P%HEAT%nout_sta,         &
                P%HEAT%idx_dadt,         &
                P%HEAT%ccc_rl )

        if( rcode /= 0) call fstr_ctrl_err_stop

end subroutine fstr_setup_RESIN_HEAT 

!*****************************************************************************!
!* HEADERS FOR EIGEN ANALYSIS ************************************************!
!*****************************************************************************!

!-----------------------------------------------------------------------------!
! FSTR_SETUP_EIGEN                                                            !
!-----------------------------------------------------------------------------!

subroutine fstr_setup_EIGEN( ctrl, counter, P )
        implicit none
        integer(kind=kint) :: ctrl
        integer(kind=kint) :: counter
        type(fstr_param_pack) :: P

        integer(kind=kint) :: rcode

        rcode = fstr_ctrl_get_EIGEN( ctrl, P%EIGEN%nget, P%EIGEN%lcztol, P%EIGEN%lczmax)
        if( rcode /= 0) call fstr_ctrl_err_stop

end subroutine fstr_setup_EIGEN


!*****************************************************************************!
!* HEADERS FOR DYNAMIC ANALYSIS **********************************************!
!*****************************************************************************!

!-----------------------------------------------------------------------------!
! FSTR_SETUP_DYNAMIC                                                          !
!-----------------------------------------------------------------------------!

subroutine fstr_setup_DYNAMIC( ctrl, counter, P )
        implicit none
        integer(kind=kint) :: ctrl
        integer(kind=kint) :: counter
        type(fstr_param_pack) :: P
        integer(kind=kint) :: rcode

        rcode = fstr_ctrl_get_DYNAMIC( ctrl, &
                P%DYN%idx_eqa, &
                P%DYN%idx_resp,&
                P%DYN%n_step,  &
                P%DYN%t_start, &
                P%DYN%t_end,   &
                P%DYN%t_delta, &
                P%DYN%restart_nout, &
                P%DYN%ganma,   &
                P%DYN%beta,    &
                P%DYN%idx_mas, &
                P%DYN%idx_dmp, &
                P%DYN%ray_m,   &
                P%DYN%ray_k,   &
                P%DYN%nout,    &
                P%DYN%node_monit_1,&
                P%DYN%nout_monit,  &
                P%DYN%iout_list )

        if( rcode /= 0) call fstr_ctrl_err_stop

end subroutine fstr_setup_DYNAMIC


!-----------------------------------------------------------------------------!
! FSTR_SETUP_VELOCITY                                                         !
!-----------------------------------------------------------------------------!

subroutine fstr_setup_VELOCITY( ctrl, counter, P )
        implicit none
        integer(kind=kint) :: ctrl
        integer(kind=kint) :: counter
        type(fstr_param_pack) :: P

        integer(kind=kint) :: rcode
        character(HECMW_NAME_LEN) :: amp
        integer(kind=kint) :: amp_id
        character(HECMW_NAME_LEN), pointer :: grp_id_name(:)
        integer(kind=kint),pointer :: dof_ids (:)
        integer(kind=kint),pointer :: dof_ide (:)
        real(kind=kreal),pointer :: val_ptr(:)
        integer(kind=kint) :: i, j, n, old_size, new_size
                
        n = fstr_ctrl_get_data_line_n( ctrl )
        if( n == 0 ) return
        old_size = P%SOLID%VELOCITY_ngrp_tot
        new_size = old_size + n
        P%SOLID%VELOCITY_ngrp_tot = new_size

        call fstr_expand_integer_array (P%SOLID%VELOCITY_ngrp_ID  , old_size, new_size )
        call fstr_expand_integer_array (P%SOLID%VELOCITY_ngrp_type, old_size, new_size )
        call fstr_expand_real_array    (P%SOLID%VELOCITY_ngrp_val , old_size, new_size )
        call fstr_expand_integer_array (P%SOLID%VELOCITY_ngrp_amp , old_size, new_size )

        allocate( grp_id_name(n))
        allocate( dof_ids (n))
        allocate( dof_ide (n))

        amp = ''
        val_ptr => P%SOLID%VELOCITY_ngrp_val(old_size+1:)
        val_ptr = 0
        rcode = fstr_ctrl_get_VELOCITY( ctrl,  amp,   &
                grp_id_name, HECMW_NAME_LEN,  &
                dof_ids, dof_ide, val_ptr )
        if( rcode /= 0 ) call fstr_ctrl_err_stop
        call amp_name_to_id( P%MESH, '!VELOCITY', amp, amp_id ) 
        call node_grp_name_to_id_ex( P%MESH, '!VELOCITY', &
                n, grp_id_name, P%SOLID%VELOCITY_ngrp_ID(old_size+1:))

        j = old_size+1
        do i = 1, n
                if( (dof_ids(i) < 1).or.(6 < dof_ids(i)).or.(dof_ide(i) < 1).or.(6 < dof_ide(i)) ) then
                         write(ILOG,*) 'fstr contol file error : !VELOCITY : range of dof_ids and dof_ide is from 1 to 6'
                              STOP
                end if
                P%SOLID%VELOCITY_ngrp_type(j) = 10 * dof_ids(i) + dof_ide(i)
                P%SOLID%VELOCITY_ngrp_amp(j) = amp_id
                j = j+1
        end do

        deallocate( grp_id_name )
        deallocate( dof_ids )
        deallocate( dof_ide )

end subroutine fstr_setup_VELOCITY


!-----------------------------------------------------------------------------!
! FSTR_SETUP_ACCELERATION                                                     !
!-----------------------------------------------------------------------------!

subroutine fstr_setup_ACCELERATION( ctrl, counter, P )
        implicit none
        integer(kind=kint) :: ctrl
        integer(kind=kint) :: counter
        type(fstr_param_pack) :: P

        integer(kind=kint) :: rcode
        character(HECMW_NAME_LEN) :: amp
        integer(kind=kint) :: amp_id
        character(HECMW_NAME_LEN), pointer :: grp_id_name(:)
        integer(kind=kint),pointer :: dof_ids (:)
        integer(kind=kint),pointer :: dof_ide (:)
        real(kind=kreal),pointer :: val_ptr(:)
        integer(kind=kint) :: i, j, n, old_size, new_size

                
        n = fstr_ctrl_get_data_line_n( ctrl )
        if( n == 0 ) return
        old_size = P%SOLID%ACCELERATION_ngrp_tot
        new_size = old_size + n
        P%SOLID%ACCELERATION_ngrp_tot = new_size

        call fstr_expand_integer_array (P%SOLID%ACCELERATION_ngrp_ID  , old_size, new_size )
        call fstr_expand_integer_array (P%SOLID%ACCELERATION_ngrp_type, old_size, new_size )
        call fstr_expand_real_array    (P%SOLID%ACCELERATION_ngrp_val , old_size, new_size )
        call fstr_expand_integer_array (P%SOLID%ACCELERATION_ngrp_amp , old_size, new_size )

        allocate( grp_id_name(n))
        allocate( dof_ids (n))
        allocate( dof_ide (n))

        amp = ' '
        val_ptr => P%SOLID%ACCELERATION_ngrp_val(old_size+1:)
        val_ptr = 0
        rcode = fstr_ctrl_get_ACCELERATION( ctrl,  amp,   &
                grp_id_name, HECMW_NAME_LEN,  &
                dof_ids, dof_ide,  val_ptr)
        if( rcode /= 0 ) call fstr_ctrl_err_stop
        call amp_name_to_id( P%MESH, '!ACCELERATION', amp, amp_id ) 
        call node_grp_name_to_id_ex( P%MESH, '!ACCELERATION', &
                n, grp_id_name, P%SOLID%ACCELERATION_ngrp_ID(old_size+1:))

        j = old_size+1
        do i = 1, n
                if( (dof_ids(i) < 1).or.(6 < dof_ids(i)).or.(dof_ide(i) < 1).or.(6 < dof_ide(i)) ) then
                         write(ILOG,*) 'fstr contol file error : !ACCELERATION : range of dof_ids and dof_ide is from 1 to 6'
                              STOP
                end if
                P%SOLID%ACCELERATION_ngrp_type(j) = 10 * dof_ids(i) + dof_ide(i)
                P%SOLID%ACCELERATION_ngrp_amp(j) = amp_id
                j = j+1
        end do

        deallocate( grp_id_name )
        deallocate( dof_ids )
        deallocate( dof_ide )
end subroutine fstr_setup_ACCELERATION


!*****************************************************************************!
!* MPC ***********************************************************************!
!*****************************************************************************!

!-----------------------------------------------------------------------------!
! FSTR_SETUP_MPC                                                              !
!-----------------------------------------------------------------------------!

subroutine fstr_setup_MPC( ctrl, counter, P )
        implicit none
        integer(kind=kint) :: ctrl
        integer(kind=kint) :: counter
        type(fstr_param_pack), target :: P
        real(kind=kreal), pointer :: penalty

        integer(kind=kint) :: rcode
!        integer(kind=kint) :: type
!        integer(kind=kint),pointer :: node1_ptr(:)
!        integer(kind=kint),pointer :: node2_ptr(:)
!        integer(kind=kint),pointer :: dof_ptr(:)
!        integer(kind=kint) :: n, old_size, new_size
!
!        rcode = fstr_ctrl_get_param_ex( ctrl, 'TYPE ', 'RIGID ', 1, 'P', type )
!        if( rcode < 0 ) call fstr_ctrl_err_stop
!
!        n = fstr_ctrl_get_data_line_n( ctrl )
!        if( n == 0 ) return
!        old_size = P%MPC_RD%nmpc
!        new_size = old_size + n
!        P%MPC_RD%nmpc = new_size
!
!        call fstr_expand_integer_array ( P%MPC_RD%node1,  old_size, new_size )
!        call fstr_expand_integer_array ( P%MPC_RD%node2,  old_size, new_size )
!        call fstr_expand_integer_array ( P%MPC_RD%dof,    old_size, new_size )
!
!        node1_ptr => P%MPC_RD%node1(old_size+1:)
!        node2_ptr => P%MPC_RD%node2(old_size+1:)
!        dof_ptr   => P%MPC_RD%dof(old_size+1:)
!
!        rcode = fstr_ctrl_get_MPC( ctrl, type, node1_ptr, node2_ptr, dof_ptr )
!        if( rcode /= 0 ) call fstr_ctrl_err_stop
!
!        if( node_global_to_local( P%MESH, node1_ptr, n ) /= n ) then
!                call fstr_setup_util_err_stop( '### Error : not exist node (!MPC)' )
!        endif
!        if( node_global_to_local( P%MESH, node2_ptr, n ) /= n ) then
!                call fstr_setup_util_err_stop( '### Error : not exist node (!MPC)' )
!        endif

        penalty => P%MAT%Rarray(11)
        rcode = fstr_ctrl_get_MPC( ctrl, penalty)
        if( rcode /= 0) call fstr_ctrl_err_stop
end subroutine fstr_setup_MPC


!*****************************************************************************!
!* IMPORTING NASTRAN BOUNDARY CONDITIONS *************************************!
!*****************************************************************************!

subroutine fstr_setup_solid_nastran( ctrl, hecMESH, fstrSOLID )
        implicit none
        integer(kind=kint) :: ctrl
        type (hecmwST_local_mesh) :: hecMESH
        type (fstr_solid        ) :: fstrSOLID
        write(ILOG,*) '### Error : In !BOUNNDARY, TYPE=NASTRAN is not supported.'
        call hecmw_abort( hecmw_comm_get_comm())
end subroutine fstr_setup_solid_nastran

!subroutine fstr_setup_solid_nastran( ctrl, hecMESH, fstrSOLID )
!        use fstr_get_x_nastran
!        implicit none
!        integer(kind=kint) :: ctrl
!        type (hecmwST_local_mesh) :: hecMESH
!        type (fstr_solid        ) :: fstrSOLID
!
!        character(len=HECMW_FILENAME_LEN) :: fname
!        integer(kind=kint) :: rcode
!
!        rcode  = fstr_ctrl_get_param_ex( ctrl, 'FILE ',   ' ', 1, 'S', fname )
!
!        if( rcode /= 0 ) then
!                write(ILOG,*) '### Error : In !BOUNNDARY, TYPE=NASTRAN header line, "FILE" is required.'
!                STOP
!        end if
!
!        if( fstr_read_nastran_prop_init() /= 0 ) STOP
!        if( fstr_read_nastran_prop( fname ) /=0 ) STOP
!
!        call fstr_get_boundary_nastran( hecMESH, &
!                                fstrSOLID%BOUNDARY_ngrp_tot, &
!                                fstrSOLID%BOUNDARY_ngrp_ID, &
!                                fstrSOLID%BOUNDARY_ngrp_type, &
!                                fstrSOLID%BOUNDARY_ngrp_val )
!
!        call fstr_get_cload_nastran( hecMESH, &
!                                fstrSOLID%CLOAD_ngrp_tot, &
!                                fstrSOLID%CLOAD_ngrp_ID, &
!                                fstrSOLID%CLOAD_ngrp_DOF, &
!                                fstrSOLID%CLOAD_ngrp_val )
!
!        call fstr_get_dload_nastran( hecMESH, &
!                                fstrSOLID%DLOAD_ngrp_tot, &
!                                fstrSOLID%DLOAD_ngrp_ID, &
!                                fstrSOLID%DLOAD_ngrp_LID, &
!                                fstrSOLID%DLOAD_ngrp_params )
!
!        call fstr_get_temperature_nastran( hecMESH, &
!                                fstrSOLID%TEMP_ngrp_tot, &
!                                fstrSOLID%TEMP_ngrp_ID, &
!                                fstrSOLID%TEMP_ngrp_val )
!
!        if( fstr_read_nastran_prop_finalize() /= 0 ) then
!                write(ILOG,*) '### Error in FSTR_read_nastran_prop_finalize()'
!        end if
!end subroutine


end module m_fstr_setup


