1!------------------------------------------------------------------------------- 2! Copyright (c) 2019 FrontISTR Commons 3! This software is released under the MIT License, see LICENSE.txt 4!------------------------------------------------------------------------------- 5!> \brief This module provides functions to read in data from control file 6!! and do neccessary preparation for following calculation 7module m_fstr_setup 8 use m_fstr 9 use fstr_setup_util 10 use fstr_ctrl_common 11 use fstr_ctrl_static 12 use fstr_ctrl_heat 13 use fstr_ctrl_eigen 14 use fstr_ctrl_dynamic 15 use fstr_ctrl_material 16 use mContact 17 use m_static_get_prop 18 use m_out 19 use m_step 20 use m_utilities 21 implicit none 22 23 include 'fstr_ctrl_util_f.inc' 24 25 !> Package of all data needs to initilize 26 type fstr_param_pack 27 type(hecmwST_local_mesh), pointer :: MESH 28 type(fstr_param), pointer :: PARAM 29 type(fstr_solid), pointer :: SOLID 30 type(fstr_heat), pointer :: HEAT 31 type(fstr_eigen), pointer :: EIGEN 32 type(fstr_dynamic), pointer :: DYN 33 type(fstr_couple), pointer :: CPL 34 type(fstr_freqanalysis), pointer :: FREQ 35 end type fstr_param_pack 36 37contains 38 39 !=============================================================================! 40 !> Read in and initialize control data ! 41 !=============================================================================! 42 subroutine fstr_setup( cntl_filename, hecMESH, fstrPARAM, & 43 fstrSOLID, fstrEIG, fstrHEAT, fstrDYNAMIC, fstrCPL, fstrFREQ ) 44 use mMaterial 45 character(len=HECMW_FILENAME_LEN) :: cntl_filename, input_filename 46 type(hecmwST_local_mesh),target :: hecMESH 47 type(fstr_param),target :: fstrPARAM 48 type(fstr_solid),target :: fstrSOLID 49 type(fstr_eigen),target :: fstrEIG 50 type(fstr_heat),target :: fstrHEAT 51 type(fstr_dynamic),target :: fstrDYNAMIC 52 type(fstr_couple),target :: fstrCPL 53 type(fstr_freqanalysis), target :: fstrFREQ 54 55 integer(kind=kint) :: ctrl, ctrl_list(20), ictrl 56 type(fstr_param_pack) :: P 57 58 integer, parameter :: MAXOUTFILE = 10 59 double precision, parameter :: dpi = 3.14159265358979323846D0 60 61 external fstr_ctrl_get_c_h_name 62 integer(kind=kint) :: fstr_ctrl_get_c_h_name 63 64 integer(kind=kint) :: version, resul, visual, femap, n_totlyr 65 integer(kind=kint) :: rcode, n, i, j, cid, nout, nin, ierror 66 character(len=HECMW_NAME_LEN) :: header_name, fname(MAXOUTFILE) 67 real(kind=kreal) :: ee, pp, rho, alpha, thick, alpha_over_mu 68 real(kind=kreal) :: beam_radius, & 69 beam_angle1, beam_angle2, beam_angle3,& 70 beam_angle4, beam_angle5, beam_angle6 71 logical :: isOK 72 type(t_output_ctrl) :: outctrl 73 type(tshellmat),pointer :: shmat(:) 74 character(len=HECMW_FILENAME_LEN) :: logfileNAME, mName, mName2 75 76 ! counters 77 integer(kind=kint) :: c_solution, c_solver, c_step, c_write, c_echo 78 integer(kind=kint) :: c_static, c_boundary, c_cload, c_dload, c_temperature, c_reftemp, c_spring 79 integer(kind=kint) :: c_heat, c_fixtemp, c_cflux, c_dflux, c_sflux, c_film, c_sfilm, c_radiate, c_sradiate 80 integer(kind=kint) :: c_eigen, c_contact 81 integer(kind=kint) :: c_dynamic, c_velocity, c_acceleration 82 integer(kind=kint) :: c_fload, c_eigenread 83 integer(kind=kint) :: c_couple, c_material 84 integer(kind=kint) :: c_mpc, c_weldline, c_initial 85 integer(kind=kint) :: c_istep, c_localcoord, c_section 86 integer(kind=kint) :: c_elemopt, c_aincparam, c_timepoints 87 integer(kind=kint) :: c_output, islog 88 integer(kind=kint) :: k 89 integer(kind=kint) :: cache = 1 90 91 write( logfileNAME, '(i5,''.log'')' ) myrank 92 93 ! packaging 94 P%MESH => hecMESH 95 P%PARAM => fstrPARAM 96 P%SOLID => fstrSOLID 97 P%EIGEN => fstrEIG 98 P%HEAT => fstrHEAT 99 P%DYN => fstrDYNAMIC 100 P%CPL => fstrCPL 101 P%FREQ => fstrFREQ 102 103 fstrPARAM%contact_algo = kcaALagrange 104 105 c_solution = 0; c_solver = 0; c_step = 0; c_output = 0; c_echo = 0; 106 c_static = 0; c_boundary = 0; c_cload = 0; c_dload = 0; c_temperature = 0; c_reftemp = 0; c_spring = 0; 107 c_heat = 0; c_fixtemp = 0; c_cflux = 0; c_dflux = 0; c_sflux = 0 108 c_film = 0; c_sfilm = 0; c_radiate= 0; c_sradiate = 0 109 c_eigen = 0; c_contact = 0 110 c_dynamic = 0; c_velocity = 0; c_acceleration = 0 111 c_couple = 0; c_material = 0; c_section =0 112 c_mpc = 0; c_weldline = 0; c_initial = 0 113 c_istep = 0; c_localcoord = 0 114 c_fload = 0; c_eigenread = 0 115 c_elemopt = 0; 116 c_aincparam= 0; c_timepoints = 0 117 118 ctrl_list = 0 119 ictrl = 1 120 ctrl = fstr_ctrl_open( cntl_filename ) 121 if( ctrl < 0 ) then 122 write(*,*) '### Error: Cannot open FSTR control file : ', cntl_filename 123 write(ILOG,*) '### Error: Cannot open FSTR control file : ', cntl_filename 124 stop 125 end if 126 127 version =0 128 do 129 rcode = fstr_ctrl_get_c_h_name( ctrl, header_name, HECMW_NAME_LEN ) 130 if( header_name == '!VERSION' ) then 131 rcode = fstr_ctrl_get_data_array_ex( ctrl, 'i ', version ) 132 else if( header_name == '!SOLUTION' ) then 133 c_solution = c_solution + 1 134 call fstr_setup_SOLUTION( ctrl, c_solution, P ) 135 else if( header_name == '!SOLVER' ) then 136 c_solver = c_solver + 1 137 call fstr_setup_SOLVER( ctrl, c_solver, P ) 138 else if( header_name == '!ISTEP' ) then 139 c_istep = c_istep + 1 140 else if( header_name == '!STEP' ) then 141 if( version==0 ) then 142 c_step = c_step + 1 143 call fstr_setup_STEP( ctrl, c_step, P ) 144 else 145 c_istep = c_istep + 1 146 endif 147 else if( header_name == '!WRITE' ) then 148 call fstr_ctrl_get_output( ctrl, outctrl, islog, resul, visual, femap ) 149 if( visual==1 ) P%PARAM%fg_visual= 1 150 if( resul==1 ) P%PARAM%fg_result = 1 151 c_output = c_output+1 152 else if( header_name == '!ECHO' ) then 153 c_echo = c_echo + 1 154 call fstr_setup_ECHO( ctrl, c_echo, P ) 155 else if( header_name == '!RESTART' ) then 156 call fstr_setup_RESTART( ctrl, nout, P%PARAM%restart_version ) 157 fstrSOLID%restart_nout= nout 158 fstrDYNAMIC%restart_nout= nout 159 fstrHEAT%restart_nout= nout 160 else if( header_name == '!ORIENTATION' ) then 161 c_localcoord = c_localcoord + 1 162 else if( header_name == '!AUTOINC_PARAM' ) then 163 c_aincparam = c_aincparam + 1 164 else if( header_name == '!TIME_POINTS' ) then 165 c_timepoints = c_timepoints + 1 166 else if( header_name == '!OUTPUT_SSTYPE' ) then 167 call fstr_setup_OUTPUT_SSTYPE( ctrl, P ) 168 else if( header_name == '!INITIAL_CONDITION' ) then 169 c_initial = c_initial + 1 170 171 !--------------- for static ------------------------- 172 173 else if( header_name == '!STATIC' ) then 174 c_static = c_static + 1 175 call fstr_setup_STATIC( ctrl, c_static, P ) 176 else if( header_name == '!BOUNDARY' ) then 177 c_boundary = c_boundary + 1 178 call fstr_setup_BOUNDARY( ctrl, c_boundary, P ) 179 else if( header_name == '!CLOAD' ) then 180 c_cload = c_cload + 1 181 call fstr_setup_CLOAD( ctrl, c_cload, P ) 182 n = fstr_ctrl_get_data_line_n( ctrl ) 183 else if( header_name == '!DLOAD' ) then 184 c_dload = c_dload + 1 185 call fstr_setup_DLOAD( ctrl, c_dload, P ) 186 else if( header_name == '!CONTACT_ALGO' ) then 187 call fstr_setup_CONTACTALGO( ctrl, P ) 188 else if( header_name == '!CONTACT' ) then 189 n = fstr_ctrl_get_data_line_n( ctrl ) 190 c_contact = c_contact + n 191 else if( header_name == '!MATERIAL' ) then 192 c_material = c_material + 1 193 else if( header_name == '!TEMPERATURE' ) then 194 c_temperature = c_temperature + 1 195 call fstr_setup_TEMPERATURE( ctrl, c_temperature, P ) 196 else if( header_name == '!SPRING' ) then 197 c_spring = c_spring + 1 198 call fstr_setup_SPRING( ctrl, c_spring, P ) 199 else if( header_name == '!REFTEMP' ) then 200 c_reftemp = c_reftemp + 1 201 call fstr_setup_REFTEMP( ctrl, c_reftemp, P ) 202 203 !--------------- for heat ------------------------- 204 205 else if( header_name == '!HEAT' ) then 206 c_heat = c_heat + 1 207 else if( header_name == '!FIXTEMP' ) then 208 c_fixtemp = c_fixtemp + 1 209 call fstr_setup_FIXTEMP( ctrl, c_fixtemp, P ) 210 else if( header_name == '!CFLUX' ) then 211 c_cflux = c_cflux + 1 212 call fstr_setup_CFLUX( ctrl, c_cflux, P ) 213 else if( header_name == '!DFLUX' ) then 214 c_dflux = c_dflux + 1 215 call fstr_setup_DFLUX( ctrl, c_dflux, P ) 216 else if( header_name == '!SFLUX' ) then 217 c_sflux = c_sflux + 1 218 call fstr_setup_SFLUX( ctrl, c_sflux, P ) 219 else if( header_name == '!FILM' ) then 220 c_film = c_film + 1 221 call fstr_setup_FILM( ctrl, c_film, P ) 222 else if( header_name == '!SFILM' ) then 223 c_sfilm = c_sfilm + 1 224 call fstr_setup_SFILM( ctrl, c_sfilm, P ) 225 else if( header_name == '!RADIATE' ) then 226 c_radiate = c_radiate + 1 227 call fstr_setup_RADIATE( ctrl, c_radiate, P ) 228 else if( header_name == '!SRADIATE' ) then 229 c_sradiate = c_sradiate + 1 230 call fstr_setup_SRADIATE( ctrl, c_sradiate, P ) 231 else if( header_name == '!WELD_LINE' ) then 232 c_weldline = c_weldline + 1 233 234 !--------------- for eigen ------------------------- 235 236 else if( header_name == '!EIGEN' ) then 237 c_eigen = c_eigen + 1 238 call fstr_setup_EIGEN( ctrl, c_eigen, P ) 239 240 !--------------- for dynamic ------------------------- 241 242 else if( header_name == '!DYNAMIC' ) then 243 c_dynamic = c_dynamic + 1 244 call fstr_setup_DYNAMIC( ctrl, c_eigen, P ) 245 else if( header_name == '!VELOCITY' ) then 246 c_velocity = c_velocity + 1 247 call fstr_setup_VELOCITY( ctrl, c_eigen, P ) 248 else if( header_name == '!ACCELERATION' ) then 249 c_acceleration = c_acceleration + 1 250 call fstr_setup_ACCELERATION( ctrl, c_eigen, P ) 251 else if( header_name == '!FLOAD' ) then 252 c_fload = c_fload + 1 253 call fstr_setup_FLOAD( ctrl , c_fload, P ) 254 else if( header_name == '!EIGENREAD' ) then 255 c_eigenread = c_eigenread + 1 256 call fstr_setup_eigenread( ctrl, c_eigenread, P ) 257 258 !--------------- for couple ------------------------- 259 260 else if( header_name == '!COUPLE' ) then 261 c_couple = c_couple + 1 262 call fstr_setup_COUPLE( ctrl, c_couple, P ) 263 264 !--------------- for mpc ------------------------- 265 266 else if( header_name == '!MPC' ) then 267 c_mpc = c_mpc + 1 268 call fstr_setup_MPC( ctrl, c_mpc, P ) 269 270 !--------------------- for input ------------------------- 271 272 else if( header_name == '!INCLUDE' ) then 273 ctrl_list(ictrl) = ctrl 274 input_filename = "" 275 ierror = fstr_ctrl_get_param_ex( ctrl, 'INPUT ', '# ', 0, 'S', input_filename ) 276 ctrl = fstr_ctrl_open( input_filename ) 277 if( ctrl < 0 ) then 278 write(*,*) '### Error: Cannot open FSTR control file : ', input_filename 279 write(ILOG,*) '### Error: Cannot open FSTR control file : ', input_filename 280 stop 281 end if 282 ictrl = ictrl + 1 283 cycle 284 285 !--------------------- END ------------------------- 286 287 else if( header_name == '!END' ) then 288 exit 289 end if 290 291 ! next 292 if( fstr_ctrl_seek_next_header(ctrl) == 0 )then 293 if( ictrl == 1 )then 294 exit 295 else 296 ierror= fstr_ctrl_close( ctrl ) 297 ictrl = ictrl - 1 298 ctrl = ctrl_list(ictrl) 299 if( fstr_ctrl_seek_next_header(ctrl) == 0 ) exit 300 endif 301 endif 302 end do 303 304 ! ----- 305 if( c_contact>0 ) then 306 allocate( fstrSOLID%contacts( c_contact ) ) 307 ! convert SURF_SURF contact to NODE_SURF contact 308 call fstr_convert_contact_type( P%MESH ) 309 endif 310 if( c_weldline>0 ) allocate( fstrHEAT%weldline( c_weldline ) ) 311 if( c_initial>0 ) allocate( g_InitialCnd( c_initial ) ) 312 if( c_istep>0 ) allocate( fstrSOLID%step_ctrl( c_istep ) ) 313 if( c_localcoord>0 ) allocate( g_LocalCoordSys(c_localcoord) ) 314 allocate( fstrPARAM%ainc(0:c_aincparam) ) 315 do i=0,c_aincparam 316 call init_AincParam( fstrPARAM%ainc(i) ) 317 end do 318 if( c_timepoints>0 ) allocate( fstrPARAM%timepoints(c_timepoints) ) 319 320 P%SOLID%is_33shell = 0 321 P%SOLID%is_33beam = 0 322 323 do i=1,hecMESH%n_elem_type 324 n = hecMESH%elem_type_item(i) 325 if (n == 781 .or. n == 761)then 326 P%SOLID%is_33shell = 1 327 elseif (n == 641)then 328 P%SOLID%is_33beam = 1 329 endif 330 enddo 331 332 n = c_material 333 if( hecMESH%material%n_mat>n ) n= hecMESH%material%n_mat 334 if( n==0 ) stop "material property not defined!" 335 allocate( fstrSOLID%materials( n ) ) 336 do i = 1, n 337 call initMaterial(fstrSOLID%materials(i)) 338 enddo 339 if( hecMESH%section%n_sect >0 ) then 340 do i=1,hecMESH%section%n_sect 341 if( hecMESH%section%sect_type(i) == 4 ) cycle 342 cid = hecMESH%section%sect_mat_ID_item(i) 343 if( cid>n ) stop "Error in material property definition!" 344 if( fstrPARAM%nlgeom .or. fstrPARAM%solution_type==kstSTATICEIGEN ) & 345 fstrSOLID%materials(cid)%nlgeom_flag = 1 346 nullify(shmat) 347 call fstr_get_prop(hecMESH,shmat,i,ee,pp,rho,alpha,thick,& 348 n_totlyr,alpha_over_mu, & 349 beam_radius,beam_angle1,beam_angle2,beam_angle3, & 350 beam_angle4,beam_angle5,beam_angle6) 351 fstrSOLID%materials(cid)%name = hecMESH%material%mat_name(cid) 352 fstrSOLID%materials(cid)%variables(M_YOUNGS)=ee 353 fstrSOLID%materials(cid)%variables(M_POISSON)=pp 354 fstrSOLID%materials(cid)%variables(M_DENSITY)=rho 355 fstrSOLID%materials(cid)%variables(M_EXAPNSION)=alpha 356 fstrSOLID%materials(cid)%variables(M_THICK)=thick 357 fstrSOLID%materials(cid)%variables(M_ALPHA_OVER_MU)= alpha_over_mu 358 fstrSOLID%materials(cid)%variables(M_BEAM_RADIUS)=beam_radius 359 fstrSOLID%materials(cid)%variables(M_BEAM_ANGLE1)=beam_angle1 360 fstrSOLID%materials(cid)%variables(M_BEAM_ANGLE2)=beam_angle2 361 fstrSOLID%materials(cid)%variables(M_BEAM_ANGLE3)=beam_angle3 362 fstrSOLID%materials(cid)%variables(M_BEAM_ANGLE4)=beam_angle4 363 fstrSOLID%materials(cid)%variables(M_BEAM_ANGLE5)=beam_angle5 364 fstrSOLID%materials(cid)%variables(M_BEAM_ANGLE6)=beam_angle6 365 fstrSOLID%materials(cid)%mtype = ELASTIC 366 fstrSOLID%materials(cid)%totallyr = n_totlyr 367 fstrSOLID%materials(cid)%shell_var => shmat 368 enddo 369 endif 370 371 ! for section control 372 allocate( fstrSOLID%sections(hecMESH%section%n_sect) ) 373 do i=1,hecMESH%section%n_sect 374 ! set default 361 element formulation 375 if( p%PARAM%solution_type==kstSTATIC .or. p%PARAM%solution_type==kstDYNAMIC ) then 376 if( p%PARAM%nlgeom ) then 377 fstrSOLID%sections(i)%elemopt361 = kel361FBAR 378 else 379 fstrSOLID%sections(i)%elemopt361 = kel361IC 380 end if 381 else if( p%PARAM%solution_type==kstEIGEN ) then 382 fstrSOLID%sections(i)%elemopt361 = kel361IC 383 else if( p%PARAM%solution_type==kstSTATICEIGEN ) then 384 fstrSOLID%sections(i)%elemopt361 = kel361FBAR 385 else 386 fstrSOLID%sections(i)%elemopt361 = kel361FI 387 end if 388 enddo 389 390 allocate( fstrSOLID%output_ctrl( 4 ) ) 391 call fstr_init_outctrl(fstrSOLID%output_ctrl(1)) 392 fstrSOLID%output_ctrl( 1 )%filename = trim(logfileNAME) 393 fstrSOLID%output_ctrl( 1 )%filenum = ILOG 394 call fstr_init_outctrl(fstrSOLID%output_ctrl(2)) 395 call fstr_init_outctrl(fstrSOLID%output_ctrl(3)) 396 call fstr_init_outctrl(fstrSOLID%output_ctrl(4)) 397 398 ! ----- 399 rcode = fstr_ctrl_rewind( ctrl ) 400 401 c_istep = 0 402 c_heat = 0 403 c_material = 0 404 c_output = 0 405 c_contact = 0 406 c_initial = 0 407 c_localcoord = 0 408 c_section = 0 409 fstrHEAT%WL_tot = 0 410 c_elemopt = 0 411 c_aincparam = 0 412 c_timepoints = 0 413 fstrSOLID%elemopt361 = 0 414 fstrSOLID%AutoINC_stat = 0 415 fstrSOLID%CutBack_stat = 0 416 fstrSOLID%NRstat_i(:) = 0 417 fstrSOLID%NRstat_r(:) = 0.d0 418 ictrl = 1 419 do 420 rcode = fstr_ctrl_get_c_h_name( ctrl, header_name, HECMW_NAME_LEN ) 421 422 if( header_name == '!ORIENTATION' ) then 423 c_localcoord = c_localcoord + 1 424 if( fstr_setup_ORIENTATION( ctrl, hecMESH, c_localcoord, g_LocalCoordSys(c_localcoord) )/=0 ) then 425 write(*,*) '### Error: Fail in read in ORIENTATION definition : ', c_localcoord 426 write(ILOG,*) '### Error: Fail in read in ORIENTATION definition : ', c_localcoord 427 stop 428 endif 429 430 ! ----- CONTACT condtion setting 431 elseif( header_name == '!CONTACT' ) then 432 n = fstr_ctrl_get_data_line_n( ctrl ) 433 if( .not. fstr_ctrl_get_CONTACT( ctrl, n, fstrSOLID%contacts(c_contact+1:c_contact+n) & 434 ,ee, pp, rho, alpha, P%PARAM%contact_algo ) ) then 435 write(*,*) '### Error: Fail in read in contact condition : ', c_contact 436 write(ILOG,*) '### Error: Fail in read in contact condition : ', c_contact 437 stop 438 endif 439 ! initialize contact condition 440 if( ee>0.d0 ) cdotp = ee 441 if( pp>0.d0 ) mut = pp 442 if( rho>0.d0 ) cgn = rho 443 if( alpha>0.d0 ) cgt = alpha 444 do i=1,n 445 if( .not. fstr_contact_check( fstrSOLID%contacts(c_contact+i), P%MESH ) ) then 446 write(*,*) '### Error: Inconsistence in contact and surface definition : ' , i+c_contact 447 write(ILOG,*) '### Error: Inconsistence in contact and surface definition : ', i+c_contact 448 stop 449 else 450 if(paraContactFlag) then 451 isOK = fstr_contact_init( fstrSOLID%contacts(c_contact+i), P%MESH, myrank) 452 else 453 isOK = fstr_contact_init( fstrSOLID%contacts(c_contact+i), P%MESH) 454 endif 455 ! call fstr_write_contact( 6, fstrSOLID%contacts(c_contact+i) ) 456 endif 457 enddo 458 c_contact = c_contact+n 459 460 else if( header_name == '!ISTEP' ) then 461 c_istep = c_istep+1 462 if( .not. fstr_ctrl_get_ISTEP( ctrl, hecMESH, fstrSOLID%step_ctrl(c_istep), mName, mName2 ) ) then 463 write(*,*) '### Error: Fail in read in step definition : ' , c_istep 464 write(ILOG,*) '### Error: Fail in read in step definition : ', c_istep 465 stop 466 endif 467 if( associated(fstrPARAM%timepoints) ) then 468 do i=1,size(fstrPARAM%timepoints) 469 if( fstr_streqr( fstrPARAM%timepoints(i)%name, mName ) ) then 470 fstrSOLID%step_ctrl(c_istep)%timepoint_id = i; exit 471 endif 472 enddo 473 endif 474 if( associated(fstrPARAM%ainc) ) then 475 do i=1,size(fstrPARAM%ainc) 476 if( fstr_streqr( fstrPARAM%ainc(i)%name, mName2 ) ) then 477 fstrSOLID%step_ctrl(c_istep)%AincParam_id = i; exit 478 endif 479 enddo 480 endif 481 else if( header_name == '!STEP' .and. version>=1 ) then 482 c_istep = c_istep+1 483 if( .not. fstr_ctrl_get_ISTEP( ctrl, hecMESH, fstrSOLID%step_ctrl(c_istep), mName, mName2 ) ) then 484 write(*,*) '### Error: Fail in read in step definition : ' , c_istep 485 write(ILOG,*) '### Error: Fail in read in step definition : ', c_istep 486 stop 487 endif 488 if( associated(fstrPARAM%timepoints) ) then 489 do i=1,size(fstrPARAM%timepoints) 490 if( fstr_streqr( fstrPARAM%timepoints(i)%name, mName ) ) then 491 fstrSOLID%step_ctrl(c_istep)%timepoint_id = i; exit 492 endif 493 enddo 494 endif 495 if( associated(fstrPARAM%ainc) ) then 496 do i=1,size(fstrPARAM%ainc)-1 497 if( fstr_streqr( fstrPARAM%ainc(i)%name, mName2 ) ) then 498 fstrSOLID%step_ctrl(c_istep)%AincParam_id = i; exit 499 endif 500 enddo 501 endif 502 503 else if( header_name == '!HEAT' ) then 504 c_heat = c_heat + 1 505 call fstr_setup_HEAT( ctrl, c_heat, P ) 506 507 else if( header_name == '!WELD_LINE' ) then 508 fstrHEAT%WL_tot = fstrHEAT%WL_tot+1 509 if( fstr_ctrl_get_WELDLINE( ctrl, hecMESH, HECMW_NAME_LEN, fstrHEAT%weldline(fstrHEAT%WL_tot) )/=0 ) then 510 write(*,*) '### Error: Fail in read in Weld Line definition : ' , fstrHEAT%WL_tot 511 write(ILOG,*) '### Error: Fail in read in Weld Line definition : ', fstrHEAT%WL_tot 512 stop 513 endif 514 515 else if( header_name == '!INITIAL_CONDITION' .or. header_name == '!INITIAL CONDITION' ) then 516 c_initial = c_initial+1 517 if( fstr_setup_INITIAL( ctrl, g_InitialCnd(c_initial), P%MESH )/=0 ) then 518 write(*,*) '### Error: Fail in read in INITIAL CONDITION definition : ' ,c_initial 519 write(ILOG,*) '### Error: Fail in read in INITIAL CONDITION definition : ', c_initial 520 stop 521 endif 522 523 else if( header_name == '!SECTION' ) then 524 c_section = c_section+1 525 if( fstr_ctrl_get_SECTION( ctrl, hecMESH, fstrSOLID%sections )/=0 ) then 526 write(*,*) '### Error: Fail in read in SECTION definition : ' , c_section 527 write(ILOG,*) '### Error: Fail in read in SECTION definition : ', c_section 528 stop 529 endif 530 531 else if( header_name == '!ELEMOPT' ) then 532 c_elemopt = c_elemopt+1 533 if( fstr_ctrl_get_ELEMOPT( ctrl, fstrSOLID%elemopt361 )/=0 ) then 534 write(*,*) '### Error: Fail in read in ELEMOPT definition : ' , c_elemopt 535 write(ILOG,*) '### Error: Fail in read in ELEMOPT definition : ', c_elemopt 536 stop 537 endif 538 539 !== following material proerties == 540 else if( header_name == '!MATERIAL' ) then 541 c_material = c_material+1 542 if( fstr_ctrl_get_MATERIAL( ctrl, mName )/=0 ) then 543 write(*,*) '### Error: Fail in read in material definition : ' , c_material 544 write(ILOG,*) '### Error: Fail in read in material definition : ', c_material 545 stop 546 endif 547 cid = 0 548 if(cache < hecMESH%material%n_mat) then 549 if(fstr_streqr( hecMESH%material%mat_name(cache), mName ))then 550 cid = cache 551 cache = cache + 1 552 endif 553 endif 554 if(cid == 0)then 555 do i=1,hecMESH%material%n_mat 556 if( fstr_streqr( hecMESH%material%mat_name(i), mName ) ) then 557 cid = i 558 cache = i + 1 559 exit 560 endif 561 enddo 562 endif 563 if(cid == 0)then 564 write(*,*) '### Error: Fail in read in material definition : ' , c_material 565 write(ILOG,*) '### Error: Fail in read in material definition : ', c_material 566 stop 567 endif 568 fstrSOLID%materials(cid)%name = mName 569 if(c_material>hecMESH%material%n_mat) call initMaterial( fstrSOLID%materials(cid) ) 570 571 else if( header_name == '!ELASTIC' ) then 572 if( c_material >0 ) then 573 if( fstr_ctrl_get_ELASTICITY( ctrl, & 574 fstrSOLID%materials(cid)%mtype, & 575 fstrSOLID%materials(cid)%nlgeom_flag, & 576 fstrSOLID%materials(cid)%variables, & 577 fstrSOLID%materials(cid)%dict)/=0 ) then 578 write(*,*) '### Error: Fail in read in elasticity definition : ' , cid 579 write(ILOG,*) '### Error: Fail in read in elasticity definition : ', cid 580 stop 581 endif 582 endif 583 else if( header_name == '!PLASTIC' ) then 584 if( cid >0 ) then 585 if( fstr_ctrl_get_PLASTICITY( ctrl, & 586 fstrSOLID%materials(cid)%mtype, & 587 fstrSOLID%materials(cid)%nlgeom_flag, & 588 fstrSOLID%materials(cid)%variables, & 589 fstrSOLID%materials(cid)%table, & 590 fstrSOLID%materials(cid)%dict)/=0 ) then 591 write(*,*) '### Error: Fail in read in plasticity definition : ' , cid 592 write(ILOG,*) '### Error: Fail in read in plasticity definition : ', cid 593 stop 594 endif 595 endif 596 else if( header_name == '!HYPERELASTIC' ) then 597 if( cid >0 ) then 598 if( fstr_ctrl_get_HYPERELASTIC( ctrl, & 599 fstrSOLID%materials(cid)%mtype, & 600 fstrSOLID%materials(cid)%nlgeom_flag, & 601 fstrSOLID%materials(cid)%variables )/=0 ) then 602 write(*,*) '### Error: Fail in read in elasticity definition : ' , cid 603 write(ILOG,*) '### Error: Fail in read in elasticity definition : ', cid 604 stop 605 endif 606 endif 607 else if( header_name == '!VISCOELASTIC' ) then 608 if( cid >0 ) then 609 if( fstr_ctrl_get_VISCOELASTICITY( ctrl, & 610 fstrSOLID%materials(cid)%mtype, & 611 fstrSOLID%materials(cid)%nlgeom_flag, & 612 fstrSOLID%materials(cid)%dict)/=0 ) then 613 write(*,*) '### Error: Fail in read in plasticity definition : ' , cid 614 write(ILOG,*) '### Error: Fail in read in plasticity definition : ', cid 615 stop 616 endif 617 endif 618 else if( header_name == '!TRS' ) then 619 if( cid >0 ) then 620 if( fstrSOLID%materials(cid)%mtype/=VISCOELASTIC ) then 621 write(*,*) '### WARNING: TRS can only be defined for viscoelastic material! It is ignored! ' 622 write(ILOG,*) '### WARNING: TRS can only be defined for viscoelastic material! It is ignored! ' 623 else 624 if( fstr_ctrl_get_TRS( ctrl, fstrSOLID%materials(cid)%mtype, fstrSOLID%materials(cid)%variables)/=0 ) then 625 write(*,*) '### Error: Fail in read in TRS definition : ' , cid 626 write(ILOG,*) '### Error: Fail in read in TRS definition : ', cid 627 stop 628 endif 629 endif 630 endif 631 else if( header_name == '!CREEP' ) then 632 if( cid >0 ) then 633 if( fstr_ctrl_get_VISCOPLASTICITY( ctrl, & 634 fstrSOLID%materials(cid)%mtype, & 635 fstrSOLID%materials(cid)%nlgeom_flag, & 636 fstrSOLID%materials(cid)%dict)/=0 ) then 637 write(*,*) '### Error: Fail in read in plasticity definition : ' , cid 638 write(ILOG,*) '### Error: Fail in read in plasticity definition : ', cid 639 stop 640 endif 641 endif 642 else if( header_name == '!DENSITY' ) then 643 if( cid >0 ) then 644 if( fstr_ctrl_get_DENSITY( ctrl, fstrSOLID%materials(cid)%variables )/=0 ) then 645 write(*,*) '### Error: Fail in read in density definition : ' , cid 646 write(ILOG,*) '### Error: Fail in read in density definition : ', cid 647 stop 648 endif 649 endif 650 else if( header_name == '!EXPANSION_COEF' .or. header_name == '!EXPANSION_COEFF' .or. & 651 header_name == '!EXPANSION') then 652 if( cid >0 ) then 653 if( fstr_ctrl_get_EXPANSION_COEFF( ctrl, fstrSOLID%materials(cid)%variables, & 654 fstrSOLID%materials(cid)%dict)/=0 ) then 655 write(*,*) '### Error: Fail in read in expansion coefficient definition : ' , cid 656 write(ILOG,*) '### Error: Fail in read in expansion coefficient definition : ', cid 657 stop 658 endif 659 endif 660 else if( header_name == '!FLUID' ) then 661 if( c_material >0 ) then 662 if( fstr_ctrl_get_FLUID( ctrl, & 663 fstrSOLID%materials(cid)%mtype, & 664 fstrSOLID%materials(cid)%nlgeom_flag, & 665 fstrSOLID%materials(cid)%variables, & 666 fstrSOLID%materials(cid)%dict)/=0 ) then 667 write(*,*) '### Error: Fail in read in fluid definition : ' , cid 668 write(ILOG,*) '### Error: Fail in read in fluid definition : ', cid 669 stop 670 endif 671 endif 672 else if( header_name == '!USER_MATERIAL' ) then 673 if( cid >0 ) then 674 if( fstr_ctrl_get_USERMATERIAL( ctrl, fstrSOLID%materials(cid)%mtype, & 675 fstrSOLID%materials(cid)%nlgeom_flag, fstrSOLID%materials(cid)%nfstatus, & 676 fstrSOLID%materials(cid)%variables(101:) )/=0 ) then 677 write(*,*) '### Error: Fail in read in user defined material : ' , cid 678 write(ILOG,*) '### Error: Fail in read in user defined material : ', cid 679 stop 680 endif 681 endif 682 683 684 ! == Following output control == 685 else if( header_name == '!WRITE' ) then 686 call fstr_ctrl_get_output( ctrl, outctrl, islog, resul, visual, femap ) 687 if( islog == 1 ) then 688 c_output=1 689 outctrl%filename = trim(logfileNAME) 690 outctrl%filenum = ILOG 691 call fstr_copy_outctrl(fstrSOLID%output_ctrl(c_output), outctrl) 692 endif 693 if( femap == 1 ) then 694 c_output=2 695 write( outctrl%filename, *) 'utable.',myrank,".dat" 696 outctrl%filenum = IUTB 697 call fstr_copy_outctrl(fstrSOLID%output_ctrl(c_output), outctrl) 698 open( unit=outctrl%filenum, file=outctrl%filename, status='REPLACE' ) 699 endif 700 if( resul == 1 ) then 701 c_output=3 702 call fstr_copy_outctrl(fstrSOLID%output_ctrl(c_output), outctrl) 703 endif 704 if( visual == 1 ) then 705 c_output=4 706 call fstr_copy_outctrl(fstrSOLID%output_ctrl(c_output), outctrl) 707 endif 708 709 else if( header_name == '!OUTPUT_RES' ) then 710 c_output=3 711 if( .not. fstr_ctrl_get_outitem( ctrl, hecMESH, fstrSOLID%output_ctrl(c_output)%outinfo ) ) then 712 write(*,*) '### Error: Fail in read in node output definition : ' , c_output 713 write(ILOG,*) '### Error: Fail in read in node output definition : ', c_output 714 stop 715 endif 716 if( fstrSOLID%output_ctrl(c_output)%outinfo%grp_id_name /= 'ALL' ) then 717 c_output=2 718 do i=1,hecMESH%node_group%n_grp 719 if( fstrSOLID%output_ctrl(c_output)%outinfo%grp_id_name == hecMESH%node_group%grp_name(i) ) then 720 fstrSOLID%output_ctrl(c_output)%outinfo%grp_id = i; exit 721 endif 722 enddo 723 endif 724 else if( header_name == '!OUTPUT_VIS' ) then 725 c_output=4 726 if( .not. fstr_ctrl_get_outitem( ctrl, hecMESH, fstrSOLID%output_ctrl(c_output)%outinfo ) ) then 727 write(*,*) '### Error: Fail in read in element output definition : ' , c_output 728 write(ILOG,*) '### Error: Fail in read in element output definition : ', c_output 729 stop 730 endif 731 if( fstrSOLID%output_ctrl(c_output)%outinfo%grp_id_name /= 'ALL' ) then 732 c_output=2 733 do i=1,hecMESH%node_group%n_grp 734 if( fstrSOLID%output_ctrl(c_output)%outinfo%grp_id_name == hecMESH%node_group%grp_name(i) ) then 735 fstrSOLID%output_ctrl(c_output)%outinfo%grp_id = i; exit 736 endif 737 enddo 738 endif 739 else if( header_name == '!AUTOINC_PARAM' ) then 740 c_aincparam = c_aincparam + 1 741 if( fstr_get_AUTOINC( ctrl, fstrPARAM%ainc(c_aincparam) ) /=0 ) then 742 write(*,*) '### Error: Fail in read in AUTOINC_PARAM definition : ' , c_aincparam 743 write(ILOG,*) '### Error: Fail in read in AUTOINC_PARAM definition : ', c_aincparam 744 stop 745 endif 746 else if( header_name == '!TIME_POINTS' ) then 747 c_timepoints = c_timepoints + 1 748 if( fstr_ctrl_get_TIMEPOINTS( ctrl, fstrPARAM%timepoints(c_timepoints) )/=0 ) then 749 write(*,*) '### Error: Fail in read in TIME_POINTS definition : ' , c_timepoints 750 write(ILOG,*) '### Error: Fail in read in TIME_POINTS definition : ', c_timepoints 751 stop 752 endif 753 else if( header_name == '!ULOAD' ) then 754 if( fstr_ctrl_get_USERLOAD( ctrl )/=0 ) then 755 write(*,*) '### Error: Fail in read in ULOAD definition : ' 756 write(ILOG,*) '### Error: Fail in read in ULOAD definition : ' 757 stop 758 endif 759 760 else if( header_name == '!INCLUDE' ) then 761 ctrl_list(ictrl) = ctrl 762 input_filename = "" 763 ierror = fstr_ctrl_get_param_ex( ctrl, 'INPUT ', '# ', 0, 'S', input_filename ) 764 ctrl = fstr_ctrl_open( input_filename ) 765 if( ctrl < 0 ) then 766 write(*,*) '### Error: Cannot open FSTR control file : ', input_filename 767 write(ILOG,*) '### Error: Cannot open FSTR control file : ', input_filename 768 stop 769 end if 770 ictrl = ictrl + 1 771 cycle 772 773 else if( header_name == '!END' ) then 774 exit 775 endif 776 777 ! next 778 if( fstr_ctrl_seek_next_header(ctrl) == 0 )then 779 if( ictrl == 1 )then 780 exit 781 else 782 ierror= fstr_ctrl_close( ctrl ) 783 ictrl = ictrl - 1 784 ctrl = ctrl_list(ictrl) 785 if( fstr_ctrl_seek_next_header(ctrl) == 0 ) exit 786 endif 787 endif 788 789 end do 790 791 ! ----- material type judgement. in case of infinitive analysis, nlgeom_flag=0 792 if( .not. P%PARAM%nlgeom ) then 793 do i=1, c_material 794 fstrSOLID%materials(i)%nlgeom_flag = 0 795 enddo 796 endif 797 798 if( fstrSOLID%TEMP_ngrp_tot > 0 .or. fstrSOLID%TEMP_irres > 0 ) then 799 allocate ( fstrSOLID%temperature( hecMESH%n_node ) ,stat=ierror ) 800 if( ierror /= 0 ) then 801 write(idbg,*) 'stop due to allocation error <FSTR_SOLID, TEMPERATURE>' 802 write(idbg,*) ' rank = ', myrank,' ierror = ',ierror 803 call flush(idbg) 804 call hecmw_abort( hecmw_comm_get_comm()) 805 end if 806 fstrSOLID%temperature = REF_TEMP 807 allocate ( fstrSOLID%last_temp( hecMESH%n_node ) ,stat=ierror ) 808 if( ierror /= 0 ) then 809 write(idbg,*) 'stop due to allocation error <FSTR_SOLID, LAST_TEMP>' 810 write(idbg,*) ' rank = ', myrank,' ierror = ',ierror 811 call flush(idbg) 812 call hecmw_abort( hecmw_comm_get_comm()) 813 end if 814 fstrSOLID%last_temp = 0.d0 815 allocate ( fstrSOLID%temp_bak( hecMESH%n_node ) ,stat=ierror ) 816 if( ierror /= 0 ) then 817 write(idbg,*) 'stop due to allocation error <FSTR_SOLID, TEMP_BAK>' 818 write(idbg,*) ' rank = ', myrank,' ierror = ',ierror 819 call flush(idbg) 820 call hecmw_abort( hecmw_comm_get_comm()) 821 end if 822 fstrSOLID%temp_bak = 0.d0 823 endif 824 825 if( associated(fstrSOLID%step_ctrl) ) then 826 fstrSOLID%nstep_tot = size(fstrSOLID%step_ctrl) 827 call setup_stepInfo_starttime( fstrSOLID%step_ctrl ) 828 !call fstr_print_steps( 6, fstrSOLID%step_ctrl ) 829 else 830 if( p%PARAM%solution_type==kstSTATIC .and. P%PARAM%nlgeom ) then 831 write( *,* ) " ERROR: STEP not defined!" 832 write( idbg,* ) "ERROR: STEP not defined!" 833 call flush(idbg) 834 call hecmw_abort( hecmw_comm_get_comm()) 835 endif 836 837 if( myrank==0 ) write(*,*)"Step control not defined! Using default step=1" 838 fstrSOLID%nstep_tot = 1 839 allocate( fstrSOLID%step_ctrl(1) ) 840 call init_stepInfo( fstrSOLID%step_ctrl(1) ) 841 n = fstrSOLID%BOUNDARY_ngrp_tot 842 if( n>0 ) allocate( fstrSOLID%step_ctrl(1)%Boundary(n) ) 843 do i = 1, n 844 fstrSOLID%step_ctrl(1)%Boundary(i) = fstrSOLID%BOUNDARY_ngrp_GRPID(i) 845 enddo 846 n = fstrSOLID%CLOAD_ngrp_tot + fstrSOLID%DLOAD_ngrp_tot + fstrSOLID%TEMP_ngrp_tot + fstrSOLID%SPRING_ngrp_tot 847 if( n>0 ) allocate( fstrSOLID%step_ctrl(1)%Load(n) ) 848 n = 0 849 do i = 1, fstrSOLID%CLOAD_ngrp_tot 850 n = n + 1 851 fstrSOLID%step_ctrl(1)%Load(n) = fstrSOLID%CLOAD_ngrp_GRPID(i) 852 enddo 853 do i = 1, fstrSOLID%DLOAD_ngrp_tot 854 n = n + 1 855 fstrSOLID%step_ctrl(1)%Load(n) = fstrSOLID%DLOAD_ngrp_GRPID(i) 856 enddo 857 do i = 1, fstrSOLID%TEMP_ngrp_tot 858 n = n + 1 859 fstrSOLID%step_ctrl(1)%Load(n) = fstrSOLID%TEMP_ngrp_GRPID(i) 860 enddo 861 do i = 1, fstrSOLID%SPRING_ngrp_tot 862 n = n + 1 863 fstrSOLID%step_ctrl(1)%Load(n) = fstrSOLID%SPRING_ngrp_GRPID(i) 864 enddo 865 endif 866 867 if( p%PARAM%solution_type /= kstHEAT) call fstr_element_init( hecMESH, fstrSOLID ) 868 if( p%PARAM%solution_type==kstSTATIC .or. p%PARAM%solution_type==kstDYNAMIC .or. & 869 p%PARAM%solution_type==kstEIGEN .or. p%PARAM%solution_type==kstSTATICEIGEN ) & 870 call fstr_solid_alloc( hecMESH, fstrSOLID ) 871 872 if( p%PARAM%solution_type == kstHEAT) then 873 p%PARAM%fg_irres = fstrSOLID%output_ctrl(3)%freqency 874 p%PARAM%fg_iwres = fstrSOLID%output_ctrl(4)%freqency 875 endif 876 877 n_totlyr = 1 878 do i=1,hecMESH%section%n_sect 879 cid = hecMESH%section%sect_mat_ID_item(i) 880 n = fstrSOLID%materials(cid)%totallyr 881 if (n > n_totlyr)then 882 n_totlyr = n 883 endif 884 enddo 885 P%SOLID%max_lyr = n_totlyr 886 887 call fstr_setup_post( ctrl, P ) 888 rcode = fstr_ctrl_close( ctrl ) 889 890 end subroutine fstr_setup 891 892 893 !> Initializer of structure fstr_solid 894 subroutine fstr_solid_init( hecMESH, fstrSOLID ) 895 use m_fstr 896 type(hecmwST_local_mesh),target :: hecMESH 897 type(fstr_solid) :: fstrSOLID 898 899 integer :: ndof, ntotal, ierror, ic_type 900 901 fstrSOLID%file_type = kbcfFSTR 902 903 fstrSOLID%BOUNDARY_ngrp_tot = 0 904 fstrSOLID%BOUNDARY_ngrp_rot = 0 905 fstrSOLID%CLOAD_ngrp_tot = 0 906 fstrSOLID%CLOAD_ngrp_rot = 0 907 fstrSOLID%DLOAD_ngrp_tot = 0 908 fstrSOLID%DLOAD_follow = 1 909 fstrSOLID%TEMP_ngrp_tot = 0 910 fstrSOLID%SPRING_ngrp_tot = 0 911 fstrSOLID%TEMP_irres = 0 912 fstrSOLID%TEMP_tstep = 1 913 fstrSOLID%TEMP_interval = 1 914 fstrSOLID%TEMP_rtype = 1 915 fstrSOLID%TEMP_factor = 1.d0 916 fstrSOLID%VELOCITY_ngrp_tot = 0 917 fstrSOLID%ACCELERATION_ngrp_tot = 0 918 fstrSOLID%COUPLE_ngrp_tot = 0 919 920 fstrSOLID%restart_nout= 0 921 922 end subroutine fstr_solid_init 923 924 !> Initializer of structure fstr_solid 925 subroutine fstr_solid_alloc( hecMESH, fstrSOLID ) 926 use m_fstr 927 type(hecmwST_local_mesh),target :: hecMESH 928 type(fstr_solid) :: fstrSOLID 929 930 integer :: ndof, ntotal, ierror, ic_type 931 932 ndof=hecMESH%n_dof 933 ntotal=ndof*hecMESH%n_node 934 935 allocate ( fstrSOLID%GL( ntotal ) ,stat=ierror ) 936 if( ierror /= 0 ) then 937 write(idbg,*) 'stop due to allocation error <FSTR_SOLID, GL>' 938 write(idbg,*) ' rank = ', hecMESH%my_rank,' ierror = ',ierror 939 call flush(idbg) 940 call hecmw_abort( hecmw_comm_get_comm()) 941 end if 942 allocate ( fstrSOLID%EFORCE( ntotal ) ,stat=ierror ) 943 if( ierror /= 0 ) then 944 write(idbg,*) 'stop due to allocation error <FSTR_SOLID, EFORCE>' 945 write(idbg,*) ' rank = ', hecMESH%my_rank,' ierror = ',ierror 946 call flush(idbg) 947 call hecmw_abort( hecmw_comm_get_comm()) 948 end if 949 ! allocate ( fstrSOLID%TOTAL_DISP( ntotal ) ,STAT=ierror ) 950 ! if( ierror /= 0 ) then 951 ! write(idbg,*) 'stop due to allocation error <FSTR_SOLID, TOTAL_DISP>' 952 ! write(idbg,*) ' rank = ', hecMESH%my_rank,' ierror = ',ierror 953 ! call flush(idbg) 954 ! call hecmw_abort( hecmw_comm_get_comm()) 955 ! end if 956 allocate ( fstrSOLID%unode( ntotal ) ,stat=ierror ) 957 if( ierror /= 0 ) then 958 write(idbg,*) 'stop due to allocation error <FSTR_SOLID, unode>' 959 write(idbg,*) ' rank = ', hecMESH%my_rank,' ierror = ',ierror 960 call flush(idbg) 961 call hecmw_abort( hecmw_comm_get_comm()) 962 end if 963 allocate ( fstrSOLID%dunode( ntotal ) ,stat=ierror ) 964 if( ierror /= 0 ) then 965 write(idbg,*) 'stop due to allocation error <FSTR_SOLID, dunode>' 966 write(idbg,*) ' rank = ', hecMESH%my_rank,' ierror = ',ierror 967 call flush(idbg) 968 call hecmw_abort( hecmw_comm_get_comm()) 969 end if 970 allocate ( fstrSOLID%ddunode( ntotal ) ,stat=ierror ) 971 if( ierror /= 0 ) then 972 write(idbg,*) 'stop due to allocation error <FSTR_SOLID, ddunode>' 973 write(idbg,*) ' rank = ', hecMESH%my_rank,' ierror = ',ierror 974 call flush(idbg) 975 call hecmw_abort( hecmw_comm_get_comm()) 976 end if 977 allocate ( fstrSOLID%QFORCE( ntotal ) ,stat=ierror ) 978 if( ierror /= 0 ) then 979 write(idbg,*) 'stop due to allocation error <FSTR_SOLID, QFORCE>' 980 write(idbg,*) ' rank = ', hecMESH%my_rank,' ierror = ',ierror 981 call flush(idbg) 982 call hecmw_abort( hecmw_comm_get_comm()) 983 end if 984 985 fstrSOLID%GL(:)=0.d0 986 ! fstrSOLID%TOTAL_DISP(:)=0.d0 987 fstrSOLID%unode(:) = 0.d0 988 fstrSOLID%dunode(:) = 0.d0 989 fstrSOLID%ddunode(:) = 0.d0 990 fstrSOLID%QFORCE(:) = 0.d0 991 fstrSOLID%FACTOR( 1:2 ) = 0.d0 992 993 ! for MPC 994 fstrSOLID%n_fix_mpc = hecMESH%mpc%n_mpc 995 if( fstrSOLID%n_fix_mpc>0 ) then 996 allocate( fstrSOLID%mpc_const( fstrSOLID%n_fix_mpc ) ) 997 fstrSOLID%mpc_const(:) = hecMESH%mpc%mpc_const(:) 998 endif 999 1000 ! initialize for linear static problems 1001 fstrSOLID%FACTOR(2)=1.d0 1002 fstrSOLID%FACTOR(1)=0.d0 1003 end subroutine fstr_solid_alloc 1004 1005 !> Initialize elements info in static calculation 1006 subroutine fstr_element_init( hecMESH, fstrSOLID ) 1007 use elementInfo 1008 use mMechGauss 1009 use m_fstr 1010 type(hecmwST_local_mesh),target :: hecMESH 1011 type(fstr_solid) :: fstrSOLID 1012 1013 integer :: i, j, ng, isect, ndof, id, nn 1014 1015 if( hecMESH%n_elem <=0 ) then 1016 stop "no element defined!" 1017 endif 1018 1019 fstrSOLID%maxn_gauss = 0 1020 1021 allocate( fstrSOLID%elements(hecMESH%n_elem) ) 1022 do i=1,hecMESH%n_elem 1023 fstrSOLID%elements(i)%etype = hecMESH%elem_type(i) 1024 if( hecMESH%elem_type(i)==301 ) fstrSOLID%elements(i)%etype=111 1025 if (hecmw_is_etype_link(fstrSOLID%elements(i)%etype)) cycle 1026 if (hecmw_is_etype_patch(fstrSOLID%elements(i)%etype)) cycle 1027 ng = NumOfQuadPoints( fstrSOLID%elements(i)%etype ) 1028 if( ng > fstrSOLID%maxn_gauss ) fstrSOLID%maxn_gauss = ng 1029 if(ng>0) allocate( fstrSOLID%elements(i)%gausses( ng ) ) 1030 1031 isect= hecMESH%section_ID(i) 1032 ndof = getSpaceDimension( fstrSOLID%elements(i)%etype ) 1033 if (ndof == 2) then ! why do this??? 1034 id=hecMESH%section%sect_opt(isect) 1035 if( id==0 ) then 1036 fstrSOLID%elements(i)%iset=1 1037 else if( id==1) then 1038 fstrSOLID%elements(i)%iset=0 1039 else if( id==2) then 1040 fstrSOLID%elements(i)%iset=2 1041 endif 1042 endif 1043 1044 if( isect<0 .or. isect>hecMESH%section%n_sect ) & 1045 stop "Error in element's section definition" 1046 id = hecMESH%section%sect_mat_ID_item(isect) 1047 fstrSOLID%materials(id)%cdsys_ID = hecMESH%section%sect_orien_ID(isect) 1048 do j=1,ng 1049 fstrSOLID%elements(i)%gausses(j)%pMaterial => fstrSOLID%materials(id) 1050 call fstr_init_gauss( fstrSOLID%elements(i)%gausses( j ) ) 1051 enddo 1052 1053 nn = hecmw_get_max_node(hecMESH%elem_type(i)) 1054 allocate(fstrSOLID%elements(i)%equiForces(nn*ndof)) 1055 fstrSOLID%elements(i)%equiForces = 0.0d0 1056 1057 if( hecMESH%elem_type(i)==361 ) then 1058 if( fstrSOLID%sections(isect)%elemopt361==kel361IC ) then 1059 allocate( fstrSOLID%elements(i)%aux(3,3) ) 1060 fstrSOLID%elements(i)%aux = 0.0d0 1061 endif 1062 endif 1063 enddo 1064 1065 call hecmw_allreduce_I1(hecMESH,fstrSOLID%maxn_gauss,HECMW_MAX) 1066 end subroutine 1067 1068 !> Finalizer of fstr_solid 1069 subroutine fstr_solid_finalize( fstrSOLID ) 1070 type(fstr_solid) :: fstrSOLID 1071 integer :: i, j, ierror 1072 if( associated(fstrSOLID%materials) ) then 1073 do j=1,size(fstrSOLID%materials) 1074 call finalizeMaterial(fstrSOLID%materials(j)) 1075 enddo 1076 deallocate( fstrSOLID%materials ) 1077 endif 1078 if( .not. associated(fstrSOLID%elements ) ) return 1079 do i=1,size(fstrSOLID%elements) 1080 if( associated(fstrSOLID%elements(i)%gausses) ) then 1081 do j=1,size(fstrSOLID%elements(i)%gausses) 1082 call fstr_finalize_gauss(fstrSOLID%elements(i)%gausses(j)) 1083 enddo 1084 deallocate( fstrSOLID%elements(i)%gausses ) 1085 endif 1086 if(associated(fstrSOLID%elements(i)%equiForces) ) then 1087 deallocate(fstrSOLID%elements(i)%equiForces) 1088 endif 1089 if( associated(fstrSOLID%elements(i)%aux) ) then 1090 deallocate(fstrSOLID%elements(i)%aux) 1091 endif 1092 enddo 1093 1094 deallocate( fstrSOLID%elements ) 1095 if( associated( fstrSOLID%mpc_const ) ) then 1096 deallocate( fstrSOLID%mpc_const ) 1097 endif 1098 call free_stepInfo( fstrSOLID%step_ctrl_restart ) 1099 if( associated(fstrSOLID%step_ctrl) ) then 1100 do i=1,size(fstrSOLID%step_ctrl) 1101 call free_stepInfo( fstrSOLID%step_ctrl(i) ) 1102 enddo 1103 deallocate( fstrSOLID%step_ctrl ) 1104 endif 1105 if(associated(fstrSOLID%output_ctrl) ) then 1106 do i=1,size(fstrSOLID%output_ctrl) 1107 if( fstrSOLID%output_ctrl(i)%filenum==IUTB ) & 1108 close(fstrSOLID%output_ctrl(i)%filenum) 1109 enddo 1110 deallocate(fstrSOLID%output_ctrl) 1111 endif 1112 if( associated( fstrSOLID%sections ) ) then 1113 deallocate( fstrSOLID%sections ) 1114 endif 1115 1116 if( associated(fstrSOLID%GL) ) then 1117 deallocate(fstrSOLID%GL ,stat=ierror) 1118 if( ierror /= 0 ) then 1119 write(idbg,*) 'stop due to deallocation error <FSTR_SOLID, GL>' 1120 call flush(idbg) 1121 call hecmw_abort( hecmw_comm_get_comm()) 1122 end if 1123 endif 1124 if( associated(fstrSOLID%EFORCE) ) then 1125 deallocate(fstrSOLID%EFORCE ,stat=ierror) 1126 if( ierror /= 0 ) then 1127 write(idbg,*) 'stop due to deallocation error <FSTR_SOLID, EFORCE>' 1128 call flush(idbg) 1129 call hecmw_abort( hecmw_comm_get_comm()) 1130 end if 1131 endif 1132 if( associated(fstrSOLID%unode) ) then 1133 deallocate(fstrSOLID%unode ,stat=ierror) 1134 if( ierror /= 0 ) then 1135 write(idbg,*) 'stop due to deallocation error <FSTR_SOLID, unode>' 1136 call flush(idbg) 1137 call hecmw_abort( hecmw_comm_get_comm()) 1138 end if 1139 endif 1140 if( associated(fstrSOLID%dunode) ) then 1141 deallocate(fstrSOLID%dunode ,stat=ierror) 1142 if( ierror /= 0 ) then 1143 write(idbg,*) 'stop due to deallocation error <FSTR_SOLID, dunode>' 1144 call flush(idbg) 1145 call hecmw_abort( hecmw_comm_get_comm()) 1146 end if 1147 endif 1148 if( associated(fstrSOLID%ddunode) ) then 1149 deallocate(fstrSOLID%ddunode ,stat=ierror) 1150 if( ierror /= 0 ) then 1151 write(idbg,*) 'stop due to deallocation error <FSTR_SOLID, ddunode>' 1152 call flush(idbg) 1153 call hecmw_abort( hecmw_comm_get_comm()) 1154 end if 1155 endif 1156 if( associated(fstrSOLID%QFORCE) ) then 1157 deallocate(fstrSOLID%QFORCE ,stat=ierror) 1158 if( ierror /= 0 ) then 1159 write(idbg,*) 'stop due to deallocation error <FSTR_SOLID, QFORCE>' 1160 call flush(idbg) 1161 call hecmw_abort( hecmw_comm_get_comm()) 1162 end if 1163 endif 1164 if( associated(fstrSOLID%temperature) ) then 1165 deallocate(fstrSOLID%temperature ,stat=ierror) 1166 if( ierror /= 0 ) then 1167 write(idbg,*) 'stop due to deallocation error <FSTR_SOLID, temperature>' 1168 call flush(idbg) 1169 call hecmw_abort( hecmw_comm_get_comm()) 1170 end if 1171 endif 1172 if( associated(fstrSOLID%last_temp) ) then 1173 deallocate(fstrSOLID%last_temp ,stat=ierror) 1174 if( ierror /= 0 ) then 1175 write(idbg,*) 'stop due to deallocation error <FSTR_SOLID, reftemp>' 1176 call flush(idbg) 1177 call hecmw_abort( hecmw_comm_get_comm()) 1178 end if 1179 endif 1180 if( associated(fstrSOLID%temp_bak) ) then 1181 deallocate(fstrSOLID%temp_bak ,stat=ierror) 1182 if( ierror /= 0 ) then 1183 write(idbg,*) 'stop due to deallocation error <FSTR_SOLID, reftemp>' 1184 call flush(idbg) 1185 call hecmw_abort( hecmw_comm_get_comm()) 1186 end if 1187 endif 1188 1189 ! Allocated in in f str_setup_BOUNDARY */ 1190 if( associated(fstrSOLID%BOUNDARY_ngrp_GRPID) ) then 1191 deallocate(fstrSOLID%BOUNDARY_ngrp_GRPID, stat=ierror) 1192 if( ierror /= 0 ) then 1193 write(idbg,*) 'stop due to deallocation error <FSTR_SOLID, BOUNDARY_ngrp_GRPID>' 1194 call flush(idbg) 1195 call hecmw_abort( hecmw_comm_get_comm()) 1196 end if 1197 endif 1198 if( associated(fstrSOLID%BOUNDARY_ngrp_ID) ) then 1199 deallocate(fstrSOLID%BOUNDARY_ngrp_ID, stat=ierror) 1200 if( ierror /= 0 ) then 1201 write(idbg,*) 'stop due to deallocation error <FSTR_SOLID, BOUNDARY_ngrp_ID>' 1202 call flush(idbg) 1203 call hecmw_abort( hecmw_comm_get_comm()) 1204 end if 1205 endif 1206 if( associated(fstrSOLID%BOUNDARY_ngrp_type) ) then 1207 deallocate(fstrSOLID%BOUNDARY_ngrp_type, stat=ierror) 1208 if( ierror /= 0 ) then 1209 write(idbg,*) 'stop due to deallocation error <FSTR_SOLID, BOUNDARY_ngrp_type>' 1210 call flush(idbg) 1211 call hecmw_abort( hecmw_comm_get_comm()) 1212 end if 1213 endif 1214 if( associated(fstrSOLID%BOUNDARY_ngrp_val) ) then 1215 deallocate(fstrSOLID%BOUNDARY_ngrp_val, stat=ierror) 1216 if( ierror /= 0 ) then 1217 write(idbg,*) 'stop due to deallocation error <FSTR_SOLID, BOUNDARY_ngrp_val>' 1218 call flush(idbg) 1219 call hecmw_abort( hecmw_comm_get_comm()) 1220 end if 1221 endif 1222 if( associated(fstrSOLID%BOUNDARY_ngrp_amp) ) then 1223 deallocate(fstrSOLID%BOUNDARY_ngrp_amp, stat=ierror) 1224 if( ierror /= 0 ) then 1225 write(idbg,*) 'stop due to deallocation error <FSTR_SOLID, BOUNDARY_ngrp_amp>' 1226 call flush(idbg) 1227 call hecmw_abort( hecmw_comm_get_comm()) 1228 end if 1229 endif 1230 if( associated(fstrSOLID%BOUNDARY_ngrp_rotID) ) then 1231 deallocate(fstrSOLID%BOUNDARY_ngrp_rotID, stat=ierror) 1232 if( ierror /= 0 ) then 1233 write(idbg,*) 'stop due to deallocation error <FSTR_SOLID, BOUNDARY_ngrp_rotID>' 1234 call flush(idbg) 1235 call hecmw_abort( hecmw_comm_get_comm()) 1236 end if 1237 endif 1238 if( associated(fstrSOLID%BOUNDARY_ngrp_centerID) ) then 1239 deallocate(fstrSOLID%BOUNDARY_ngrp_centerID, stat=ierror) 1240 if( ierror /= 0 ) then 1241 write(idbg,*) 'stop due to deallocation error <FSTR_SOLID, BOUNDARY_ngrp_centerID>' 1242 call flush(idbg) 1243 call hecmw_abort( hecmw_comm_get_comm()) 1244 end if 1245 endif 1246 1247 ! Allocated in in fstr_setup_CLOAD 1248 if( associated(fstrSOLID%CLOAD_ngrp_GRPID) ) then 1249 deallocate(fstrSOLID%CLOAD_ngrp_GRPID, stat=ierror) 1250 if( ierror /= 0 ) then 1251 write(idbg,*) 'stop due to deallocation error <FSTR_SOLID, CLOAD_ngrp_GRPID>' 1252 call flush(idbg) 1253 call hecmw_abort( hecmw_comm_get_comm()) 1254 end if 1255 endif 1256 if( associated(fstrSOLID%CLOAD_ngrp_ID) ) then 1257 deallocate(fstrSOLID%CLOAD_ngrp_ID, stat=ierror) 1258 if( ierror /= 0 ) then 1259 write(idbg,*) 'stop due to deallocation error <FSTR_SOLID, CLOAD_ngrp_ID>' 1260 call flush(idbg) 1261 call hecmw_abort( hecmw_comm_get_comm()) 1262 end if 1263 endif 1264 if( associated(fstrSOLID%CLOAD_ngrp_DOF) ) then 1265 deallocate(fstrSOLID%CLOAD_ngrp_DOF, stat=ierror) 1266 if( ierror /= 0 ) then 1267 write(idbg,*) 'stop due to deallocation error <FSTR_SOLID, CLOAD_ngrp_DOF>' 1268 call flush(idbg) 1269 call hecmw_abort( hecmw_comm_get_comm()) 1270 end if 1271 endif 1272 if( associated(fstrSOLID%CLOAD_ngrp_val) ) then 1273 deallocate(fstrSOLID%CLOAD_ngrp_val, stat=ierror) 1274 if( ierror /= 0 ) then 1275 write(idbg,*) 'stop due to deallocation error <FSTR_SOLID, CLOAD_ngrp_val>' 1276 call flush(idbg) 1277 call hecmw_abort( hecmw_comm_get_comm()) 1278 end if 1279 endif 1280 if( associated(fstrSOLID%CLOAD_ngrp_amp) ) then 1281 deallocate(fstrSOLID%CLOAD_ngrp_amp, stat=ierror) 1282 if( ierror /= 0 ) then 1283 write(idbg,*) 'stop due to deallocation error <FSTR_SOLID, CLOAD_ngrp_amp>' 1284 call flush(idbg) 1285 call hecmw_abort( hecmw_comm_get_comm()) 1286 end if 1287 endif 1288 if( associated(fstrSOLID%CLOAD_ngrp_rotID) ) then 1289 deallocate(fstrSOLID%CLOAD_ngrp_rotID, stat=ierror) 1290 if( ierror /= 0 ) then 1291 write(idbg,*) 'stop due to deallocation error <FSTR_SOLID, CLOAD_ngrp_rotID>' 1292 call flush(idbg) 1293 call hecmw_abort( hecmw_comm_get_comm()) 1294 end if 1295 endif 1296 if( associated(fstrSOLID%CLOAD_ngrp_centerID) ) then 1297 deallocate(fstrSOLID%CLOAD_ngrp_centerID, stat=ierror) 1298 if( ierror /= 0 ) then 1299 write(idbg,*) 'stop due to deallocation error <FSTR_SOLID, CLOAD_ngrp_centerID>' 1300 call flush(idbg) 1301 call hecmw_abort( hecmw_comm_get_comm()) 1302 end if 1303 endif 1304 1305 end subroutine 1306 1307 !> Initial setting of heat analysis 1308 subroutine fstr_heat_init( fstrHEAT ) 1309 implicit none 1310 type(fstr_heat) :: fstrHEAT 1311 1312 fstrHEAT%STEPtot = 0 1313 fstrHEAT%MATERIALtot = 0 1314 fstrHEAT%AMPLITUDEtot= 0 1315 fstrHEAT%T_FIX_tot = 0 1316 fstrHEAT%Q_NOD_tot = 0 1317 fstrHEAT%Q_VOL_tot = 0 1318 fstrHEAT%Q_SUF_tot = 0 1319 fstrHEAT%R_SUF_tot = 0 1320 fstrHEAT%H_SUF_tot = 0 1321 fstrHEAT%WL_tot = 0 1322 end subroutine fstr_heat_init 1323 1324 !> Initial setting of eigen ca;culation 1325 subroutine fstr_eigen_init( fstrEIG ) 1326 implicit none 1327 type(fstr_eigen) :: fstrEIG 1328 1329 fstrEIG%nget = 5 1330 fstrEIG%maxiter = 60 1331 fstrEIG%iter = 0 1332 fstrEIG%sigma = 0.0d0 1333 fstrEIG%tolerance = 1.0d-6 1334 fstrEIG%totalmass = 0.0d0 1335 end subroutine fstr_eigen_init 1336 1337 !> Initial setting of dynamic calculation 1338 subroutine fstr_dynamic_init( fstrDYNAMIC ) 1339 use m_fstr 1340 type(fstr_dynamic) :: fstrDYNAMIC 1341 fstrDYNAMIC%idx_eqa = 1 1342 fstrDYNAMIC%idx_resp = 1 1343 fstrDYNAMIC%n_step = 1 1344 fstrDYNAMIC%t_start = 0.0 1345 fstrDYNAMIC%t_curr = 0.0d0 1346 fstrDYNAMIC%t_end = 1.0 1347 fstrDYNAMIC%t_delta = 1.0 1348 fstrDYNAMIC%ganma = 0.5 1349 fstrDYNAMIC%beta = 0.25 1350 fstrDYNAMIC%idx_mas = 1 1351 fstrDYNAMIC%idx_dmp = 1 1352 fstrDYNAMIC%ray_m = 0.0 1353 fstrDYNAMIC%ray_k = 0.0 1354 fstrDYNAMIC%restart_nout = 0 1355 fstrDYNAMIC%nout = 100 1356 fstrDYNAMIC%ngrp_monit = 0 1357 fstrDYNAMIC%nout_monit = 1 1358 fstrDYNAMIC%iout_list(1) = 0 1359 fstrDYNAMIC%iout_list(2) = 0 1360 fstrDYNAMIC%iout_list(3) = 0 1361 fstrDYNAMIC%iout_list(4) = 0 1362 fstrDYNAMIC%iout_list(5) = 0 1363 fstrDYNAMIC%iout_list(6) = 0 1364 1365 end subroutine fstr_dynamic_init 1366 1367 1368 !> Initial setting of dynamic calculation 1369 subroutine fstr_dynamic_alloc( hecMESH, fstrDYNAMIC ) 1370 use m_fstr 1371 type(hecmwST_local_mesh),target :: hecMESH 1372 type(fstr_dynamic) :: fstrDYNAMIC 1373 1374 integer :: ierror, ndof,nnod 1375 1376 ndof=hecMESH%n_dof 1377 nnod=hecMESH%n_node 1378 if(fstrDYNAMIC%idx_eqa == 11) then 1379 allocate( fstrDYNAMIC%DISP(ndof*nnod,3) ,stat=ierror ) 1380 if( ierror /= 0 ) then 1381 write(idbg,*) 'stop due to allocation error <fstr_solve_LINEAR_DYNAMIC, DISP>' 1382 write(idbg,*) ' rank = ', hecMESH%my_rank,' ierror = ',ierror 1383 call flush(idbg) 1384 call hecmw_abort( hecmw_comm_get_comm()) 1385 end if 1386 allocate( fstrDYNAMIC%VEL (ndof*nnod,1) ,stat=ierror ) 1387 if( ierror /= 0 ) then 1388 write(idbg,*) 'stop due to allocation error <fstr_solve_LINEAR_DYNAMIC, VEL>' 1389 write(idbg,*) ' rank = ', hecMESH%my_rank,' ierror = ',ierror 1390 call flush(idbg) 1391 call hecmw_abort( hecmw_comm_get_comm()) 1392 end if 1393 allocate( fstrDYNAMIC%ACC (ndof*nnod,1) ,stat=ierror ) 1394 if( ierror /= 0 ) then 1395 write(idbg,*) 'stop due to allocation error <fstr_solve_LINEAR_DYNAMIC, ACC>' 1396 write(idbg,*) ' rank = ', hecMESH%my_rank,' ierror = ',ierror 1397 call flush(idbg) 1398 call hecmw_abort( hecmw_comm_get_comm()) 1399 end if 1400 else 1401 allocate( fstrDYNAMIC%DISP(ndof*nnod,2) ,stat=ierror ) 1402 if( ierror /= 0 ) then 1403 write(idbg,*) 'stop due to allocation error <fstr_solve_LINEAR_DYNAMIC, DISP>' 1404 write(idbg,*) ' rank = ', hecMESH%my_rank,' ierror = ',ierror 1405 call flush(idbg) 1406 call hecmw_abort( hecmw_comm_get_comm()) 1407 end if 1408 allocate( fstrDYNAMIC%VEL (ndof*nnod,2) ,stat=ierror ) 1409 if( ierror /= 0 ) then 1410 write(idbg,*) 'stop due to allocation error <fstr_solve_LINEAR_DYNAMIC, VEL>' 1411 write(idbg,*) ' rank = ', hecMESH%my_rank,' ierror = ',ierror 1412 call flush(idbg) 1413 call hecmw_abort( hecmw_comm_get_comm()) 1414 end if 1415 allocate( fstrDYNAMIC%ACC (ndof*nnod,2) ,stat=ierror ) 1416 if( ierror /= 0 ) then 1417 write(idbg,*) 'stop due to allocation error <fstr_solve_LINEAR_DYNAMIC, ACC>' 1418 write(idbg,*) ' rank = ', hecMESH%my_rank,' ierror = ',ierror 1419 call flush(idbg) 1420 call hecmw_abort( hecmw_comm_get_comm()) 1421 end if 1422 endif 1423 1424 1425 allocate( fstrDYNAMIC%VEC1(ndof*nnod) ,stat=ierror ) 1426 if( ierror /= 0 ) then 1427 write(idbg,*) 'stop due to allocation error <fstr_solve_LINEAR_DYNAMIC, VEC1>' 1428 write(idbg,*) ' rank = ', hecMESH%my_rank,' ierror = ',ierror 1429 call flush(idbg) 1430 call hecmw_abort( hecmw_comm_get_comm()) 1431 end if 1432 allocate( fstrDYNAMIC%VEC2(ndof*nnod) ,stat=ierror ) 1433 if( ierror /= 0 ) then 1434 write(idbg,*) 'stop due to allocation error <fstr_solve_LINEAR_DYNAMIC, VEC2>' 1435 write(idbg,*) ' rank = ', hecMESH%my_rank,' ierror = ',ierror 1436 call flush(idbg) 1437 call hecmw_abort( hecmw_comm_get_comm()) 1438 end if 1439 allocate( fstrDYNAMIC%VEC3(ndof*nnod) ,stat=ierror ) 1440 if( ierror /= 0 ) then 1441 write(idbg,*) 'stop due to allocation error <fstr_solve_LINEAR_DYNAMIC, VEC3>' 1442 write(idbg,*) ' rank = ', hecMESH%my_rank,' ierror = ',ierror 1443 call flush(idbg) 1444 call hecmw_abort( hecmw_comm_get_comm()) 1445 end if 1446 1447 end subroutine fstr_dynamic_alloc 1448 1449 !> Finalizer of fstr_solid 1450 subroutine fstr_dynamic_finalize( fstrDYNAMIC ) 1451 type(fstr_dynamic) :: fstrDYNAMIC 1452 1453 integer :: ierror 1454 if( associated(fstrDYNAMIC%DISP) ) & 1455 deallocate( fstrDYNAMIC%DISP ,stat=ierror ) 1456 if( ierror /= 0 ) then 1457 write(idbg,*) 'stop due to deallocation error <fstr_solve_LINEAR_DYNAMIC, DISP>' 1458 call flush(idbg) 1459 call hecmw_abort( hecmw_comm_get_comm()) 1460 end if 1461 if( associated(fstrDYNAMIC%VEL) ) & 1462 deallocate( fstrDYNAMIC%VEL ,stat=ierror ) 1463 if( ierror /= 0 ) then 1464 write(idbg,*) 'stop due to deallocation error <fstr_solve_LINEAR_DYNAMIC, VEL>' 1465 call flush(idbg) 1466 call hecmw_abort( hecmw_comm_get_comm()) 1467 end if 1468 if( associated(fstrDYNAMIC%ACC) ) & 1469 deallocate( fstrDYNAMIC%ACC ,stat=ierror ) 1470 if( ierror /= 0 ) then 1471 write(idbg,*) 'stop due to deallocation error <fstr_solve_LINEAR_DYNAMIC, ACC>' 1472 call flush(idbg) 1473 call hecmw_abort( hecmw_comm_get_comm()) 1474 end if 1475 if( associated(fstrDYNAMIC%VEC1) ) & 1476 deallocate( fstrDYNAMIC%VEC1 ,stat=ierror ) 1477 if( ierror /= 0 ) then 1478 write(idbg,*) 'stop due to deallocation error <fstr_solve_LINEAR_DYNAMIC, VEC1>' 1479 call flush(idbg) 1480 call hecmw_abort( hecmw_comm_get_comm()) 1481 end if 1482 if( associated(fstrDYNAMIC%VEC2) ) & 1483 deallocate( fstrDYNAMIC%VEC2 ,stat=ierror ) 1484 if( ierror /= 0 ) then 1485 write(idbg,*) 'stop due to deallocation error <fstr_solve_LINEAR_DYNAMIC, VEC2>' 1486 call flush(idbg) 1487 call hecmw_abort( hecmw_comm_get_comm()) 1488 end if 1489 if( associated(fstrDYNAMIC%VEC3) ) & 1490 deallocate( fstrDYNAMIC%VEC3 ,stat=ierror ) 1491 if( ierror /= 0 ) then 1492 write(idbg,*) 'stop due to deallocation error <fstr_solve_LINEAR_DYNAMIC, VEC3>' 1493 call flush(idbg) 1494 call hecmw_abort( hecmw_comm_get_comm()) 1495 end if 1496 1497 end subroutine 1498 1499 1500 !-----------------------------------------------------------------------------! 1501 !> Initial setting of postprecessor 1502 1503 subroutine fstr_setup_post_phys_alloc(phys, NDOF, n_node, n_elem) 1504 implicit none 1505 type(fstr_solid_physic_val), pointer :: phys 1506 integer(kind=kint) :: NDOF, n_node, n_elem, mdof 1507 mdof = (NDOF*NDOF+NDOF)/2; 1508 allocate ( phys%STRAIN (mdof*n_node)) 1509 allocate ( phys%STRESS (mdof*n_node)) 1510 allocate ( phys%MISES ( n_node)) 1511 allocate ( phys%ESTRAIN (mdof*n_elem)) 1512 allocate ( phys%ESTRESS (mdof*n_elem)) 1513 allocate ( phys%EMISES ( n_elem)) 1514 allocate ( phys%ENQM (12*n_elem)) 1515 end subroutine fstr_setup_post_phys_alloc 1516 1517 subroutine fstr_setup_post( ctrl, P ) 1518 implicit none 1519 integer(kind=kint) :: ctrl, i 1520 type(fstr_param_pack) :: P 1521 type(fstr_solid_physic_val), pointer :: phys => null() 1522 1523 if( P%PARAM%solution_type == kstSTATIC & 1524 .or. P%PARAM%solution_type == kstEIGEN & 1525 .or. P%PARAM%solution_type == kstDYNAMIC & 1526 .or. P%PARAM%solution_type == kstSTATICEIGEN ) then 1527 ! Memory Allocation for Result Vectors ------------ 1528 if( P%MESH%n_dof == 6 .or. P%SOLID%is_33shell == 1 ) then 1529 allocate ( P%SOLID%SHELL ) 1530 call fstr_setup_post_phys_alloc(P%SOLID%SHELL,3, P%MESH%n_node,P%MESH%n_elem) 1531 allocate ( P%SOLID%SHELL%LAYER(P%SOLID%max_lyr) ) 1532 do i=1,P%SOLID%max_lyr 1533 allocate ( P%SOLID%SHELL%LAYER(i)%PLUS ) 1534 allocate ( P%SOLID%SHELL%LAYER(i)%MINUS ) 1535 call fstr_setup_post_phys_alloc(P%SOLID%SHELL%LAYER(i)%PLUS , 3, P%MESH%n_node, P%MESH%n_elem) 1536 call fstr_setup_post_phys_alloc(P%SOLID%SHELL%LAYER(i)%MINUS, 3, P%MESH%n_node, P%MESH%n_elem) 1537 enddo 1538 phys => P%SOLID%SHELL 1539 else 1540 allocate ( P%SOLID%SOLID ) 1541 phys => P%SOLID%SOLID 1542 call fstr_setup_post_phys_alloc(phys, P%MESH%n_dof, P%MESH%n_node, P%MESH%n_elem) 1543 end if 1544 P%SOLID%STRAIN => phys%STRAIN 1545 P%SOLID%STRESS => phys%STRESS 1546 P%SOLID%MISES => phys%MISES 1547 P%SOLID%ESTRAIN => phys%ESTRAIN 1548 P%SOLID%ESTRESS => phys%ESTRESS 1549 P%SOLID%EMISES => phys%EMISES 1550 P%SOLID%ENQM => phys%ENQM 1551 allocate( P%SOLID%REACTION( P%MESH%n_dof*P%MESH%n_node ) ) 1552 end if 1553 1554 if( P%PARAM%fg_visual == kON )then 1555 call fstr_setup_visualize( ctrl, P%MESH%my_rank ) 1556 end if 1557 1558 call hecmw_barrier( P%MESH ) ! JP-7 1559 1560 if( P%HEAT%STEPtot == 0 ) then ! No !HEAT Input 1561 if( P%PARAM%analysis_n == 0 ) then ! No !STATIC Input 1562 call reallocate_real( P%PARAM%dtime, 1) 1563 call reallocate_real( P%PARAM%etime, 1) 1564 call reallocate_real( P%PARAM%dtmin, 1) 1565 call reallocate_real( P%PARAM%delmax,1) 1566 call reallocate_integer( P%PARAM%itmax, 1) 1567 call reallocate_real( P%PARAM%eps, 1) 1568 P%PARAM%analysis_n = 1 1569 P%PARAM%dtime = 0 1570 P%PARAM%etime = 0 1571 P%PARAM%dtmin = 0 1572 P%PARAM%delmax = 0 1573 P%PARAM%itmax = 20 1574 P%PARAM%eps = 1.0e-6 1575 end if 1576 P%HEAT%STEPtot = 1 1577 call reallocate_real( P%HEAT%STEP_DLTIME, 1) 1578 call reallocate_real( P%HEAT%STEP_EETIME, 1) 1579 call reallocate_real( P%HEAT%STEP_DELMIN, 1) 1580 call reallocate_real( P%HEAT%STEP_DELMAX, 1) 1581 P%HEAT%STEP_DLTIME = 0 1582 P%HEAT%STEP_EETIME = 0 1583 P%HEAT%STEP_DELMIN = 0 1584 P%HEAT%STEP_DELMAX = 0 1585 end if 1586 end subroutine fstr_setup_post 1587 1588 !*****************************************************************************! 1589 !* GENERAL HEADERS ***********************************************************! 1590 !*****************************************************************************! 1591 1592 !-----------------------------------------------------------------------------! 1593 !> Read in !SOLUTION ! 1594 !-----------------------------------------------------------------------------! 1595 1596 subroutine fstr_setup_SOLUTION( ctrl, counter, P ) 1597 implicit none 1598 integer(kind=kint) :: ctrl 1599 integer(kind=kint) :: counter 1600 type(fstr_param_pack) :: P 1601 1602 integer(kind=kint) :: rcode 1603 1604 rcode = fstr_ctrl_get_SOLUTION( ctrl, P%PARAM%solution_type, P%PARAM%nlgeom ) 1605 if( rcode /= 0 ) call fstr_ctrl_err_stop 1606 1607 end subroutine fstr_setup_SOLUTION 1608 1609 !-----------------------------------------------------------------------------! 1610 !> Read in !SOLVER ! 1611 !-----------------------------------------------------------------------------! 1612 1613 subroutine fstr_setup_SOLVER( ctrl, counter, P ) 1614 implicit none 1615 integer(kind=kint) :: ctrl 1616 integer(kind=kint) :: counter 1617 type(fstr_param_pack),target :: P 1618 1619 integer(kind=kint) :: rcode 1620 1621 if( counter >= 2 ) then 1622 write(ILOG,*) '### Error : !SOLVER exists twice in FSTR control file.' 1623 stop 1624 endif 1625 1626 ! nier => svIarray(1) 1627 ! method => svIarray(2) 1628 ! precond => svIarray(3) 1629 ! nset => svIarray(4) 1630 ! iterpremax => svIarray(5) 1631 ! nrest => svIarray(6) 1632 ! scaling => svIarray(7) 1633 ! iterlog => svIarray(21) 1634 ! timelog => svIarray(22) 1635 ! steplog => svIarray(23) 1636 ! dumptype => svIarray(31) 1637 ! dumpexit => svIarray(32) 1638 ! usejad => svIarray(33) 1639 ! ncolor_in => svIarray(34) 1640 ! mpc_method => svIarray(13) 1641 ! estcond => svIarray(14) 1642 ! method2 => svIarray(8) 1643 ! recyclepre => svIarray(35) 1644 ! solver_opt1=> svIarray(41) 1645 ! solver_opt2=> svIarray(42) 1646 ! solver_opt3=> svIarray(43) 1647 ! solver_opt4=> svIarray(44) 1648 ! solver_opt5=> svIarray(45) 1649 ! solver_opt6=> svIarray(46) 1650 1651 ! resid => svRarray(1) 1652 ! sigma_diag => svRarray(2) 1653 ! sigma => svRarray(3) 1654 ! thresh => svRarray(4) 1655 ! filter => svRarray(5) 1656 1657 rcode = fstr_ctrl_get_SOLVER( ctrl, & 1658 svIarray(2), svIarray(3), svIarray(4), svIarray(21), svIarray(22), svIarray(23),& 1659 svIarray(1), svIarray(5), svIarray(6), svIarray(7), & 1660 svIarray(31), svIarray(32), svIarray(33), svIarray(34), svIarray(13), svIarray(14), svIarray(8),& 1661 svIarray(35), svIarray(41), svIarray(42), svIarray(43), svIarray(44), svIarray(45), svIarray(46), & 1662 svRarray(1), svRarray(2), svRarray(3), & 1663 svRarray(4), svRarray(5) ) 1664 if( rcode /= 0 ) call fstr_ctrl_err_stop 1665 1666 if( svIarray(2) <= 100 ) then 1667 svIarray(99) = 1 ! indirect method 1668 else 1669 svIarray(99) = svIarray(2)-99 !2 ! direct method 1670 end if 1671 1672 end subroutine fstr_setup_SOLVER 1673 1674 !* ----------------------------------------------------------------------------------------------- *! 1675 !> Read in !ORIENTATION 1676 !* ----------------------------------------------------------------------------------------------- *! 1677 1678 integer function fstr_setup_ORIENTATION( ctrl, hecMESH, cnt, coordsys ) 1679 implicit none 1680 integer(kind=kint) :: ctrl 1681 type( hecmwST_local_mesh ) :: hecMESH 1682 integer :: cnt 1683 type( tLocalCoordSys ) :: coordsys 1684 1685 integer :: j, is, iE, grp_id(1) 1686 character(len=HECMW_NAME_LEN) :: grp_id_name(1) 1687 1688 integer :: nid, dtype 1689 character(len=HECMW_NAME_LEN) :: data_fmt 1690 real(kind=kreal) :: fdum, xyza(3), xyzb(3), xyzc(3), ff1(3), ff2(3), ff3(3) 1691 1692 fstr_setup_ORIENTATION = -1 1693 1694 nid = 1 1695 coordsys%sys_type = 10 1696 1697 nid = 1 1698 data_fmt = 'COORDINATES,NODES ' 1699 if( fstr_ctrl_get_param_ex( ctrl, 'DEFINITION ', data_fmt, 0, 'P', nid )/=0 ) return 1700 dtype = nid-1 1701 coordsys%sys_type = coordsys%sys_type + dtype 1702 1703 if( fstr_ctrl_get_param_ex( ctrl, 'NAME ', '# ', 1, 'S', grp_id_name(1) )/= 0) return 1704 coordsys%sys_name = grp_id_name(1) 1705 call fstr_strupr( coordsys%sys_name ) 1706 1707 if( dtype==0 ) then 1708 data_fmt = "RRRRRRrrr " 1709 xyzc(:) = 0.d0 1710 if( fstr_ctrl_get_data_array_ex( ctrl, data_fmt, xyza(1), xyza(2), & 1711 xyza(3), xyzb(1), xyzb(2), xyzb(3), xyzc(1), xyzc(2), xyzc(3) )/=0 ) return 1712 if( coordsys%sys_type==10 ) then 1713 ff1 = xyza-xyzc 1714 fdum = dsqrt( dot_product(ff1, ff1) ) 1715 if( fdum==0.d0 ) return 1716 ff1 = ff1/fdum 1717 ff2 = xyzb-xyzc 1718 call cross_product(ff1,ff2,ff3) 1719 coordsys%CoordSys(1,:) = ff1 1720 1721 fdum = dsqrt( dot_product(ff3, ff3) ) 1722 if( fdum==0.d0 ) return 1723 coordsys%CoordSys(3,:) = ff3/fdum 1724 1725 call cross_product(coordsys%CoordSys(3,:), coordsys%CoordSys(1,:), coordsys%CoordSys(2,:) ) 1726 else 1727 coordsys%CoordSys(1,:) = xyza 1728 coordsys%CoordSys(2,:) = xyzb 1729 endif 1730 1731 else 1732 coordsys%node_ID(3) = 0 ! global origin 1733 data_fmt = "IIi " 1734 if( fstr_ctrl_get_data_array_ex( ctrl, data_fmt, coordsys%node_ID(1), & 1735 coordsys%node_ID(2), coordsys%node_ID(3) )/=0 ) return 1736 if( coordsys%node_ID(3) == 0 ) then 1737 nid = node_global_to_local( hecMESH, coordsys%node_ID(1:2), 2 ) 1738 if( nid/=0 .and. nid/=2 ) then 1739 write(*,*) "We cannot define coordinate system using nodes in other CPU!" 1740 write(IDBG,*) "We cannot define coordinate system using nodes in other CPU!" 1741 return 1742 endif 1743 else 1744 nid = node_global_to_local( hecMESH, coordsys%node_ID, 3 ) 1745 if( nid/=0 .and. nid/=3 ) then 1746 write(*,*) "We cannot define coordinate system using nodes in other CPU!" 1747 write(IDBG,*) "We cannot define coordinate system using nodes in other CPU!" 1748 return 1749 endif 1750 endif 1751 endif 1752 1753 fstr_setup_ORIENTATION = 0 1754 end function fstr_setup_ORIENTATION 1755 1756 1757 !-----------------------------------------------------------------------------! 1758 !> Read in !STEP ! 1759 !-----------------------------------------------------------------------------! 1760 1761 subroutine fstr_setup_STEP( ctrl, counter, P ) 1762 implicit none 1763 integer(kind=kint) :: ctrl 1764 integer(kind=kint) :: counter 1765 type(fstr_param_pack) :: P 1766 character(HECMW_NAME_LEN) :: amp 1767 integer(kind=kint) :: amp_id 1768 1769 integer(kind=kint) :: rcode, iproc 1770 1771 amp = ' ' 1772 rcode = fstr_ctrl_get_STEP( ctrl, amp, iproc ) 1773 if( rcode /= 0 ) call fstr_ctrl_err_stop 1774 call amp_name_to_id( P%MESH, '!STEP', amp, amp_id ) 1775 ! P%SOLID%NLSTATIC_ngrp_amp = amp_id; 1776 1777 end subroutine fstr_setup_STEP 1778 1779 integer(kind=kint) function fstr_setup_INITIAL( ctrl, cond, hecMESH ) 1780 implicit none 1781 integer(kind=kint) :: ctrl 1782 type( tInitialCondition ) :: cond 1783 type(hecmwST_local_mesh) :: hecMESH 1784 integer, pointer :: grp_id(:), dof(:) 1785 real(kind=kreal), pointer :: temp(:) 1786 character(len=HECMW_NAME_LEN), pointer :: grp_id_name(:) 1787 character(len=HECMW_NAME_LEN) :: data_fmt, ss 1788 integer :: i,j,n, iS, iE, gid, nid, rcode 1789 1790 fstr_setup_INITIAL = -1 1791 1792 ss = 'TEMPERATURE,VELOCITY,ACCELERATION ' 1793 rcode = fstr_ctrl_get_param_ex( ctrl, 'TYPE ', ss, 1, 'P', nid ) 1794 if( nid==1 ) then 1795 cond%cond_name = "temperature" 1796 allocate( cond%intval(hecMESH%n_node) ) 1797 allocate( cond%realval(hecMESH%n_node) ) 1798 elseif( nid==2 ) then 1799 cond%cond_name = "velocity" 1800 allocate( cond%intval(hecMESH%n_node) ) 1801 allocate( cond%realval(hecMESH%n_node) ) 1802 elseif( nid==3 ) then 1803 cond%cond_name = "acceleration" 1804 allocate( cond%intval(hecMESH%n_node) ) 1805 allocate( cond%realval(hecMESH%n_node) ) 1806 else 1807 return 1808 endif 1809 1810 cond%intval = -1 1811 cond%realval = 0.d0 1812 1813 n = fstr_ctrl_get_data_line_n( ctrl ) 1814 if( n<=0 ) return 1815 allocate( temp(n), grp_id_name(n), grp_id(n), dof(n) ) 1816 dof = 0 1817 write(ss,*) HECMW_NAME_LEN 1818 if( nid==1 ) then 1819 write(data_fmt,'(a,a,a)') 'S',trim(adjustl(ss)),'R ' 1820 fstr_setup_INITIAL = & 1821 fstr_ctrl_get_data_array_ex( ctrl, data_fmt, grp_id_name, temp ) 1822 else 1823 write(data_fmt,'(a,a,a)') 'S',trim(adjustl(ss)),'IR ' 1824 fstr_setup_INITIAL = & 1825 fstr_ctrl_get_data_array_ex( ctrl, data_fmt, grp_id_name, dof, temp ) 1826 endif 1827 1828 if( fstr_setup_INITIAL /= 0 ) then 1829 if( associated(grp_id) ) deallocate( grp_id ) 1830 if( associated(temp) ) deallocate( temp ) 1831 if( associated(dof) ) deallocate( dof ) 1832 if( associated(grp_id_name) ) deallocate( grp_id_name ) 1833 return 1834 end if 1835 1836 call node_grp_name_to_id_ex( hecMESH, '!INITIAL CONDITION', n, grp_id_name, grp_id ) 1837 do i=1,n 1838 gid = grp_id(i) 1839 iS = hecMESH%node_group%grp_index(gid-1) + 1 1840 iE = hecMESH%node_group%grp_index(gid ) 1841 do j=iS, iE 1842 nid = hecMESH%node_group%grp_item(j) 1843 cond%realval(nid) = temp(i) 1844 cond%intval(nid) = dof(i) 1845 enddo 1846 enddo 1847 1848 if( associated(grp_id) ) deallocate( grp_id ) 1849 if( associated(temp) ) deallocate( temp ) 1850 if( associated(dof) ) deallocate( dof ) 1851 if( associated(grp_id_name) ) deallocate( grp_id_name ) 1852end function fstr_setup_INITIAL 1853 1854 !-----------------------------------------------------------------------------! 1855 !> Read in !WRITE ! 1856 !-----------------------------------------------------------------------------! 1857 1858 subroutine fstr_setup_WRITE( ctrl, counter, P ) 1859 implicit none 1860 integer(kind=kint) :: ctrl 1861 integer(kind=kint) :: counter 1862 type(fstr_param_pack) :: P 1863 integer(kind=kint) :: res, visual, neutral 1864 1865 integer(kind=kint) :: rcode 1866 1867 rcode = fstr_ctrl_get_WRITE( ctrl, res, visual, neutral ) 1868 if( rcode /= 0 ) call fstr_ctrl_err_stop 1869 if( res == 1 ) P%PARAM%fg_result = 1 1870 if( visual == 1 ) P%PARAM%fg_visual = 1 1871 if( neutral == 1 ) P%PARAM%fg_neutral = 1 1872 1873 end subroutine fstr_setup_WRITE 1874 1875 1876 !-----------------------------------------------------------------------------! 1877 !> Read in !ECHO ! 1878 !-----------------------------------------------------------------------------! 1879 subroutine fstr_setup_ECHO( ctrl, counter, P ) 1880 implicit none 1881 integer(kind=kint) :: ctrl 1882 integer(kind=kint) :: counter 1883 type(fstr_param_pack) :: P 1884 1885 integer(kind=kint) :: rcode 1886 1887 rcode = fstr_ctrl_get_ECHO( ctrl, & 1888 P%PARAM%fg_echo ) 1889 if( rcode /= 0 ) call fstr_ctrl_err_stop 1890 1891 end subroutine fstr_setup_ECHO 1892 1893 1894 !-----------------------------------------------------------------------------! 1895 !> Read in !RESTART ! 1896 !-----------------------------------------------------------------------------! 1897 subroutine fstr_setup_RESTART( ctrl, nout, version ) 1898 implicit none 1899 integer(kind=kint) :: ctrl 1900 integer(kind=kint) :: nout 1901 integer(kind=kint) :: version 1902 1903 integer(kind=kint) :: rcode 1904 nout = 0 1905 rcode = fstr_ctrl_get_param_ex( ctrl, 'FREQUENCY ', '# ', 0, 'I', nout ) 1906 if( rcode /= 0 ) call fstr_ctrl_err_stop 1907 rcode = fstr_ctrl_get_param_ex( ctrl, 'VERSION ', '# ', 0, 'I', version ) 1908 if( rcode /= 0 ) call fstr_ctrl_err_stop 1909 1910 end subroutine fstr_setup_RESTART 1911 1912 1913 !-----------------------------------------------------------------------------! 1914 !> Read in !COUPLE ! 1915 !-----------------------------------------------------------------------------! 1916 1917 subroutine fstr_setup_COUPLE( ctrl, counter, P ) 1918 implicit none 1919 integer(kind=kint) :: ctrl 1920 integer(kind=kint) :: counter 1921 type(fstr_param_pack) :: P 1922 integer(kind=kint) :: rcode 1923 character(HECMW_NAME_LEN), pointer :: grp_id_name(:) 1924 integer(kind=kint) :: i, n, old_size, new_size 1925 1926 if( P%SOLID%file_type /= kbcfFSTR ) return 1927 1928 n = fstr_ctrl_get_data_line_n( ctrl ) 1929 if( n == 0 ) return 1930 old_size = P%SOLID%COUPLE_ngrp_tot 1931 new_size = old_size + n 1932 P%SOLID%COUPLE_ngrp_tot = new_size 1933 1934 call fstr_expand_integer_array ( P%SOLID%COUPLE_ngrp_ID, old_size, new_size ) 1935 1936 allocate( grp_id_name(n)) 1937 rcode = fstr_ctrl_get_COUPLE( ctrl, & 1938 P%PARAM%fg_couple_type, & 1939 P%PARAM%fg_couple_first, & 1940 P%PARAM%fg_couple_window, & 1941 grp_id_name, HECMW_NAME_LEN ) 1942 if( rcode /= 0 ) call fstr_ctrl_err_stop 1943 1944 call surf_grp_name_to_id_ex( P%MESH, '!COUPLE', & 1945 n, grp_id_name, P%SOLID%COUPLE_ngrp_ID(old_size+1:)) 1946 1947 deallocate( grp_id_name ) 1948 P%PARAM%fg_couple = 1 1949 1950 end subroutine fstr_setup_COUPLE 1951 1952 1953 !*****************************************************************************! 1954 !* HEADERS FOR STATIC ANALYSIS ***********************************************! 1955 !*****************************************************************************! 1956 1957 !-----------------------------------------------------------------------------! 1958 !> Read in !STATIC(old) ! 1959 !-----------------------------------------------------------------------------! 1960 1961 subroutine fstr_setup_STATIC( ctrl, counter, P ) 1962 implicit none 1963 integer(kind=kint) :: ctrl 1964 integer(kind=kint) :: counter 1965 type(fstr_param_pack) :: P 1966 integer(kind=kint) :: rcode 1967 1968 integer :: nout, nout_monit,node_monit_1 ,elem_monit_1 ,intg_monit_1 1969 integer :: ipt, idx_elpl, iout_list(6) 1970 real(kind=kreal) :: sig_y0, h_dash 1971 1972 if( counter > 1 ) then 1973 write(*,*) 1974 endif 1975 1976 ipt = 0 1977 if( fstr_ctrl_get_param_ex( ctrl, 'TYPE ', 'INFINITESIMAL,NLGEOM,INFINITE ', 0, 'P', ipt )/=0 ) & 1978 return 1979 if( ipt == 2 ) P%PARAM%nlgeom = .true. 1980 1981 ! for backward compatibility 1982 if( ipt == 3 ) then 1983 write(*,*) "Warning : !STATIC : parameter 'TYPE=INFINITE' is deprecated." & 1984 & // " Please use the replacement parameter 'TYPE=INFINITESIMAL'" 1985 endif 1986 1987 rcode = fstr_ctrl_get_STATIC( ctrl, & 1988 DT, ETIME, ITMAX, EPS, P%SOLID%restart_nout, & 1989 idx_elpl, & 1990 iout_list, & 1991 sig_y0, h_dash, & 1992 nout, nout_monit, node_monit_1, & 1993 elem_monit_1, intg_monit_1 ) 1994 1995 if( rcode /= 0 ) call fstr_ctrl_err_stop 1996 1997 end subroutine fstr_setup_STATIC 1998 1999 2000 !-----------------------------------------------------------------------------! 2001 !> Read in !BOUNDARY ! 2002 !-----------------------------------------------------------------------------! 2003 2004 subroutine fstr_setup_BOUNDARY( ctrl, counter, P ) 2005 implicit none 2006 integer(kind=kint) :: ctrl 2007 integer(kind=kint) :: counter 2008 type(fstr_param_pack) :: P 2009 2010 integer(kind=kint) :: rcode 2011 integer(kind=kint) :: type = 0 2012 character(HECMW_NAME_LEN) :: amp, rotc_name(1) 2013 integer(kind=kint) :: amp_id, rotc_id(1), n_rotc 2014 character(HECMW_NAME_LEN), pointer :: grp_id_name(:) 2015 integer(kind=kint),pointer :: dof_ids (:) 2016 integer(kind=kint),pointer :: dof_ide (:) 2017 real(kind=kreal),pointer :: val_ptr(:) 2018 integer(kind=kint) :: i, n, old_size, new_size 2019 2020 integer(kind=kint) :: gid 2021 2022 gid = 1 2023 rcode = fstr_ctrl_get_param_ex( ctrl, 'GRPID ', '# ', 0, 'I', gid ) 2024 ! rcode = fstr_ctrl_get_param_ex( ctrl, 'TYPE ', 'FSTR,NASTRAN ', 0, 'P', type ) 2025 ! if( rcode < 0 ) call fstr_ctrl_err_stop 2026 ! if( rcode == 1 ) type = 0 ! PARAM_NOTHING 2027 2028 ! if( type == 0 ) then 2029 2030 ! get center of torque load 2031 rotc_name = ' ' 2032 rotc_id = -1 2033 n_rotc = -1 2034 rcode = fstr_ctrl_get_param_ex( ctrl, 'ROT_CENTER ', '# ', 0, 'S', rotc_name ) 2035 if( rcode /= 0 ) call fstr_ctrl_err_stop 2036 if( rotc_name(1) /= ' ' ) then 2037 P%SOLID%BOUNDARY_ngrp_rot = P%SOLID%BOUNDARY_ngrp_rot + 1 2038 n_rotc = P%SOLID%BOUNDARY_ngrp_rot 2039 call node_grp_name_to_id_ex( P%MESH, '!BOUNDARY,ROT_CENTER=', 1, rotc_name, rotc_id) 2040 endif 2041 2042 2043 ! ENTIRE ----------------------------------------------- 2044 P%SOLID%file_type = kbcfFSTR 2045 2046 n = fstr_ctrl_get_data_line_n( ctrl ) 2047 if( n == 0 ) return 2048 old_size = P%SOLID%BOUNDARY_ngrp_tot 2049 new_size = old_size + n 2050 P%SOLID%BOUNDARY_ngrp_tot = new_size 2051 call fstr_expand_integer_array (P%SOLID%BOUNDARY_ngrp_GRPID, old_size, new_size ) 2052 call fstr_expand_integer_array (P%SOLID%BOUNDARY_ngrp_ID, old_size, new_size ) 2053 call fstr_expand_integer_array (P%SOLID%BOUNDARY_ngrp_type, old_size, new_size ) 2054 call fstr_expand_real_array (P%SOLID%BOUNDARY_ngrp_val, old_size, new_size ) 2055 call fstr_expand_integer_array (P%SOLID%BOUNDARY_ngrp_amp, old_size, new_size ) 2056 call fstr_expand_integer_array (P%SOLID%BOUNDARY_ngrp_rotID, old_size, new_size ) 2057 call fstr_expand_integer_array (P%SOLID%BOUNDARY_ngrp_centerID, old_size, new_size ) 2058 2059 allocate( grp_id_name(n) ) 2060 allocate( dof_ids (n) ) 2061 allocate( dof_ide (n) ) 2062 2063 amp = ' ' 2064 val_ptr => P%SOLID%BOUNDARY_ngrp_val(old_size+1:) 2065 val_ptr = 0 2066 rcode = fstr_ctrl_get_BOUNDARY( ctrl, amp, grp_id_name, HECMW_NAME_LEN, dof_ids, dof_ide, val_ptr) 2067 if( rcode /= 0 ) call fstr_ctrl_err_stop 2068 call amp_name_to_id( P%MESH, '!BOUNDARY', amp, amp_id ) 2069 P%SOLID%BOUNDARY_ngrp_GRPID(old_size+1:new_size) = gid 2070 call node_grp_name_to_id_ex( P%MESH, '!BOUNDARY', n, grp_id_name, P%SOLID%BOUNDARY_ngrp_ID(old_size+1:)) 2071 2072 ! set up infomation abount rotation ( default value is set if ROT_CENTER is not given.) 2073 P%SOLID%BOUNDARY_ngrp_rotID(old_size+1:) = n_rotc 2074 P%SOLID%BOUNDARY_ngrp_centerID(old_size+1:) = rotc_id(1) 2075 2076 do i = 1, n 2077 if( (dof_ids(i) < 1).or.(6 < dof_ids(i)).or.(dof_ide(i) < 1).or.(6 < dof_ide(i)) ) then 2078 write(*,*) 'fstr contol file error : !BOUNDARY : range of dof_ids and dof_ide is from 1 to 6' 2079 write(ILOG,*) 'fstr contol file error : !BOUNDARY : range of dof_ids and dof_ide is from 1 to 6' 2080 call fstr_ctrl_err_stop 2081 end if 2082 P%SOLID%BOUNDARY_ngrp_type(old_size+i) = 10 * dof_ids(i) + dof_ide(i) 2083 P%SOLID%BOUNDARY_ngrp_amp(old_size+i) = amp_id 2084 end do 2085 2086 deallocate( grp_id_name ) 2087 deallocate( dof_ids ) 2088 deallocate( dof_ide ) 2089 ! else 2090 ! ! NASTRAN --------------------------------------------- 2091 ! 2092 ! P%SOLID%file_type = kbcfNASTRAN 2093 ! call fstr_setup_solid_nastran( ctrl, P%MESH, P%SOLID ) 2094 ! end if 2095 2096 end subroutine fstr_setup_BOUNDARY 2097 2098 2099 !-----------------------------------------------------------------------------! 2100 !> Read in !CLOAD ! 2101 !-----------------------------------------------------------------------------! 2102 2103 subroutine fstr_setup_CLOAD( ctrl, counter, P ) 2104 implicit none 2105 integer(kind=kint) :: ctrl 2106 integer(kind=kint) :: counter 2107 type(fstr_param_pack) :: P 2108 2109 integer(kind=kint) :: rcode 2110 character(HECMW_NAME_LEN) :: amp, rotc_name(1) 2111 integer(kind=kint) :: amp_id, rotc_id(1), n_rotc 2112 character(HECMW_NAME_LEN), pointer :: grp_id_name(:) 2113 real(kind=kreal),pointer :: val_ptr(:) 2114 integer(kind=kint),pointer :: id_ptr(:) 2115 integer(kind=kint) :: i, n, old_size, new_size 2116 integer(kind=kint) :: gid 2117 2118 if( P%SOLID%file_type /= kbcfFSTR ) return 2119 gid = 1 2120 rcode = fstr_ctrl_get_param_ex( ctrl, 'GRPID ', '# ', 0, 'I', gid ) 2121 if( rcode /= 0 ) call fstr_ctrl_err_stop 2122 2123 ! get center of torque load 2124 rotc_name = ' ' 2125 rotc_id = -1 2126 n_rotc = -1 2127 rcode = fstr_ctrl_get_param_ex( ctrl, 'ROT_CENTER ', '# ', 0, 'S', rotc_name ) 2128 if( rcode /= 0 ) call fstr_ctrl_err_stop 2129 if( rotc_name(1) /= ' ' ) then 2130 P%SOLID%CLOAD_ngrp_rot = P%SOLID%CLOAD_ngrp_rot + 1 2131 n_rotc = P%SOLID%CLOAD_ngrp_rot 2132 call node_grp_name_to_id_ex( P%MESH, '!CLOAD,ROT_CENTER=', 1, rotc_name, rotc_id) 2133 endif 2134 2135 n = fstr_ctrl_get_data_line_n( ctrl ) 2136 if( n == 0 ) return 2137 old_size = P%SOLID%CLOAD_ngrp_tot 2138 new_size = old_size + n 2139 P%SOLID%CLOAD_ngrp_tot = new_size 2140 ! Keiji Suemitsu (20140624) < 2141 call fstr_expand_integer_array ( P%SOLID%CLOAD_ngrp_GRPID, old_size, new_size ) 2142 call fstr_expand_integer_array ( P%SOLID%CLOAD_ngrp_ID, old_size, new_size ) 2143 call fstr_expand_integer_array ( P%SOLID%CLOAD_ngrp_DOF, old_size, new_size ) 2144 call fstr_expand_real_array ( P%SOLID%CLOAD_ngrp_val, old_size, new_size ) 2145 call fstr_expand_integer_array ( P%SOLID%CLOAD_ngrp_amp, old_size, new_size ) 2146 call fstr_expand_integer_array ( P%SOLID%CLOAD_ngrp_rotID, old_size, new_size ) 2147 call fstr_expand_integer_array ( P%SOLID%CLOAD_ngrp_centerID, old_size, new_size ) 2148 ! > Keiji Suemitsu (20140624) 2149 2150 allocate( grp_id_name(n)) 2151 amp = ' ' 2152 val_ptr => P%SOLID%CLOAD_ngrp_val(old_size+1:) 2153 id_ptr =>P%SOLID%CLOAD_ngrp_DOF(old_size+1:) 2154 val_ptr = 0 2155 rcode = fstr_ctrl_get_CLOAD( ctrl, amp, grp_id_name, HECMW_NAME_LEN, id_ptr, val_ptr ) 2156 if( rcode /= 0 ) call fstr_ctrl_err_stop 2157 2158 ! set up infomation abount torque load ( default value is set if ROT_CENTER is not given.) 2159 P%SOLID%CLOAD_ngrp_rotID(old_size+1:) = n_rotc 2160 P%SOLID%CLOAD_ngrp_centerID(old_size+1:) = rotc_id(1) 2161 2162 call amp_name_to_id( P%MESH, '!CLOAD', amp, amp_id ) 2163 do i=1,n 2164 P%SOLID%CLOAD_ngrp_amp(old_size+i) = amp_id 2165 end do 2166 P%SOLID%CLOAD_ngrp_GRPID(old_size+1:new_size) = gid 2167 call node_grp_name_to_id_ex( P%MESH, '!CLOAD', n, grp_id_name, P%SOLID%CLOAD_ngrp_ID(old_size+1:)) 2168 2169 deallocate( grp_id_name ) 2170 2171 end subroutine fstr_setup_CLOAD 2172 2173 !-----------------------------------------------------------------------------! 2174 !> Read !FLOAD ! 2175 !-----------------------------------------------------------------------------! 2176 include 'fstr_ctrl_freq.f90' 2177 2178 !-----------------------------------------------------------------------------! 2179 !> Reset !DLOAD ! 2180 !-----------------------------------------------------------------------------! 2181 2182 subroutine fstr_expand_dload_array( array, old_size, new_size ) 2183 implicit none 2184 real(kind=kreal), pointer :: array(:,:) 2185 integer(kind=kint) :: old_size, new_size, i, j 2186 real(kind=kreal), pointer :: temp(:,:) 2187 2188 if( old_size >= new_size ) then 2189 return 2190 end if 2191 2192 if( associated( array ) ) then 2193 allocate(temp(0:6, old_size)) 2194 temp = array 2195 deallocate(array) 2196 allocate(array(0:6, new_size)) 2197 array = 0 2198 do i=1,old_size 2199 do j=0,6 2200 array(j,i) = temp(j,i) 2201 end do 2202 end do 2203 deallocate(temp) 2204 else 2205 allocate(array(0:6, new_size)) 2206 array = 0 2207 end if 2208 end subroutine fstr_expand_dload_array 2209 2210 !> Read in !DLOAD 2211 subroutine fstr_setup_DLOAD( ctrl, counter, P ) 2212 implicit none 2213 integer(kind=kint) :: ctrl 2214 integer(kind=kint) :: counter 2215 type(fstr_param_pack) :: P 2216 2217 integer(kind=kint) :: rcode 2218 character(HECMW_NAME_LEN) :: amp 2219 integer(kind=kint) :: amp_id 2220 integer(kind=kint) :: follow 2221 character(HECMW_NAME_LEN), pointer :: grp_id_name(:) 2222 real(kind=kreal),pointer :: new_params(:,:) 2223 logical,pointer :: fg_surface(:) 2224 integer(kind=kint),pointer :: lid_ptr(:) 2225 integer(kind=kint) :: i, j, n, old_size, new_size 2226 integer(kind=kint) :: gid 2227 2228 if( P%SOLID%file_type /= kbcfFSTR ) return 2229 2230 gid = 1 2231 rcode = fstr_ctrl_get_param_ex( ctrl, 'GRPID ', '# ', 0, 'I', gid ) 2232 2233 n = fstr_ctrl_get_data_line_n( ctrl ) 2234 if( n == 0 ) return 2235 old_size = P%SOLID%DLOAD_ngrp_tot 2236 new_size = old_size + n 2237 P%SOLID%DLOAD_ngrp_tot = new_size 2238 ! Keiji Suemitsu (20140624) < 2239 call fstr_expand_integer_array ( P%SOLID%DLOAD_ngrp_GRPID, old_size, new_size ) 2240 call fstr_expand_integer_array ( P%SOLID%DLOAD_ngrp_ID, old_size, new_size ) 2241 call fstr_expand_integer_array ( P%SOLID%DLOAD_ngrp_LID, old_size, new_size ) 2242 call fstr_expand_integer_array ( P%SOLID%DLOAD_ngrp_amp, old_size, new_size ) 2243 call fstr_expand_dload_array ( P%SOLID%DLOAD_ngrp_params, old_size, new_size ) 2244 ! > Keiji Suemitsu (20140624) 2245 2246 allocate( grp_id_name(n)) 2247 allocate( new_params(0:6,n)) 2248 allocate( fg_surface(n)) 2249 new_params = 0 2250 amp = ' ' 2251 follow = P%SOLID%DLOAD_follow 2252 if( .not. P%PARAM%nlgeom ) follow = 0 2253 lid_ptr => P%SOLID%DLOAD_ngrp_LID(old_size+1:) 2254 rcode = fstr_ctrl_get_DLOAD( ctrl, amp, follow, & 2255 grp_id_name, HECMW_NAME_LEN, & 2256 lid_ptr, new_params ) 2257 if( rcode /= 0 ) call fstr_ctrl_err_stop 2258 call amp_name_to_id( P%MESH, '!DLOAD', amp, amp_id ) 2259 P%SOLID%DLOAD_follow = follow 2260 do i=1,n 2261 P%SOLID%DLOAD_ngrp_amp(old_size+i) = amp_id 2262 do j=0, 6 2263 P%SOLID%DLOAD_ngrp_params(j,old_size+i) = new_params(j,i) 2264 end do 2265 fg_surface(i) = ( lid_ptr(i) == 100 ) 2266 end do 2267 P%SOLID%DLOAD_ngrp_GRPID(old_size+1:new_size) = gid 2268 call dload_grp_name_to_id_ex( P%MESH, n, grp_id_name, fg_surface, P%SOLID%DLOAD_ngrp_ID(old_size+1:)) 2269 deallocate( grp_id_name ) 2270 deallocate( new_params ) 2271 deallocate( fg_surface ) 2272 end subroutine fstr_setup_DLOAD 2273 2274 2275 !-----------------------------------------------------------------------------! 2276 !> Read in !TEMPERATURE ! 2277 !-----------------------------------------------------------------------------! 2278 2279 subroutine fstr_setup_TEMPERATURE( ctrl, counter, P ) 2280 implicit none 2281 integer(kind=kint) :: ctrl 2282 integer(kind=kint) :: counter 2283 type(fstr_param_pack) :: P 2284 2285 integer(kind=kint) :: rcode, gid 2286 character(HECMW_NAME_LEN), pointer :: grp_id_name(:) 2287 real(kind=kreal),pointer :: val_ptr(:) 2288 integer(kind=kint) :: n, old_size, new_size 2289 2290 if( P%SOLID%file_type /= kbcfFSTR ) return 2291 2292 gid = 1 2293 rcode = fstr_ctrl_get_param_ex( ctrl, 'GRPID ', '# ', 0, 'I', gid ) 2294 2295 n = fstr_ctrl_get_data_line_n( ctrl ) 2296 old_size = P%SOLID%TEMP_ngrp_tot 2297 if( n > 0 ) then 2298 new_size = old_size + n 2299 else 2300 new_size = old_size + 1 2301 endif 2302 call fstr_expand_integer_array ( P%SOLID%TEMP_ngrp_GRPID, old_size, new_size ) 2303 call fstr_expand_integer_array ( P%SOLID%TEMP_ngrp_ID, old_size, new_size ) 2304 call fstr_expand_real_array ( P%SOLID%TEMP_ngrp_val,old_size, new_size ) 2305 2306 allocate( grp_id_name(n)) 2307 val_ptr => P%SOLID%TEMP_ngrp_val( old_size+1: ) 2308 2309 rcode = fstr_ctrl_get_TEMPERATURE( ctrl, & 2310 P%SOLID%TEMP_irres, & 2311 P%SOLID%TEMP_tstep, & 2312 P%SOLID%TEMP_interval, & 2313 P%SOLID%TEMP_rtype, & 2314 grp_id_name, HECMW_NAME_LEN, & 2315 val_ptr ) 2316 if( rcode /= 0 ) call fstr_ctrl_err_stop 2317 2318 P%SOLID%TEMP_ngrp_GRPID(old_size+1:new_size) = gid 2319 if( n > 0 ) then 2320 if( P%SOLID%TEMP_irres == 0 ) then 2321 P%SOLID%TEMP_ngrp_tot = new_size 2322 call node_grp_name_to_id_ex( P%MESH, '!TEMPERATURE', & 2323 n, grp_id_name, P%SOLID%TEMP_ngrp_ID(old_size+1:)) 2324 endif 2325 deallocate( grp_id_name ) 2326 endif 2327 2328 end subroutine fstr_setup_TEMPERATURE 2329 2330 2331 !-----------------------------------------------------------------------------! 2332 !> Read in !SPRING ! 2333 !-----------------------------------------------------------------------------! 2334 2335 subroutine fstr_setup_SPRING( ctrl, counter, P ) 2336 implicit none 2337 integer(kind=kint) :: ctrl 2338 integer(kind=kint) :: counter 2339 type(fstr_param_pack) :: P 2340 2341 integer(kind=kint) :: rcode 2342 character(HECMW_NAME_LEN) :: amp 2343 integer(kind=kint) :: amp_id 2344 character(HECMW_NAME_LEN), pointer :: grp_id_name(:) 2345 real(kind=kreal),pointer :: val_ptr(:) 2346 integer(kind=kint),pointer :: id_ptr(:) 2347 integer(kind=kint) :: i, n, old_size, new_size 2348 integer(kind=kint) :: gid 2349 2350 if( P%SOLID%file_type /= kbcfFSTR ) return 2351 gid = 1 2352 rcode = fstr_ctrl_get_param_ex( ctrl, 'GRPID ', '# ', 0, 'I', gid ) 2353 n = fstr_ctrl_get_data_line_n( ctrl ) 2354 if( n == 0 ) return 2355 old_size = P%SOLID%SPRING_ngrp_tot 2356 new_size = old_size + n 2357 P%SOLID%SPRING_ngrp_tot = new_size 2358 call fstr_expand_integer_array ( P%SOLID%SPRING_ngrp_GRPID, old_size, new_size ) 2359 call fstr_expand_integer_array ( P%SOLID%SPRING_ngrp_ID, old_size, new_size ) 2360 call fstr_expand_integer_array ( P%SOLID%SPRING_ngrp_DOF, old_size, new_size ) 2361 call fstr_expand_real_array ( P%SOLID%SPRING_ngrp_val, old_size, new_size ) 2362 call fstr_expand_integer_array ( P%SOLID%SPRING_ngrp_amp, old_size, new_size ) 2363 2364 allocate( grp_id_name(n)) 2365 amp = ' ' 2366 val_ptr => P%SOLID%SPRING_ngrp_val(old_size+1:) 2367 id_ptr =>P%SOLID%SPRING_ngrp_DOF(old_size+1:) 2368 val_ptr = 0 2369 rcode = fstr_ctrl_get_SPRING( ctrl, amp, grp_id_name, HECMW_NAME_LEN, id_ptr, val_ptr ) 2370 if( rcode /= 0 ) call fstr_ctrl_err_stop 2371 2372 call amp_name_to_id( P%MESH, '!SPRING', amp, amp_id ) 2373 do i=1,n 2374 P%SOLID%SPRING_ngrp_amp(old_size+i) = amp_id 2375 end do 2376 P%SOLID%SPRING_ngrp_GRPID(old_size+1:new_size) = gid 2377 call node_grp_name_to_id_ex( P%MESH, '!SPRING', n, grp_id_name, P%SOLID%SPRING_ngrp_ID(old_size+1:)) 2378 2379 deallocate( grp_id_name ) 2380 2381 end subroutine fstr_setup_SPRING 2382 2383 2384 !-----------------------------------------------------------------------------! 2385 !> Read in !REFTEMP ! 2386 !-----------------------------------------------------------------------------! 2387 2388 subroutine fstr_setup_REFTEMP( ctrl, counter, P ) 2389 implicit none 2390 integer(kind=kint) :: ctrl 2391 integer(kind=kint) :: counter 2392 type(fstr_param_pack) :: P 2393 2394 integer(kind=kint) :: rcode 2395 2396 rcode = fstr_ctrl_get_REFTEMP( ctrl, P%PARAM%ref_temp ) 2397 if( rcode /= 0 ) call fstr_ctrl_err_stop 2398 2399 end subroutine fstr_setup_REFTEMP 2400 2401 2402 !*****************************************************************************! 2403 !* HEADERS FOR HEAT ANALYSIS *************************************************! 2404 !*****************************************************************************! 2405 2406 !-----------------------------------------------------------------------------! 2407 !> Read in !HEAT ! 2408 !-----------------------------------------------------------------------------! 2409 2410 subroutine fstr_setup_HEAT( ctrl, counter, P ) 2411 implicit none 2412 integer(kind=kint) :: ctrl 2413 integer(kind=kint) :: counter 2414 type(fstr_param_pack) :: P 2415 2416 integer(kind=kint) :: rcode 2417 integer(kind=kint) :: n 2418 character(len=HECMW_NAME_LEN) :: mName 2419 integer(kind=kint) :: i 2420 2421 n = fstr_ctrl_get_data_line_n( ctrl ) 2422 2423 if( n == 0 ) return 2424 2425 call reallocate_real( P%PARAM%dtime, n) 2426 call reallocate_real( P%PARAM%etime, n) 2427 call reallocate_real( P%PARAM%dtmin, n) 2428 call reallocate_real( P%PARAM%delmax,n) 2429 call reallocate_integer( P%PARAM%itmax, n) 2430 call reallocate_real( P%PARAM%eps, n) 2431 P%PARAM%analysis_n = n 2432 2433 P%PARAM%dtime = 0 2434 P%PARAM%etime = 0 2435 P%PARAM%dtmin = 0 2436 P%PARAM%delmax = 0 2437 P%PARAM%itmax = 20 2438 P%PARAM%eps = 1.0e-6 2439 P%PARAM%timepoint_id = 0 2440 2441 rcode = fstr_ctrl_get_HEAT( ctrl, & 2442 P%PARAM%dtime, & 2443 P%PARAM%etime, & 2444 P%PARAM%dtmin, & 2445 P%PARAM%delmax, & 2446 P%PARAM%itmax, & 2447 P%PARAM%eps, & 2448 mName ) 2449 if( rcode /= 0 ) then 2450 call fstr_ctrl_err_stop 2451 end if 2452 2453 if( associated(P%PARAM%timepoints) ) then 2454 do i=1,size(P%PARAM%timepoints) 2455 if( fstr_streqr( P%PARAM%timepoints(i)%name, mName ) ) then 2456 P%PARAM%timepoint_id = i; exit 2457 endif 2458 enddo 2459 endif 2460 2461 call reallocate_real( P%HEAT%STEP_DLTIME, n) 2462 call reallocate_real( P%HEAT%STEP_EETIME, n) 2463 call reallocate_real( P%HEAT%STEP_DELMIN, n) 2464 call reallocate_real( P%HEAT%STEP_DELMAX, n) 2465 P%HEAT%STEPtot = n 2466 2467 P%HEAT%STEP_DLTIME = P%PARAM%dtime 2468 P%HEAT%STEP_EETIME = P%PARAM%etime 2469 P%HEAT%STEP_DELMIN = P%PARAM%dtmin 2470 P%HEAT%STEP_DELMAX = P%PARAM%delmax 2471 P%HEAT%timepoint_id = P%PARAM%timepoint_id 2472 2473 end subroutine fstr_setup_HEAT 2474 2475 !-----------------------------------------------------------------------------! 2476 !> Read in !FIXTEMP ! 2477 !-----------------------------------------------------------------------------! 2478 2479 subroutine fstr_setup_FIXTEMP( ctrl, counter, P ) 2480 implicit none 2481 integer(kind=kint) :: ctrl 2482 integer(kind=kint) :: counter 2483 type(fstr_param_pack),target :: P 2484 2485 integer(kind=kint) :: rcode 2486 character(HECMW_NAME_LEN) :: amp 2487 integer(kind=kint) :: amp_id 2488 character(HECMW_NAME_LEN), pointer :: grp_id_name(:) 2489 real(kind=kreal),pointer :: value(:) 2490 integer(kind=kint) :: i, j, n, m, head, id, member_n, old_size, new_size 2491 integer(kind=kint),pointer :: member(:) 2492 integer(kind=kint) :: local_id, rtc 2493 ! ------------------------------------------------ 2494 2495 n = fstr_ctrl_get_data_line_n( ctrl ) 2496 if( n == 0 ) return 2497 2498 allocate( grp_id_name(n)) 2499 allocate( value(n)) 2500 2501 amp = ' ' 2502 rcode = fstr_ctrl_get_FIXTEMP( ctrl, amp, & 2503 grp_id_name, HECMW_NAME_LEN, value ) 2504 if( rcode /= 0 ) call fstr_ctrl_err_stop 2505 2506 call amp_name_to_id( P%MESH, '!FIXTEMP', amp, amp_id ) 2507 2508 m = 0 2509 do i = 1, n 2510 !rtc = get_local_member_index( P%MESH, 'node', grp_id_name(i), local_id ) 2511 rtc = get_sorted_local_member_index( P%MESH, P%PARAM, 'node', grp_id_name(i), local_id ) 2512 if( rtc > 0 ) then 2513 m = m + 1 2514 else if( rtc < 0 ) then 2515 m = m + get_grp_member_n( P%MESH, 'node_grp', grp_id_name(i) ) 2516 end if 2517 end do 2518 2519 if (m == 0) then 2520 deallocate( grp_id_name ) 2521 deallocate( value ) 2522 return 2523 endif 2524 2525 ! JP-8 2526 old_size = P%HEAT%T_FIX_tot 2527 new_size = old_size + m 2528 call fstr_expand_integer_array( P%HEAT%T_FIX_node, old_size, new_size ) 2529 call fstr_expand_integer_array( P%HEAT%T_FIX_ampl, old_size, new_size ) 2530 call fstr_expand_real_array( P%HEAT%T_FIX_val, old_size, new_size ) 2531 P%HEAT%T_FIX_tot = new_size 2532 2533 head = old_size + 1 2534 member => P%HEAT%T_FIX_node(head:) 2535 id = head 2536 do i = 1, n 2537 !rtc = get_local_member_index( P%MESH, 'node', grp_id_name(i), local_id ) 2538 rtc = get_sorted_local_member_index( P%MESH, P%PARAM, 'node', grp_id_name(i), local_id ) 2539 if( rtc > 0 ) then 2540 member(1) = local_id 2541 member_n = 1 2542 else if( rtc < 0 ) then 2543 member_n = get_grp_member( P%MESH, 'node_grp', grp_id_name(i), member ) 2544 else 2545 cycle 2546 end if 2547 if( i<n ) then 2548 member => member( member_n+1 : ) 2549 endif 2550 do j = 1, member_n 2551 P%HEAT%T_FIX_val (id) = value(i) 2552 P%HEAT%T_FIX_ampl (id) = amp_id 2553 id = id + 1 2554 end do 2555 end do 2556 2557 deallocate( grp_id_name ) 2558 deallocate( value ) 2559 end subroutine fstr_setup_FIXTEMP 2560 2561 2562 !-----------------------------------------------------------------------------! 2563 !> Read in !CFLUX ! 2564 !-----------------------------------------------------------------------------! 2565 2566 subroutine fstr_setup_CFLUX( ctrl, counter, P ) 2567 implicit none 2568 integer(kind=kint) :: ctrl 2569 integer(kind=kint) :: counter 2570 type(fstr_param_pack) :: P 2571 2572 integer(kind=kint) :: rcode 2573 character(HECMW_NAME_LEN) :: amp 2574 integer(kind=kint) :: amp_id 2575 character(HECMW_NAME_LEN), pointer :: grp_id_name(:) 2576 real(kind=kreal),pointer :: value(:) 2577 integer(kind=kint) :: i, j, n, m, head, id, member_n, old_size, new_size 2578 integer(kind=kint),pointer :: member(:) 2579 integer(kind=kint) :: local_id, rtc 2580 ! ------------------------------------------------ 2581 2582 n = fstr_ctrl_get_data_line_n( ctrl ) 2583 if( n == 0 ) return 2584 2585 allocate( grp_id_name(n)) 2586 allocate( value(n)) 2587 2588 amp = ' ' 2589 rcode = fstr_ctrl_get_CFLUX( ctrl, amp, & 2590 grp_id_name, HECMW_NAME_LEN, value ) 2591 if( rcode /= 0 ) call fstr_ctrl_err_stop 2592 2593 call amp_name_to_id( P%MESH, '!CFLUX', amp, amp_id ) 2594 2595 m = 0 2596 2597 do i = 1, n 2598 rtc = get_local_member_index( P%MESH, 'node', grp_id_name(i), local_id ) 2599 if( rtc > 0 ) then 2600 m = m + 1 2601 else if( rtc < 0 ) then 2602 m = m + get_grp_member_n( P%MESH, 'node_grp', grp_id_name(i) ) 2603 end if 2604 end do 2605 2606 if (m == 0) then 2607 deallocate( grp_id_name ) 2608 deallocate( value ) 2609 return 2610 endif 2611 2612 ! JP-9 2613 old_size = P%HEAT%Q_NOD_tot 2614 new_size = old_size + m 2615 call fstr_expand_integer_array( P%HEAT%Q_NOD_node, old_size, new_size ) 2616 call fstr_expand_integer_array( P%HEAT%Q_NOD_ampl, old_size, new_size ) 2617 call fstr_expand_real_array( P%HEAT%Q_NOD_val, old_size, new_size ) 2618 P%HEAT%Q_NOD_tot = new_size 2619 2620 head = old_size + 1 2621 member => P%HEAT%Q_NOD_node(head:) 2622 id = head 2623 do i = 1, n 2624 rtc = get_local_member_index( P%MESH, 'node', grp_id_name(i), local_id ) 2625 if( rtc > 0 ) then 2626 member(1) = local_id 2627 member_n = 1 2628 else if( rtc < 0 ) then 2629 member_n = get_grp_member( P%MESH, 'node_grp', grp_id_name(i), member ) 2630 else 2631 cycle 2632 end if 2633 if( i<n ) member => member( member_n+1 : ) 2634 do j = 1, member_n 2635 P%HEAT%Q_NOD_val (id) = value(i) 2636 P%HEAT%Q_NOD_ampl (id) = amp_id 2637 id = id + 1 2638 end do 2639 end do 2640 2641 deallocate( grp_id_name ) 2642 deallocate( value ) 2643 end subroutine fstr_setup_CFLUX 2644 2645 2646 !-----------------------------------------------------------------------------! 2647 !> Read in !DFLUX ! 2648 !-----------------------------------------------------------------------------! 2649 2650 2651 subroutine fstr_setup_DFLUX( ctrl, counter, P ) 2652 implicit none 2653 integer(kind=kint) :: ctrl 2654 integer(kind=kint) :: counter 2655 type(fstr_param_pack) :: P 2656 2657 integer(kind=kint) :: rcode 2658 character(HECMW_NAME_LEN) :: amp 2659 integer(kind=kint) :: amp_id 2660 character(HECMW_NAME_LEN), pointer :: grp_id_name(:) 2661 integer(kind=kint),pointer :: load_type(:) 2662 real(kind=kreal),pointer :: value(:) 2663 integer(kind=kint) :: i, j, n, m, head, id, member_n, old_size, new_size 2664 integer(kind=kint),pointer :: member(:) 2665 integer(kind=kint) :: local_id, rtc 2666 ! ------------------------------------------------ 2667 2668 n = fstr_ctrl_get_data_line_n( ctrl ) 2669 if( n == 0 ) return 2670 2671 allocate( grp_id_name(n)) 2672 allocate( load_type(n)) 2673 allocate( value(n)) 2674 2675 amp = ' ' 2676 rcode = fstr_ctrl_get_DFLUX( ctrl, amp, & 2677 grp_id_name, HECMW_NAME_LEN, load_type, value ) 2678 if( rcode /= 0 ) call fstr_ctrl_err_stop 2679 2680 call amp_name_to_id( P%MESH, '!DFLUX', amp, amp_id ) 2681 2682 m = 0 2683 do i = 1, n 2684 rtc = get_local_member_index( P%MESH, 'element', grp_id_name(i), local_id ) 2685 if( rtc > 0 ) then 2686 m = m + 1 2687 else if( rtc < 0 ) then 2688 m = m + get_grp_member_n( P%MESH, 'elem_grp', grp_id_name(i) ) 2689 end if 2690 end do 2691 2692 if (m == 0) then 2693 deallocate( grp_id_name ) 2694 deallocate( load_type ) 2695 deallocate( value ) 2696 return 2697 endif 2698 2699 ! JP-10 2700 old_size = P%HEAT%Q_SUF_tot 2701 new_size = old_size + m 2702 call fstr_expand_integer_array( P%HEAT%Q_SUF_elem, old_size, new_size ) 2703 call fstr_expand_integer_array( P%HEAT%Q_SUF_ampl, old_size, new_size ) 2704 call fstr_expand_integer_array( P%HEAT%Q_SUF_surf, old_size, new_size ) 2705 call fstr_expand_real_array( P%HEAT%Q_SUF_val, old_size, new_size ) 2706 P%HEAT%Q_SUF_tot = new_size 2707 2708 head = old_size + 1 2709 member => P%HEAT%Q_SUF_elem(head:) 2710 id = head 2711 do i = 1, n 2712 rtc = get_local_member_index( P%MESH, 'element', grp_id_name(i), local_id ) 2713 if( rtc > 0 ) then 2714 member(1) = local_id 2715 member_n = 1 2716 else if( rtc < 0 ) then 2717 member_n = get_grp_member( P%MESH, 'elem_grp', grp_id_name(i), member ) 2718 else 2719 cycle 2720 end if 2721 if( i<n ) member => member( member_n+1 : ) 2722 do j = 1, member_n 2723 P%HEAT%Q_SUF_surf (id) = load_type(i) 2724 P%HEAT%Q_SUF_val (id) = value(i) 2725 P%HEAT%Q_SUF_ampl (id) = amp_id 2726 id = id + 1 2727 end do 2728 end do 2729 2730 deallocate( grp_id_name ) 2731 deallocate( load_type ) 2732 deallocate( value ) 2733 end subroutine fstr_setup_DFLUX 2734 2735 2736 !-----------------------------------------------------------------------------! 2737 !> Read in !SFLUX ! 2738 !-----------------------------------------------------------------------------! 2739 2740 2741 subroutine fstr_setup_SFLUX( ctrl, counter, P ) 2742 implicit none 2743 integer(kind=kint) :: ctrl 2744 integer(kind=kint) :: counter 2745 type(fstr_param_pack) :: P 2746 2747 integer(kind=kint) :: rcode 2748 character(HECMW_NAME_LEN) :: amp 2749 integer(kind=kint) :: amp_id 2750 character(HECMW_NAME_LEN), pointer :: grp_id_name(:) 2751 real(kind=kreal),pointer :: value(:) 2752 integer(kind=kint) :: i, j, n, m, head, id, member_n, old_size, new_size 2753 integer(kind=kint),pointer :: member1(:), member2(:) 2754 ! ------------------------------------------------ 2755 2756 n = fstr_ctrl_get_data_line_n( ctrl ) 2757 if( n == 0 ) return 2758 2759 allocate( grp_id_name(n)) 2760 allocate( value(n)) 2761 2762 amp = ' ' 2763 rcode = fstr_ctrl_get_SFLUX( ctrl, amp, & 2764 grp_id_name, HECMW_NAME_LEN, value ) 2765 if( rcode /= 0 ) call fstr_ctrl_err_stop 2766 2767 call amp_name_to_id( P%MESH, '!SFLUX', amp, amp_id ) 2768 2769 m = 0 2770 do i = 1, n 2771 m = m + get_grp_member_n( P%MESH, 'surf_grp', grp_id_name(i) ) 2772 end do 2773 2774 if (m == 0) then 2775 deallocate( grp_id_name ) 2776 deallocate( value ) 2777 return 2778 endif 2779 2780 ! JP-11 2781 old_size = P%HEAT%Q_SUF_tot 2782 new_size = old_size + m 2783 call fstr_expand_integer_array( P%HEAT%Q_SUF_elem, old_size, new_size ) 2784 call fstr_expand_integer_array( P%HEAT%Q_SUF_ampl, old_size, new_size ) 2785 call fstr_expand_integer_array( P%HEAT%Q_SUF_surf, old_size, new_size ) 2786 call fstr_expand_real_array( P%HEAT%Q_SUF_val, old_size, new_size ) 2787 P%HEAT%Q_SUF_tot = new_size 2788 2789 head = old_size + 1 2790 member1 => P%HEAT%Q_SUF_elem(head:) 2791 member2 => P%HEAT%Q_SUF_surf(head:) 2792 id = head 2793 do i = 1, n 2794 member_n = get_grp_member( P%MESH, 'surf_grp', grp_id_name(i), member1, member2 ) 2795 if( i<n ) then 2796 member1 => member1( member_n+1 : ) 2797 member2 => member2( member_n+1 : ) 2798 end if 2799 do j = 1, member_n 2800 P%HEAT%Q_SUF_val (id) = value(i) 2801 P%HEAT%Q_SUF_ampl (id) = amp_id 2802 id = id + 1 2803 end do 2804 end do 2805 2806 deallocate( grp_id_name ) 2807 deallocate( value ) 2808 end subroutine fstr_setup_SFLUX 2809 2810 2811 !-----------------------------------------------------------------------------! 2812 !> Read in !FILM ! 2813 !-----------------------------------------------------------------------------! 2814 2815 2816 subroutine fstr_setup_FILM( ctrl, counter, P ) 2817 implicit none 2818 integer(kind=kint) :: ctrl 2819 integer(kind=kint) :: counter 2820 type(fstr_param_pack) :: P 2821 2822 integer(kind=kint) :: rcode 2823 character(HECMW_NAME_LEN) :: amp1, amp2 2824 integer(kind=kint) :: amp_id1, amp_id2 2825 character(HECMW_NAME_LEN), pointer :: grp_id_name(:) 2826 integer(kind=kint),pointer :: load_type(:) 2827 real(kind=kreal),pointer :: value(:) 2828 real(kind=kreal),pointer :: shink(:) 2829 integer(kind=kint) :: i, j, n, m, head, id, member_n, old_size, new_size 2830 integer(kind=kint),pointer :: member(:) 2831 integer(kind=kint) :: local_id, rtc 2832 ! ------------------------------------------------ 2833 2834 n = fstr_ctrl_get_data_line_n( ctrl ) 2835 if( n == 0 ) return 2836 2837 allocate( grp_id_name(n)) 2838 allocate( load_type(n)) 2839 allocate( value(n)) 2840 allocate( shink(n)) 2841 2842 amp1 = ' ' 2843 amp2 = ' ' 2844 2845 rcode = fstr_ctrl_get_FILM( ctrl, amp1, amp2, & 2846 grp_id_name, HECMW_NAME_LEN, load_type, value, shink ) 2847 if( rcode /= 0 ) call fstr_ctrl_err_stop 2848 2849 call amp_name_to_id( P%MESH, '!FILM', amp1, amp_id1 ) 2850 call amp_name_to_id( P%MESH, '!FILM', amp2, amp_id2 ) 2851 2852 m = 0 2853 do i = 1, n 2854 rtc = get_local_member_index( P%MESH, 'element', grp_id_name(i), local_id ) 2855 if( rtc > 0 ) then 2856 m = m + 1 2857 else if( rtc < 0 ) then 2858 m = m + get_grp_member_n( P%MESH, 'elem_grp', grp_id_name(i) ) 2859 end if 2860 end do 2861 2862 if (m == 0) then 2863 deallocate( grp_id_name ) 2864 deallocate( load_type ) 2865 deallocate( value ) 2866 deallocate( shink ) 2867 return 2868 endif 2869 2870 ! JP-12 2871 old_size = P%HEAT%H_SUF_tot 2872 new_size = old_size + m 2873 call fstr_expand_integer_array( P%HEAT%H_SUF_elem, old_size, new_size ) 2874 call fstr_expand_integer_array2( P%HEAT%H_SUF_ampl, 2, old_size, new_size ) 2875 call fstr_expand_integer_array( P%HEAT%H_SUF_surf, old_size, new_size ) 2876 call fstr_expand_real_array2( P%HEAT%H_SUF_val, 2, old_size, new_size ) 2877 P%HEAT%H_SUF_tot = new_size 2878 2879 head = old_size + 1 2880 member => P%HEAT%H_SUF_elem(head:) 2881 id = head 2882 do i = 1, n 2883 rtc = get_local_member_index( P%MESH, 'element', grp_id_name(i), local_id ) 2884 if( rtc > 0 ) then 2885 member(1) = local_id 2886 member_n = 1 2887 else if( rtc < 0 ) then 2888 member_n = get_grp_member( P%MESH, 'elem_grp', grp_id_name(i), member ) 2889 else 2890 cycle 2891 end if 2892 if( i<n ) member => member( member_n+1 : ) 2893 do j = 1, member_n 2894 P%HEAT%H_SUF_surf (id) = load_type(i) 2895 P%HEAT%H_SUF_val (id,1) = value(i) 2896 P%HEAT%H_SUF_val (id,2) = shink(i) 2897 P%HEAT%H_SUF_ampl (id,1) = amp_id1 2898 P%HEAT%H_SUF_ampl (id,2) = amp_id2 2899 id= id + 1 2900 end do 2901 end do 2902 2903 deallocate( grp_id_name ) 2904 deallocate( load_type ) 2905 deallocate( value ) 2906 deallocate( shink ) 2907 end subroutine fstr_setup_FILM 2908 2909 2910 !-----------------------------------------------------------------------------! 2911 !> Read in !SFILM ! 2912 !-----------------------------------------------------------------------------! 2913 2914 2915 subroutine fstr_setup_SFILM( ctrl, counter, P ) 2916 implicit none 2917 integer(kind=kint) :: ctrl 2918 integer(kind=kint) :: counter 2919 type(fstr_param_pack) :: P 2920 2921 integer(kind=kint) :: rcode 2922 character(HECMW_NAME_LEN) :: amp1, amp2 2923 integer(kind=kint) :: amp_id1, amp_id2 2924 character(HECMW_NAME_LEN), pointer :: grp_id_name(:) 2925 real(kind=kreal),pointer :: value(:) 2926 real(kind=kreal),pointer :: shink(:) 2927 integer(kind=kint) :: i, j, n, m, head, id, member_n, old_size, new_size 2928 integer(kind=kint),pointer :: member1(:), member2(:) 2929 ! ------------------------------------------------ 2930 2931 n = fstr_ctrl_get_data_line_n( ctrl ) 2932 if( n == 0 ) return 2933 2934 allocate( grp_id_name(n)) 2935 allocate( value(n)) 2936 allocate( shink(n)) 2937 2938 amp1 = ' ' 2939 amp2 = ' ' 2940 rcode = fstr_ctrl_get_SFILM( ctrl, amp1, amp2, & 2941 grp_id_name, HECMW_NAME_LEN, value, shink ) 2942 if( rcode /= 0 ) call fstr_ctrl_err_stop 2943 2944 call amp_name_to_id( P%MESH, '!SFILM', amp1, amp_id1 ) 2945 call amp_name_to_id( P%MESH, '!SFILM', amp2, amp_id2 ) 2946 2947 m = 0 2948 do i = 1, n 2949 m = m + get_grp_member_n( P%MESH, 'surf_grp', grp_id_name(i) ) 2950 end do 2951 2952 if (m == 0) then 2953 deallocate( grp_id_name ) 2954 deallocate( value ) 2955 deallocate( shink ) 2956 return 2957 endif 2958 2959 ! JP-13 2960 old_size = P%HEAT%H_SUF_tot 2961 new_size = old_size + m 2962 call fstr_expand_integer_array( P%HEAT%H_SUF_elem, old_size, new_size ) 2963 call fstr_expand_integer_array2( P%HEAT%H_SUF_ampl, 2, old_size, new_size ) 2964 call fstr_expand_integer_array( P%HEAT%H_SUF_surf, old_size, new_size ) 2965 call fstr_expand_real_array2( P%HEAT%H_SUF_val, 2, old_size, new_size ) 2966 P%HEAT%H_SUF_tot = new_size 2967 2968 head = old_size + 1 2969 member1 => P%HEAT%H_SUF_elem(head:) 2970 member2 => P%HEAT%H_SUF_surf(head:) 2971 id = head 2972 do i = 1, n 2973 member_n = get_grp_member( P%MESH, 'surf_grp', grp_id_name(i), member1, member2 ) 2974 if( i<n ) then 2975 member1 => member1( member_n+1 : ) 2976 member2 => member2( member_n+1 : ) 2977 end if 2978 do j = 1, member_n 2979 P%HEAT%H_SUF_val (id,1) = value(i) 2980 P%HEAT%H_SUF_val (id,2) = shink(i) 2981 P%HEAT%H_SUF_ampl (id,1) = amp_id1 2982 P%HEAT%H_SUF_ampl (id,2) = amp_id2 2983 id = id + 1 2984 end do 2985 end do 2986 2987 deallocate( grp_id_name ) 2988 deallocate( value ) 2989 deallocate( shink ) 2990 end subroutine fstr_setup_SFILM 2991 2992 2993 !-----------------------------------------------------------------------------! 2994 !> Read in !RADIATE ! 2995 !-----------------------------------------------------------------------------! 2996 2997 2998 subroutine fstr_setup_RADIATE( ctrl, counter, P ) 2999 implicit none 3000 integer(kind=kint) :: ctrl 3001 integer(kind=kint) :: counter 3002 type(fstr_param_pack) :: P 3003 3004 integer(kind=kint) :: rcode 3005 character(HECMW_NAME_LEN) :: amp1, amp2 3006 integer(kind=kint) :: amp_id1, amp_id2 3007 character(HECMW_NAME_LEN), pointer :: grp_id_name(:) 3008 integer(kind=kint),pointer :: load_type(:) 3009 real(kind=kreal),pointer :: value(:) 3010 real(kind=kreal),pointer :: shink(:) 3011 integer(kind=kint) :: i, j, n, m, head, id, member_n, old_size, new_size 3012 integer(kind=kint),pointer :: member(:) 3013 integer(kind=kint) :: local_id, rtc 3014 ! ------------------------------------------------ 3015 3016 n = fstr_ctrl_get_data_line_n( ctrl ) 3017 if( n == 0 ) return 3018 3019 allocate( grp_id_name(n)) 3020 allocate( load_type(n)) 3021 allocate( value(n)) 3022 allocate( shink(n)) 3023 3024 amp1 = ' ' 3025 amp2 = ' ' 3026 rcode = fstr_ctrl_get_RADIATE( ctrl, amp1, amp2, & 3027 grp_id_name, HECMW_NAME_LEN, load_type, value, shink ) 3028 if( rcode /= 0 ) call fstr_ctrl_err_stop 3029 3030 call amp_name_to_id( P%MESH, '!RADIATE', amp1, amp_id1 ) 3031 call amp_name_to_id( P%MESH, '!RADIATE', amp2, amp_id2 ) 3032 3033 m = 0 3034 do i = 1, n 3035 rtc = get_local_member_index( P%MESH, 'element', grp_id_name(i), local_id ) 3036 if( rtc > 0 ) then 3037 m = m + 1 3038 else if( rtc < 0 ) then 3039 m = m + get_grp_member_n( P%MESH, 'elem_grp', grp_id_name(i) ) 3040 end if 3041 end do 3042 3043 if (m == 0) then 3044 deallocate( grp_id_name ) 3045 deallocate( load_type ) 3046 deallocate( value ) 3047 deallocate( shink ) 3048 return 3049 endif 3050 3051 ! JP-14 3052 old_size = P%HEAT%R_SUF_tot 3053 new_size = old_size + m 3054 call fstr_expand_integer_array( P%HEAT%R_SUF_elem, old_size, new_size ) 3055 call fstr_expand_integer_array2( P%HEAT%R_SUF_ampl, 2, old_size, new_size ) 3056 call fstr_expand_integer_array( P%HEAT%R_SUF_surf, old_size, new_size ) 3057 call fstr_expand_real_array2( P%HEAT%R_SUF_val, 2, old_size, new_size ) 3058 P%HEAT%R_SUF_tot = new_size 3059 3060 head = old_size + 1 3061 member => P%HEAT%R_SUF_elem(head:) 3062 id = head 3063 do i = 1, n 3064 rtc = get_local_member_index( P%MESH, 'element', grp_id_name(i), local_id ) 3065 if( rtc > 0 ) then 3066 member(1) = local_id 3067 member_n = 1 3068 else if( rtc < 0 ) then 3069 member_n = get_grp_member( P%MESH, 'elem_grp', grp_id_name(i), member ) 3070 else 3071 cycle 3072 end if 3073 if( i<n ) member => member( member_n+1 : ) 3074 do j = 1, member_n 3075 P%HEAT%R_SUF_surf (id) = load_type(i) 3076 P%HEAT%R_SUF_val (id,1) = value(i) 3077 P%HEAT%R_SUF_val (id,2) = shink(i) 3078 P%HEAT%R_SUF_ampl (id,1) = amp_id1 3079 P%HEAT%R_SUF_ampl (id,2) = amp_id2 3080 id = id + 1 3081 end do 3082 end do 3083 3084 deallocate( grp_id_name ) 3085 deallocate( load_type ) 3086 deallocate( value ) 3087 deallocate( shink ) 3088 end subroutine fstr_setup_RADIATE 3089 3090 3091 !-----------------------------------------------------------------------------! 3092 !> Read in !SRADIATE ! 3093 !-----------------------------------------------------------------------------! 3094 3095 3096 subroutine fstr_setup_SRADIATE( ctrl, counter, P ) 3097 implicit none 3098 integer(kind=kint) :: ctrl 3099 integer(kind=kint) :: counter 3100 type(fstr_param_pack) :: P 3101 3102 integer(kind=kint) :: rcode 3103 character(HECMW_NAME_LEN) :: amp1, amp2 3104 integer(kind=kint) :: amp_id1, amp_id2 3105 character(HECMW_NAME_LEN), pointer :: grp_id_name(:) 3106 real(kind=kreal),pointer :: value(:) 3107 real(kind=kreal),pointer :: shink(:) 3108 integer(kind=kint) :: i, j, n, m, head, id, member_n, old_size, new_size 3109 integer(kind=kint),pointer :: member1(:), member2(:) 3110 ! ------------------------------------------------ 3111 3112 n = fstr_ctrl_get_data_line_n( ctrl ) 3113 if( n == 0 ) return 3114 3115 allocate( grp_id_name(n)) 3116 allocate( value(n)) 3117 allocate( shink(n)) 3118 3119 amp1 = ' ' 3120 amp2 = ' ' 3121 rcode = fstr_ctrl_get_SRADIATE( ctrl, amp1, amp2, grp_id_name, HECMW_NAME_LEN, value, shink ) 3122 if( rcode /= 0 ) call fstr_ctrl_err_stop 3123 3124 call amp_name_to_id( P%MESH, '!SRADIATE', amp1, amp_id1 ) 3125 call amp_name_to_id( P%MESH, '!SRADIATE', amp2, amp_id2 ) 3126 3127 m = 0 3128 do i = 1, n 3129 m = m + get_grp_member_n( P%MESH, 'surf_grp', grp_id_name(i) ) 3130 end do 3131 3132 if (m == 0) then 3133 deallocate( grp_id_name ) 3134 deallocate( value ) 3135 deallocate( shink ) 3136 return 3137 endif 3138 3139 ! JP-15 3140 old_size = P%HEAT%R_SUF_tot 3141 new_size = old_size + m 3142 call fstr_expand_integer_array( P%HEAT%R_SUF_elem, old_size, new_size ) 3143 call fstr_expand_integer_array2( P%HEAT%R_SUF_ampl, 2, old_size, new_size ) 3144 call fstr_expand_integer_array( P%HEAT%R_SUF_surf, old_size, new_size ) 3145 call fstr_expand_real_array2( P%HEAT%R_SUF_val, 2, old_size, new_size ) 3146 P%HEAT%R_SUF_tot = new_size 3147 3148 head = old_size + 1 3149 member1 => P%HEAT%R_SUF_elem(head:) 3150 member2 => P%HEAT%R_SUF_surf(head:) 3151 id = head 3152 do i = 1, n 3153 member_n = get_grp_member( P%MESH, 'surf_grp', grp_id_name(i), member1, member2 ) 3154 if( i<n ) then 3155 member1 => member1( member_n+1 : ) 3156 member2 => member2( member_n+1 : ) 3157 end if 3158 do j = 1, member_n 3159 P%HEAT%R_SUF_val (id,1) = value(i) 3160 P%HEAT%R_SUF_val (id,2) = shink(i) 3161 P%HEAT%R_SUF_ampl (id,1) = amp_id1 3162 P%HEAT%R_SUF_ampl (id,2) = amp_id2 3163 id = id + 1 3164 end do 3165 end do 3166 3167 deallocate( grp_id_name ) 3168 deallocate( value ) 3169 deallocate( shink ) 3170 end subroutine fstr_setup_SRADIATE 3171 3172 3173 !*****************************************************************************! 3174 !* HEADERS FOR EIGEN ANALYSIS ************************************************! 3175 !*****************************************************************************! 3176 3177 !-----------------------------------------------------------------------------! 3178 !> Read in !EIGEN ! 3179 !-----------------------------------------------------------------------------! 3180 3181 subroutine fstr_setup_EIGEN( ctrl, counter, P ) 3182 implicit none 3183 integer(kind=kint) :: ctrl 3184 integer(kind=kint) :: counter 3185 type(fstr_param_pack) :: P 3186 3187 integer(kind=kint) :: rcode 3188 3189 rcode = fstr_ctrl_get_EIGEN( ctrl, P%EIGEN%nget, P%EIGEN%tolerance, P%EIGEN%maxiter) 3190 if( rcode /= 0) call fstr_ctrl_err_stop 3191 3192 end subroutine fstr_setup_EIGEN 3193 3194 3195 !*****************************************************************************! 3196 !* HEADERS FOR DYNAMIC ANALYSIS **********************************************! 3197 !*****************************************************************************! 3198 3199 !-----------------------------------------------------------------------------! 3200 !> Read in !DYNAMIC ! 3201 !-----------------------------------------------------------------------------! 3202 3203 subroutine fstr_setup_DYNAMIC( ctrl, counter, P ) 3204 implicit none 3205 integer(kind=kint) :: ctrl 3206 integer(kind=kint) :: counter 3207 type(fstr_param_pack) :: P 3208 integer(kind=kint) :: rcode 3209 character(HECMW_NAME_LEN) :: grp_id_name(1) 3210 integer(kind=kint) :: grp_id(1) 3211 3212 rcode = fstr_ctrl_get_DYNAMIC( ctrl, & 3213 P%PARAM%nlgeom, & 3214 P%DYN%idx_eqa, & 3215 P%DYN%idx_resp,& 3216 P%DYN%n_step, & 3217 P%DYN%t_start, & 3218 P%DYN%t_end, & 3219 P%DYN%t_delta, & 3220 P%DYN%ganma, & 3221 P%DYN%beta, & 3222 P%DYN%idx_mas, & 3223 P%DYN%idx_dmp, & 3224 P%DYN%ray_m, & 3225 P%DYN%ray_k, & 3226 P%DYN%nout, & 3227 grp_id_name(1), HECMW_NAME_LEN, & 3228 P%DYN%nout_monit, & 3229 P%DYN%iout_list ) 3230 3231 if( rcode /= 0) call fstr_ctrl_err_stop 3232 3233 if (P%DYN%idx_resp == 1) then 3234 call node_grp_name_to_id_ex( P%MESH, '!DYNAMIC', 1, grp_id_name, grp_id) 3235 P%DYN%ngrp_monit = grp_id(1) 3236 else 3237 read(grp_id_name,*) P%DYN%ngrp_monit 3238 endif 3239 3240 end subroutine fstr_setup_DYNAMIC 3241 3242 3243 !-----------------------------------------------------------------------------! 3244 !> Read in !VELOCITY ! 3245 !-----------------------------------------------------------------------------! 3246 3247 subroutine fstr_setup_VELOCITY( ctrl, counter, P ) 3248 implicit none 3249 integer(kind=kint) :: ctrl 3250 integer(kind=kint) :: counter 3251 type(fstr_param_pack) :: P 3252 3253 integer(kind=kint) :: rcode 3254 integer(kind=kint) :: vType 3255 character(HECMW_NAME_LEN) :: amp 3256 integer(kind=kint) :: amp_id 3257 character(HECMW_NAME_LEN), pointer :: grp_id_name(:) 3258 integer(kind=kint),pointer :: dof_ids (:) 3259 integer(kind=kint),pointer :: dof_ide (:) 3260 real(kind=kreal),pointer :: val_ptr(:) 3261 integer(kind=kint) :: i, j, n, old_size, new_size 3262 3263 n = fstr_ctrl_get_data_line_n( ctrl ) 3264 if( n == 0 ) return 3265 old_size = P%SOLID%VELOCITY_ngrp_tot 3266 new_size = old_size + n 3267 P%SOLID%VELOCITY_ngrp_tot = new_size 3268 3269 call fstr_expand_integer_array (P%SOLID%VELOCITY_ngrp_ID , old_size, new_size ) 3270 call fstr_expand_integer_array (P%SOLID%VELOCITY_ngrp_type, old_size, new_size ) 3271 call fstr_expand_real_array (P%SOLID%VELOCITY_ngrp_val , old_size, new_size ) 3272 call fstr_expand_integer_array (P%SOLID%VELOCITY_ngrp_amp , old_size, new_size ) 3273 3274 allocate( grp_id_name(n)) 3275 allocate( dof_ids (n)) 3276 allocate( dof_ide (n)) 3277 3278 amp = '' 3279 val_ptr => P%SOLID%VELOCITY_ngrp_val(old_size+1:) 3280 val_ptr = 0 3281 rcode = fstr_ctrl_get_VELOCITY( ctrl, vType, amp, & 3282 grp_id_name, HECMW_NAME_LEN, & 3283 dof_ids, dof_ide, val_ptr ) 3284 if( rcode /= 0 ) call fstr_ctrl_err_stop 3285 P%SOLID%VELOCITY_type = vType 3286 if( vType == kbcInitial ) P%DYN%VarInitialize = .true. 3287 call amp_name_to_id( P%MESH, '!VELOCITY', amp, amp_id ) 3288 call node_grp_name_to_id_ex( P%MESH, '!VELOCITY', & 3289 n, grp_id_name, P%SOLID%VELOCITY_ngrp_ID(old_size+1:)) 3290 3291 j = old_size+1 3292 do i = 1, n 3293 if( (dof_ids(i) < 1).or.(6 < dof_ids(i)).or.(dof_ide(i) < 1).or.(6 < dof_ide(i)) ) then 3294 write(ILOG,*) 'fstr contol file error : !VELOCITY : range of dof_ids and dof_ide is from 1 to 6' 3295 stop 3296 end if 3297 P%SOLID%VELOCITY_ngrp_type(j) = 10 * dof_ids(i) + dof_ide(i) 3298 P%SOLID%VELOCITY_ngrp_amp(j) = amp_id 3299 j = j+1 3300 end do 3301 3302 deallocate( grp_id_name ) 3303 deallocate( dof_ids ) 3304 deallocate( dof_ide ) 3305 3306 end subroutine fstr_setup_VELOCITY 3307 3308 3309 !-----------------------------------------------------------------------------! 3310 !> Read in !ACCELERATION ! 3311 !-----------------------------------------------------------------------------! 3312 3313 subroutine fstr_setup_ACCELERATION( ctrl, counter, P ) 3314 implicit none 3315 integer(kind=kint) :: ctrl 3316 integer(kind=kint) :: counter 3317 type(fstr_param_pack) :: P 3318 3319 integer(kind=kint) :: rcode 3320 integer(kind=kint) :: aType 3321 character(HECMW_NAME_LEN) :: amp 3322 integer(kind=kint) :: amp_id 3323 character(HECMW_NAME_LEN), pointer :: grp_id_name(:) 3324 integer(kind=kint),pointer :: dof_ids (:) 3325 integer(kind=kint),pointer :: dof_ide (:) 3326 real(kind=kreal),pointer :: val_ptr(:) 3327 integer(kind=kint) :: i, j, n, old_size, new_size 3328 3329 3330 n = fstr_ctrl_get_data_line_n( ctrl ) 3331 if( n == 0 ) return 3332 old_size = P%SOLID%ACCELERATION_ngrp_tot 3333 new_size = old_size + n 3334 P%SOLID%ACCELERATION_ngrp_tot = new_size 3335 3336 call fstr_expand_integer_array (P%SOLID%ACCELERATION_ngrp_ID , old_size, new_size ) 3337 call fstr_expand_integer_array (P%SOLID%ACCELERATION_ngrp_type, old_size, new_size ) 3338 call fstr_expand_real_array (P%SOLID%ACCELERATION_ngrp_val , old_size, new_size ) 3339 call fstr_expand_integer_array (P%SOLID%ACCELERATION_ngrp_amp , old_size, new_size ) 3340 3341 allocate( grp_id_name(n)) 3342 allocate( dof_ids (n)) 3343 allocate( dof_ide (n)) 3344 3345 amp = ' ' 3346 val_ptr => P%SOLID%ACCELERATION_ngrp_val(old_size+1:) 3347 val_ptr = 0 3348 rcode = fstr_ctrl_get_ACCELERATION( ctrl, aType, amp, & 3349 grp_id_name, HECMW_NAME_LEN, & 3350 dof_ids, dof_ide, val_ptr) 3351 if( rcode /= 0 ) call fstr_ctrl_err_stop 3352 P%SOLID%ACCELERATION_type = aType 3353 if( aType == kbcInitial )P%DYN%VarInitialize = .true. 3354 call amp_name_to_id( P%MESH, '!ACCELERATION', amp, amp_id ) 3355 call node_grp_name_to_id_ex( P%MESH, '!ACCELERATION', & 3356 n, grp_id_name, P%SOLID%ACCELERATION_ngrp_ID(old_size+1:)) 3357 3358 j = old_size+1 3359 do i = 1, n 3360 if( (dof_ids(i) < 1).or.(6 < dof_ids(i)).or.(dof_ide(i) < 1).or.(6 < dof_ide(i)) ) then 3361 write(ILOG,*) 'fstr contol file error : !ACCELERATION : range of dof_ids and dof_ide is from 1 to 6' 3362 stop 3363 end if 3364 P%SOLID%ACCELERATION_ngrp_type(j) = 10 * dof_ids(i) + dof_ide(i) 3365 P%SOLID%ACCELERATION_ngrp_amp(j) = amp_id 3366 j = j+1 3367 end do 3368 3369 deallocate( grp_id_name ) 3370 deallocate( dof_ids ) 3371 deallocate( dof_ide ) 3372 end subroutine fstr_setup_ACCELERATION 3373 3374 3375 !*****************************************************************************! 3376 !* MPC ***********************************************************************! 3377 !*****************************************************************************! 3378 3379 !-----------------------------------------------------------------------------! 3380 !> Read in !MPC ! 3381 !-----------------------------------------------------------------------------! 3382 3383 subroutine fstr_setup_MPC( ctrl, counter, P ) 3384 implicit none 3385 integer(kind=kint) :: ctrl 3386 integer(kind=kint) :: counter 3387 type(fstr_param_pack), target :: P 3388 3389 integer(kind=kint) :: rcode 3390 ! integer(kind=kint) :: type 3391 ! integer(kind=kint),pointer :: node1_ptr(:) 3392 ! integer(kind=kint),pointer :: node2_ptr(:) 3393 ! integer(kind=kint),pointer :: dof_ptr(:) 3394 ! integer(kind=kint) :: n, old_size, new_size 3395 ! 3396 ! rcode = fstr_ctrl_get_param_ex( ctrl, 'TYPE ', 'RIGID ', 1, 'P', type ) 3397 ! if( rcode < 0 ) call fstr_ctrl_err_stop 3398 ! 3399 ! n = fstr_ctrl_get_data_line_n( ctrl ) 3400 ! if( n == 0 ) return 3401 ! old_size = P%MPC_RD%nmpc 3402 ! new_size = old_size + n 3403 ! P%MPC_RD%nmpc = new_size 3404 ! 3405 ! call fstr_expand_integer_array ( P%MPC_RD%node1, old_size, new_size ) 3406 ! call fstr_expand_integer_array ( P%MPC_RD%node2, old_size, new_size ) 3407 ! call fstr_expand_integer_array ( P%MPC_RD%dof, old_size, new_size ) 3408 ! 3409 ! node1_ptr => P%MPC_RD%node1(old_size+1:) 3410 ! node2_ptr => P%MPC_RD%node2(old_size+1:) 3411 ! dof_ptr => P%MPC_RD%dof(old_size+1:) 3412 ! 3413 ! rcode = fstr_ctrl_get_MPC( ctrl, type, node1_ptr, node2_ptr, dof_ptr ) 3414 ! if( rcode /= 0 ) call fstr_ctrl_err_stop 3415 ! 3416 ! if( node_global_to_local( P%MESH, node1_ptr, n ) /= n ) then 3417 ! call fstr_setup_util_err_stop( '### Error : not exist node (!MPC)' ) 3418 ! endif 3419 ! if( node_global_to_local( P%MESH, node2_ptr, n ) /= n ) then 3420 ! call fstr_setup_util_err_stop( '### Error : not exist node (!MPC)' ) 3421 ! endif 3422 3423 ! penalty => svRarray(11) 3424 rcode = fstr_ctrl_get_MPC( ctrl, svRarray(11)) 3425 if( rcode /= 0) call fstr_ctrl_err_stop 3426 end subroutine fstr_setup_MPC 3427 3428 3429 !*****************************************************************************! 3430 !* IMPORTING NASTRAN BOUNDARY CONDITIONS *************************************! 3431 !*****************************************************************************! 3432 3433 subroutine fstr_setup_solid_nastran( ctrl, hecMESH, fstrSOLID ) 3434 implicit none 3435 integer(kind=kint) :: ctrl 3436 type (hecmwST_local_mesh) :: hecMESH 3437 type (fstr_solid ) :: fstrSOLID 3438 write(ILOG,*) '### Error : In !BOUNNDARY, TYPE=NASTRAN is not supported.' 3439 call hecmw_abort( hecmw_comm_get_comm()) 3440 end subroutine fstr_setup_solid_nastran 3441 3442 !-----------------------------------------------------------------------------! 3443 !> Read in !CONTACT ! 3444 !-----------------------------------------------------------------------------! 3445 3446 subroutine fstr_setup_CONTACTALGO( ctrl, P ) 3447 implicit none 3448 integer(kind=kint) :: ctrl 3449 ! integer(kind=kint) :: counter 3450 type(fstr_param_pack) :: P 3451 3452 integer(kind=kint) :: rcode 3453 3454 3455 rcode = fstr_ctrl_get_CONTACTALGO( ctrl, P%PARAM%contact_algo ) 3456 if( rcode /= 0 ) call fstr_ctrl_err_stop 3457 3458 end subroutine fstr_setup_CONTACTALGO 3459 3460 !-----------------------------------------------------------------------------! 3461 !> Read in !OUTPUT_SSTYPE ! 3462 !-----------------------------------------------------------------------------! 3463 3464 subroutine fstr_setup_OUTPUT_SSTYPE( ctrl, P ) 3465 implicit none 3466 integer(kind=kint) :: ctrl 3467 type(fstr_param_pack) :: P 3468 3469 integer(kind=kint) :: rcode, nid 3470 character(len=HECMW_NAME_LEN) :: data_fmt 3471 3472 data_fmt = 'SOLUTION,MATERIAL ' 3473 rcode = fstr_ctrl_get_param_ex( ctrl, 'TYPE ', data_fmt, 0, 'P', nid ) 3474 OPSSTYPE = nid 3475 if( rcode /= 0 ) call fstr_ctrl_err_stop 3476 3477 end subroutine fstr_setup_OUTPUT_SSTYPE 3478 3479 !-----------------------------------------------------------------------------! 3480 !> Convert SURF-SURF contact to NODE-SURF contact ! 3481 !-----------------------------------------------------------------------------! 3482 3483 subroutine fstr_convert_contact_type( hecMESH ) 3484 implicit none 3485 type(hecmwST_local_mesh), pointer :: hecMESH !< mesh definition 3486 integer(kind=kint) :: n, i, sgrp_id, ngrp_id, ngrp_id2 3487 ! convert SURF_SURF to NODE_SURF 3488 n = hecMESH%contact_pair%n_pair 3489 do i = 1,n 3490 if( hecMESH%contact_pair%type(i) /= HECMW_CONTACT_TYPE_SURF_SURF ) cycle 3491 sgrp_id = hecMESH%contact_pair%slave_grp_id(i) 3492 call append_node_grp_from_surf_grp( hecMESH, sgrp_id, ngrp_id ) 3493 ! change type of contact and slave group ID 3494 hecMESH%contact_pair%type(i) = HECMW_CONTACT_TYPE_NODE_SURF 3495 hecMESH%contact_pair%slave_grp_id(i) = ngrp_id 3496 ! ! for DEBUG 3497 ! sgrp_id = hecMESH%contact_pair%master_grp_id(i) 3498 ! call append_node_grp_from_surf_grp( hecMESH, sgrp_id, ngrp_id2 ) 3499 ! ! intersection node group of slave and master 3500 ! call append_intersection_node_grp( hecMESH, ngrp_id, ngrp_id2 ) 3501 ! ! intersection node_group of original slave and patch-slave 3502 ! ngrp_id=get_grp_id( hecMESH, 'node_grp', 'SLAVE' ) 3503 ! ngrp_id2=get_grp_id( hecMESH, 'node_grp', '_PT_SLAVE_S' ) 3504 ! call append_intersection_node_grp( hecMESH, ngrp_id, ngrp_id2 ) 3505 enddo 3506 end subroutine fstr_convert_contact_type 3507 3508end module m_fstr_setup 3509