!======================================================================!
!                                                                      !
!    Software Name : FrontCOMP_cure   Ver. 3.1                         !
!                                                                      !
!      Module Name : fstr_ctrl_static                                  !
!      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"  !
!                                                                      !
!======================================================================!
! fstr control file data obtaining functions

module fstr_ctrl_static
use m_fstr
use hecmw
include 'fstr_ctrl_util_f.inc'

     private :: pc_strupr
contains

subroutine pc_strupr( s )
        implicit none
        character(*) :: s
        integer :: i, n, a, da

        n = len_trim(s)
        da = iachar('a') - iachar('A')
        do i = 1, n
                a = iachar(s(i:i))
                if( a > iachar('Z')) then
                        a = a - da
                       s(i:i) = achar(a)
                end if
        end do
end subroutine pc_strupr

!* ----------------------------------------------------------------------------------------------- *!
!* !STATIC                                                                                         *!
!* ----------------------------------------------------------------------------------------------- *!

function fstr_ctrl_get_STATIC( ctrl, &
        & dtime, etime, itime, eps, restart_nout, &
        & idx_elpl, &
        & iout_list, &
        & sig_y0, h_dash, &
        & nout, nout_monit, node_monit_1, elem_monit_1, intg_monit_1,idx_stres,idx_stran )
        implicit none
        integer(kind=kint) :: ctrl
        real(kind=kreal)   :: dtime
        real(kind=kreal)   :: etime
        integer(kind=kint) :: itime
        real(kind=kreal)   :: eps
        integer(kind=kint) :: restart_nout
        integer(kind=kint) :: idx_elpl
        real(kind=kreal)   :: sig_y0, h_dash
        integer(kind=kint) :: nout, nout_monit, node_monit_1, elem_monit_1, intg_monit_1
        integer(kind=kint) :: iout_list(6)
        integer(kind=kint) :: idx_stres, idx_stran 
        integer(kind=kint) :: fstr_ctrl_get_STATIC

        fstr_ctrl_get_STATIC = -1

        if( fstr_ctrl_get_data_ex( ctrl, 1, 'rriri ', dtime, etime, itime, eps, restart_nout ) /= 0 ) return
        if( fstr_ctrl_get_data_ex( ctrl, 2, 'i ', idx_elpl ) /= 0 ) return
        if( fstr_ctrl_get_data_ex( ctrl, 3, 'iiiiii ', &
        & iout_list(1), iout_list(2), iout_list(3), iout_list(4), iout_list(5), iout_list(6)) /= 0 ) return
        if( fstr_ctrl_get_data_ex( ctrl, 4, 'rr ', sig_y0, h_dash ) /= 0 ) return
        if( fstr_ctrl_get_data_ex( ctrl, 5, 'iiiii ', &
                & nout, nout_monit, node_monit_1, elem_monit_1, intg_monit_1 ) /= 0 ) return
        if( fstr_ctrl_get_data_ex( ctrl, 6, 'ii ', idx_stres, idx_stran ) /= 0 ) return

        fstr_ctrl_get_STATIC = 0
end function fstr_ctrl_get_STATIC

!* ----------------------------------------------------------------------------------------------- *!
!* !BOUNDARY                                                                                       *!
!* ----------------------------------------------------------------------------------------------- *!

function fstr_ctrl_get_BOUNDARY( ctrl, amp, node_id, node_id_len, dof_ids, dof_ide, value )
        implicit none
        integer(kind=kint) :: ctrl
        character(len=HECMW_NAME_LEN) :: amp
        character(len=HECMW_NAME_LEN),target  :: node_id(:)
        character(len=HECMW_NAME_LEN),pointer :: node_id_p
        integer(kind=kint) :: node_id_len
        integer(kind=kint),pointer :: dof_ids (:)
        integer(kind=kint),pointer :: dof_ide (:)
        real(kind=kreal),pointer :: value(:)
        integer(kind=kint) :: fstr_ctrl_get_BOUNDARY

        character(len=HECMW_NAME_LEN) :: data_fmt,ss
        write(ss,*)  node_id_len
        write(data_fmt,'(a,a,a)') 'S',trim(adjustl(ss)),'IIr '

        fstr_ctrl_get_BOUNDARY = -1
        if( fstr_ctrl_get_param_ex( ctrl, 'AMP ',  '# ',  0, 'S', amp )/= 0) return
        node_id_p => node_id(1)
        fstr_ctrl_get_BOUNDARY = &
                fstr_ctrl_get_data_array_ex( ctrl, data_fmt, node_id_p, dof_ids, dof_ide, value )

end function fstr_ctrl_get_BOUNDARY


!* ----------------------------------------------------------------------------------------------- *!
!* !CLOAD                                                                                          *!
!* ----------------------------------------------------------------------------------------------- *!

function fstr_ctrl_get_CLOAD( ctrl, amp, node_id, node_id_len, dof_id, value )
        implicit none
        integer(kind=kint) :: ctrl
        character(len=HECMW_NAME_LEN) :: amp
        character(len=HECMW_NAME_LEN),target  :: node_id(:)
        character(len=HECMW_NAME_LEN),pointer :: node_id_p
        integer(kind=kint) :: node_id_len
        integer(kind=kint),pointer :: dof_id(:)
        real(kind=kreal),pointer :: value(:)
        integer(kind=kint) :: fstr_ctrl_get_CLOAD

        character(len=HECMW_NAME_LEN) :: data_fmt,ss
        write(ss,*)  node_id_len
        write( data_fmt, '(a,a,a)') 'S', trim(adjustl(ss)), 'IR '

        fstr_ctrl_get_CLOAD = -1
        if( fstr_ctrl_get_param_ex( ctrl, 'AMP ',  '# ',  0, 'S', amp )/= 0) return
        node_id_p => node_id(1)
        fstr_ctrl_get_CLOAD = &
                fstr_ctrl_get_data_array_ex( ctrl, data_fmt, node_id_p, dof_id, value )

end function fstr_ctrl_get_CLOAD

!* ----------------------------------------------------------------------------------------------- *!
!* !DLOAD                                                                                          *!
!* ----------------------------------------------------------------------------------------------- *!

function fstr_ctrl_get_DLOAD( ctrl, amp, element_id, element_id_len, load_type, params )
        implicit none
        integer(kind=kint) :: ctrl
        character(len=HECMW_NAME_LEN) :: amp
        character(len=HECMW_NAME_LEN),target :: element_id(:)
        integer(kind=kint) :: element_id_len
        integer(kind=kint),pointer :: load_type(:)
        real(kind=kreal),pointer :: params(:,:)
        real(kind=kreal),pointer :: pm(:,:)
        integer(kind=kint) :: fstr_ctrl_get_DLOAD

        character(len=HECMW_NAME_LEN),pointer :: type_name_list(:)
        character(len=HECMW_NAME_LEN),pointer :: type_name_list_p
        character(len=HECMW_NAME_LEN),pointer :: element_id_p

        integer(kind=kint) :: i, n
        integer(kind=kint) :: rcode
        character(len=HECMW_NAME_LEN) :: data_fmt,s1,s2
        integer(kind=kint) :: lid

        fstr_ctrl_get_DLOAD = -1
        if( fstr_ctrl_get_param_ex( ctrl, 'AMP ',  '# ',  0, 'S', amp )/= 0) return 

        write(s1,*)  element_id_len
        write(s2,*)  HECMW_NAME_LEN
        write( data_fmt, '(a,a,a,a,a)') 'S', trim(adjustl(s1)), 'S', trim(adjustl(s2)),'Rrrrrrr '

        n = fstr_ctrl_get_data_line_n(ctrl)
        allocate( type_name_list(n) )
        !!
        !! for avoiding stack overflow with intel 9 complier
        !!
        allocate( pm(n,0:6) )
        element_id_p => element_id(1)
        type_name_list_p => type_name_list(1)

        rcode = fstr_ctrl_get_data_array_ex( ctrl, data_fmt, element_id_p, type_name_list_p, &
                pm(:,0), pm(:,1), pm(:,2), pm(:,3), pm(:,4), pm(:,5), pm(:,6) )

        params(0,:) = pm(:,0)
        params(1,:) = pm(:,1)
        params(2,:) = pm(:,2)
        params(3,:) = pm(:,3)
        params(4,:) = pm(:,4)
        params(5,:) = pm(:,5)
        params(6,:) = pm(:,5)
        deallocate( pm )

        if( rcode /= 0 ) then
                deallocate( type_name_list )
                return
        end if

        do i=1, n
                call pc_strupr( type_name_list(i) )
                lid = -1;
                if(      type_name_list(i)(1:2) == 'BX'  ) then; lid = 1
                else if( type_name_list(i)(1:2) == 'BY'  ) then; lid = 2
                else if( type_name_list(i)(1:2) == 'BZ'  ) then; lid = 3
                else if( type_name_list(i)(1:4) == 'GRAV') then; lid = 4
                else if( type_name_list(i)(1:4) == 'CENT') then; lid = 5
                else if( type_name_list(i)(1:2) == 'PP'  ) then; lid = 10
                else if( type_name_list(i)(1:2) == 'P0'  ) then; lid = 10
                else if( type_name_list(i)(1:2) == 'P1'  ) then; lid = 10
                else if( type_name_list(i)(1:2) == 'P2'  ) then; lid = 20
                else if( type_name_list(i)(1:2) == 'P3'  ) then; lid = 30
                else if( type_name_list(i)(1:2) == 'P4'  ) then; lid = 40
                else if( type_name_list(i)(1:2) == 'P5'  ) then; lid = 50
                else if( type_name_list(i)(1:2) == 'P6'  ) then; lid = 60
                else if( type_name_list(i)(1:1) == 'S'   ) then; lid = 100
                else
                        write(ILOG, *) 'Error : !DLOAD : Load  type ',type_name_list(i), ' is unknown'
                        deallocate( type_name_list )
                        return
                end if
                load_type(i) = lid
        end do

        deallocate( type_name_list )
        fstr_ctrl_get_DLOAD = 0

end function fstr_ctrl_get_DLOAD



!* ----------------------------------------------------------------------------------------------- *!
!* !REFTEMP                                                                                        *!
!* ----------------------------------------------------------------------------------------------- *!

function fstr_ctrl_get_REFTEMP( ctrl, value )
        implicit none
        integer(kind=kint) :: ctrl
        real(kind=kreal)   :: value
        integer(kind=kint) :: fstr_ctrl_get_REFTEMP,rcode

        rcode = fstr_ctrl_get_data_array_ex( ctrl, 'r ', value )
        fstr_ctrl_get_REFTEMP = rcode

end function fstr_ctrl_get_REFTEMP

!* ----------------------------------------------------------------------------------------------- *!
!* !TEMPERATURE                                                                                    *!
!* ----------------------------------------------------------------------------------------------- *!


function fstr_ctrl_get_TEMPERATURE( ctrl, node_id, node_id_len, value )
        implicit none
        integer(kind=kint) :: ctrl
        character(len=HECMW_NAME_LEN), target :: node_id(:)
        character(len=HECMW_NAME_LEN), pointer:: node_id_p
        integer(kind=kint) :: node_id_len
        real(kind=kreal),pointer :: value(:)
        integer(kind=kint) :: fstr_ctrl_get_TEMPERATURE, rcode

        character(len=HECMW_NAME_LEN) :: data_fmt,ss

        write(ss,*)  node_id_len
        write(data_fmt,'(a,a,a)') 'S',trim(adjustl(ss)),'r '

        node_id_p => node_id(1)
        rcode = fstr_ctrl_get_data_array_ex( ctrl, data_fmt, node_id_p, value )
        fstr_ctrl_get_TEMPERATURE = rcode

end function fstr_ctrl_get_TEMPERATURE

!* ---------------------------------------------------------------------------------------------- *!
!* !VISCO                                                                                         *!
!* ---------------------------------------------------------------------------------------------- *!

function fstr_ctrl_get_VISCO( ctrl, &
                idx_visco,          &
                ccc_rl)
        implicit none
        integer(kind=kint) :: ctrl
!
        integer(kind=kint) :: idx_visco 
        real(kind=kreal) :: ccc_rl(12)
!
        integer(kind=kint) :: fstr_ctrl_get_VISCO

        fstr_ctrl_get_VISCO = -1
        if( fstr_ctrl_get_data_ex( ctrl, 1, 'irr ', &
                idx_visco, ccc_rl( 9), ccc_rl(10)  ) /= 0 ) return
        fstr_ctrl_get_VISCO = 0

end function fstr_ctrl_get_VISCO 


!* ---------------------------------------------------------------------------------------------- *!
!* !ORTHO_SOLID                                                                                   *!
!* ---------------------------------------------------------------------------------------------- *!

function fstr_ctrl_get_ORTHO_SOLID( ctrl,  &
                idx_out_cood_st, mat_iso_num, GBARU_matrl, &
                mat_otho, mat_beta )
        implicit none
        integer(kind=kint) :: ctrl
!
        integer(kind=kint) :: idx_out_cood_st 
        integer(kind=kint) :: mat_iso_num(10)
        real(kind=kreal) :: GBARU_matrl(3,3,10)
        real(kind=kreal) :: mat_otho(9,10)
        real(kind=kreal) :: mat_beta(3,10) 
!
        integer(kind=kint) :: fstr_ctrl_get_ORTHO_SOLID

        fstr_ctrl_get_ORTHO_SOLID = -1
        if( fstr_ctrl_get_data_ex( ctrl, 1, 'i ',  &
                idx_out_cood_st )/=0 ) return
        if( fstr_ctrl_get_data_ex( ctrl, 2, 'iiii ', mat_iso_num(1), mat_iso_num(2),  &
                mat_iso_num(3), mat_iso_num(4) )/=0 ) return
        if( fstr_ctrl_get_data_ex( ctrl, 3, 'rrrrrrrrr ',                    &
                GBARU_matrl(1,1,1), GBARU_matrl(1,2,1), GBARU_matrl(1,3,1),  &
                GBARU_matrl(2,1,1), GBARU_matrl(2,2,1), GBARU_matrl(2,3,1),  &
                GBARU_matrl(3,1,1), GBARU_matrl(3,2,1), GBARU_matrl(3,3,1) )/=0 ) return
        if( fstr_ctrl_get_data_ex( ctrl, 4, 'rrrrrrrrr ',                    &
                mat_otho(1,1), mat_otho(2,1), mat_otho(3,1),  &
                mat_otho(4,1), mat_otho(5,1), mat_otho(6,1),  &
                mat_otho(7,1), mat_otho(8,1), mat_otho(9,1) )/=0 ) return
        if( fstr_ctrl_get_data_ex( ctrl, 5, 'rrr ',                    &
                mat_beta(1,1), mat_beta(2,1), mat_beta(3,1) )/=0 ) return
        if( fstr_ctrl_get_data_ex( ctrl, 6, 'rrrrrrrrr ',                    &
                GBARU_matrl(1,1,4), GBARU_matrl(1,2,4), GBARU_matrl(1,3,4),  &
                GBARU_matrl(2,1,4), GBARU_matrl(2,2,4), GBARU_matrl(2,3,4),  &
                GBARU_matrl(3,1,4), GBARU_matrl(3,2,4), GBARU_matrl(3,3,4) )/=0 ) return
        if( fstr_ctrl_get_data_ex( ctrl, 7, 'rrrrrrrrr ',                    &
                mat_otho(1,4), mat_otho(2,4), mat_otho(3,4),  &
                mat_otho(4,4), mat_otho(5,4), mat_otho(6,4),  &
                mat_otho(7,4), mat_otho(8,4), mat_otho(9,4) )/=0 ) return
        if( fstr_ctrl_get_data_ex( ctrl, 8, 'rrr ',                    &
                mat_beta(1,4), mat_beta(2,4), mat_beta(3,4) )/=0 ) return
        fstr_ctrl_get_ORTHO_SOLID = 0

end function fstr_ctrl_get_ORTHO_SOLID

!* ---------------------------------------------------------------------------------------------- *!
!* !RESIN_SOLID                                                                                   *!
!* ---------------------------------------------------------------------------------------------- *!

function fstr_ctrl_get_RESIN_SOLID( ctrl, &
                idx_temp, sub_intvl, idx_young, idx_cte, &
                ccc_rl, ramd_chm )
        implicit none
        integer(kind=kint) :: ctrl
!
        integer(kind=kint) :: idx_temp, sub_intvl, idx_young, idx_cte 
        real(kind=kreal) :: ccc_rl(12)
        real(kind=kreal) :: ramd_chm 
!
        integer(kind=kint) :: fstr_ctrl_get_RESIN_SOLID

        fstr_ctrl_get_RESIN_SOLID = -1
        if( fstr_ctrl_get_data_ex( ctrl, 1, 'iiii ',  &
                idx_temp, sub_intvl, idx_young, idx_cte )/=0 ) return
        if( fstr_ctrl_get_data_ex( ctrl, 2, 'rrrr ',            &
                ccc_rl(1), ccc_rl(2), ccc_rl(3), ccc_rl(4)  )/=0 ) return
        if( fstr_ctrl_get_data_ex( ctrl, 3, 'rrrr ',            &
                ccc_rl(5), ccc_rl(6), ccc_rl(7), ccc_rl(8)  )/=0 ) return
        if( fstr_ctrl_get_data_ex( ctrl, 4, 'r ',   &
                ramd_chm  )/=0 ) return
        fstr_ctrl_get_RESIN_SOLID = 0

end function fstr_ctrl_get_RESIN_SOLID


!* ----------------------------------------------------------------------------------------------- *!
end module fstr_ctrl_static




