!======================================================================! ! ! ! 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