FrontISTR 5.2.0
Large-scale structural analysis program with finit element method
Loading...
Searching...
No Matches
fstr_setup.f90
Go to the documentation of this file.
1!-------------------------------------------------------------------------------
2! Copyright (c) 2019 FrontISTR Commons
3! This software is released under the MIT License, see LICENSE.txt
4!-------------------------------------------------------------------------------
8 use m_fstr
16 use mcontact
18 use m_out
19 use m_step
20 use m_utilities
21 implicit none
22
23 include 'fstr_ctrl_util_f.inc'
24
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 !=============================================================================!
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
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
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
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
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
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
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
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
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
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
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
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 !-----------------------------------------------------------------------------!
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 !-----------------------------------------------------------------------------!
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 !-----------------------------------------------------------------------------!
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 !* ----------------------------------------------------------------------------------------------- *!
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
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
1754 end function fstr_setup_orientation
1755
1756
1757 !-----------------------------------------------------------------------------!
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
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 '
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 '
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 !-----------------------------------------------------------------------------!
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 !-----------------------------------------------------------------------------!
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 !-----------------------------------------------------------------------------!
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 !-----------------------------------------------------------------------------!
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 !-----------------------------------------------------------------------------!
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 !-----------------------------------------------------------------------------!
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'
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 !-----------------------------------------------------------------------------!
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 !-----------------------------------------------------------------------------!
2175 !-----------------------------------------------------------------------------!
2176 include 'fstr_ctrl_freq.f90'
2177
2178 !-----------------------------------------------------------------------------!
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
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 !-----------------------------------------------------------------------------!
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 !-----------------------------------------------------------------------------!
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 !-----------------------------------------------------------------------------!
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 !-----------------------------------------------------------------------------!
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
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 !-----------------------------------------------------------------------------!
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 !-----------------------------------------------------------------------------!
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 !-----------------------------------------------------------------------------!
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 !-----------------------------------------------------------------------------!
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 !-----------------------------------------------------------------------------!
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 !-----------------------------------------------------------------------------!
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 !-----------------------------------------------------------------------------!
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 !-----------------------------------------------------------------------------!
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 !-----------------------------------------------------------------------------!
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 !-----------------------------------------------------------------------------!
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 !-----------------------------------------------------------------------------!
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 !-----------------------------------------------------------------------------!
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 !-----------------------------------------------------------------------------!
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 !-----------------------------------------------------------------------------!
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 !-----------------------------------------------------------------------------!
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 !-----------------------------------------------------------------------------!
3481 !-----------------------------------------------------------------------------!
3482
3483 subroutine fstr_convert_contact_type( hecMESH )
3484 implicit none
3485 type(hecmwst_local_mesh), pointer :: hecMESH
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
subroutine fstr_setup_eigenread(ctrl, counter, p)
Read in !EIGENREAD !
subroutine fstr_setup_fload(ctrl, counter, p)
This source file contains subroutine for reading control data for harmonic response analysis (this im...
int fstr_ctrl_get_param_ex(int *ctrl, const char *param_name, const char *value_list, int *necessity, char *type, void *val)
int fstr_ctrl_close(int *ctrl)
int fstr_ctrl_get_data_line_n(int *ctrl)
int fstr_ctrl_seek_next_header(int *ctrl)
int fstr_ctrl_get_data_array_ex(int *ctrl, const char *format,...)
int fstr_ctrl_open(char *filename)
int fstr_ctrl_get_c_h_name(int *ctrl, char *header_name, int *buff_size)
int fstr_ctrl_rewind(int *ctrl)
This module encapsulate the basic functions of all elements provide by this software.
Definition: element.f90:43
integer function numofquadpoints(fetype)
Obtains the number of quadrature points of the element.
Definition: element.f90:445
integer(kind=kind(2)) function getspacedimension(etype)
Obtain the space dimension of the element.
Definition: element.f90:112
This module contains fstr control file data obtaining functions.
integer(kind=kint) function fstr_ctrl_get_contactalgo(ctrl, algo)
Read in !CONTACT.
logical function fstr_ctrl_get_istep(ctrl, hecmesh, steps, tpname, apname)
Read in !STEP and !ISTEP.
integer(kind=kint) function fstr_ctrl_get_solution(ctrl, type, nlgeom)
Read in !SOLUTION.
integer(kind=kint) function fstr_ctrl_get_couple(ctrl, fg_type, fg_first, fg_window, surf_id, surf_id_len)
Read in !COUPLE.
integer(kind=kint) function fstr_get_autoinc(ctrl, aincparam)
Read in !AUTOINC_PARAM !
integer function fstr_ctrl_get_section(ctrl, hecmesh, sections)
Read in !SECTION.
integer(kind=kint) function fstr_ctrl_get_elemopt(ctrl, elemopt361)
Read in !ELEMOPT.
logical function fstr_ctrl_get_contact(ctrl, n, contact, np, tp, ntol, ttol, ctalgo)
Read in contact definition.
integer(kind=kint) function fstr_ctrl_get_timepoints(ctrl, tp)
Read in !TIME_POINTS.
integer(kind=kint) function fstr_ctrl_get_echo(ctrl, echo)
Read in !ECHO.
logical function fstr_ctrl_get_outitem(ctrl, hecmesh, outinfo)
Read in !OUTPUT_RES & !OUTPUT_VIS.
integer(kind=kint) function fstr_ctrl_get_mpc(ctrl, penalty)
Read in !MPC.
integer(kind=kint) function fstr_ctrl_get_write(ctrl, res, visual, femap)
Read in !WRITE.
integer(kind=kint) function fstr_ctrl_get_step(ctrl, amp, iproc)
Read in !STEP.
integer(kind=kint) function fstr_ctrl_get_solver(ctrl, method, precond, nset, iterlog, timelog, steplog, nier, iterpremax, nrest, scaling, dumptype, dumpexit, usejad, ncolor_in, mpc_method, estcond, method2, recyclepre, solver_opt1, solver_opt2, solver_opt3, solver_opt4, solver_opt5, solver_opt6, resid, singma_diag, sigma, thresh, filter)
Read in !SOLVER.
This module contains control file data obtaining functions for dynamic analysis.
integer(kind=kint) function fstr_ctrl_get_acceleration(ctrl, atype, amp, node_id, node_id_len, dof_ids, dof_ide, value)
Read in !ACCELERATION.
integer(kind=kint) function fstr_ctrl_get_velocity(ctrl, vtype, amp, node_id, node_id_len, dof_ids, dof_ide, value)
Read in !VELOCITY.
integer(kind=kint) function fstr_ctrl_get_dynamic(ctrl, nlgeom, idx_eqa, idx_resp, n_step, t_start, t_end, t_delta, ganma, beta, idx_mas, idx_dmp, ray_m, ray_k, nout, node_id, node_id_len, nout_monit, iout_list)
Read in !DYNAMIC.
This module contains control file data obtaining functions for dynamic analysis.
integer(kind=kint) function fstr_ctrl_get_eigen(ctrl, nget, tolerance, maxiter)
Read in !EIGEN (struct)
This module contains control file data obtaining functions for heat conductive analysis.
integer(kind=kint) function fstr_ctrl_get_heat(ctrl, dt, etime, dtmin, deltmx, itmax, eps, tpname)
Read in !HEAT.
integer(kind=kint) function fstr_ctrl_get_dflux(ctrl, amp, elem_grp_name, elem_grp_name_len, load_type, value)
Read in !DFLUX (heat)
integer(kind=kint) function fstr_ctrl_get_sflux(ctrl, amp, surface_grp_name, surface_grp_name_len, value)
Read in !SFLUX (heat)
integer(kind=kint) function fstr_ctrl_get_weldline(ctrl, hecmesh, grp_name_len, weldline)
Read in !WELD_LINE (heat)
integer(kind=kint) function fstr_ctrl_get_film(ctrl, amp1, amp2, elem_grp_name, elem_grp_name_len, load_type, value, sink)
Read in !FILM (heat)
integer(kind=kint) function fstr_ctrl_get_radiate(ctrl, amp1, amp2, elem_grp_name, elem_grp_name_len, load_type, value, sink)
Read in !RADIATE (heat)
integer(kind=kint) function fstr_ctrl_get_cflux(ctrl, amp, node_grp_name, node_grp_name_len, value)
Read in !CFLUX (heat)
integer(kind=kint) function fstr_ctrl_get_fixtemp(ctrl, amp, node_grp_name, node_grp_name_len, value)
Read in !FIXTEMP.
integer(kind=kint) function fstr_ctrl_get_sfilm(ctrl, amp1, amp2, surface_grp_name, surface_grp_name_len, value, sink)
Read in !SFILM (heat)
integer(kind=kint) function fstr_ctrl_get_sradiate(ctrl, amp1, amp2, surface_grp_name, surface_grp_name_len, value, sink)
Read in !SRADIATE (heat)
This module manages read in of various material properties.
integer function fstr_ctrl_get_hyperelastic(ctrl, mattype, nlgeom, matval)
Read in !HYPERELASTIC.
integer function fstr_ctrl_get_viscoelasticity(ctrl, mattype, nlgeom, dict)
Read in !VISCOELASTIC.
integer function fstr_ctrl_get_viscoplasticity(ctrl, mattype, nlgeom, dict)
Read in !VISCOELASTIC.
integer function fstr_ctrl_get_usermaterial(ctrl, mattype, nlgeom, nstatus, matval)
Read in !USER_MATERIAL.
integer function fstr_ctrl_get_expansion_coeff(ctrl, matval, dict)
Read in !EXPANSION_COEFF.
integer function fstr_ctrl_get_trs(ctrl, mattype, matval)
Read in !TRS.
integer function fstr_ctrl_get_elasticity(ctrl, mattype, nlgeom, matval, dict)
Read in !ELASTIC.
integer function fstr_ctrl_get_plasticity(ctrl, mattype, nlgeom, matval, mattable, dict)
Read in !PLASTIC.
integer function fstr_ctrl_get_material(ctrl, matname)
Read in !MATERIAL.
integer function fstr_ctrl_get_density(ctrl, matval)
Read in !DENSITY.
integer function fstr_ctrl_get_fluid(ctrl, mattype, nlgeom, matval, dict)
Read in !FLUID.
This module contains control file data obtaining functions for static analysis.
integer(kind=kint) function fstr_ctrl_get_spring(ctrl, amp, node_id, node_id_len, dof_id, value)
Read in !SPRING.
integer(kind=kint) function fstr_ctrl_get_static(ctrl, dtime, etime, itime, eps, restart_nout, idx_elpl, iout_list, sig_y0, h_dash, nout, nout_monit, node_monit_1, elem_monit_1, intg_monit_1)
Read in !STATIC.
integer(kind=kint) function fstr_ctrl_get_boundary(ctrl, amp, node_id, node_id_len, dof_ids, dof_ide, value)
Read in !BOUNDARY.
integer(kind=kint) function fstr_ctrl_get_reftemp(ctrl, value)
Read in !REFTEMP.
integer(kind=kint) function fstr_ctrl_get_dload(ctrl, amp, follow, element_id, element_id_len, load_type, params)
Read in !DLOAD.
integer(kind=kint) function fstr_ctrl_get_temperature(ctrl, irres, tstep, tintl, rtype, node_id, node_id_len, value)
Read in !TEMPERATURE.
integer(kind=kint) function fstr_ctrl_get_cload(ctrl, amp, node_id, node_id_len, dof_id, value)
Read in !CLOAD.
integer function fstr_ctrl_get_userload(ctrl)
Read in !ULOAD.
This module contains auxiliary functions in calculation setup.
subroutine dload_grp_name_to_id_ex(hecmesh, n, grp_id_name, fg_surface, grp_id)
subroutine node_grp_name_to_id_ex(hecmesh, header_name, n, grp_id_name, grp_id)
integer(kind=kint) function get_local_member_index(hecmesh, type_name, name, local_id)
subroutine fstr_ctrl_err_stop
subroutine fstr_setup_visualize(ctrl, my_rank)
subroutine append_node_grp_from_surf_grp(hecmesh, sgrp_id, ngrp_id)
subroutine fstr_expand_real_array2(array, column, old_size, new_size)
subroutine fstr_expand_integer_array(array, old_size, new_size)
integer(kind=kint) function get_grp_member(hecmesh, grp_type_name, name, member1, member2)
subroutine fstr_expand_real_array(array, old_size, new_size)
subroutine amp_name_to_id(hecmesh, header_name, aname, id)
integer(kind=kint) function node_global_to_local(hecmesh, list, n)
subroutine fstr_strupr(s)
integer(kind=kint) function get_sorted_local_member_index(hecmesh, hecparam, type_name, name, local_id)
subroutine reallocate_real(array, n)
subroutine reallocate_integer(array, n)
subroutine fstr_expand_integer_array2(array, column, old_size, new_size)
integer(kind=kint) function get_grp_member_n(hecmesh, grp_type_name, name)
logical function fstr_streqr(s1, s2)
subroutine surf_grp_name_to_id_ex(hecmesh, header_name, n, grp_id_name, grp_id)
This module provides functions to read in data from control file and do neccessary preparation for fo...
Definition: fstr_setup.f90:7
subroutine fstr_setup_couple(ctrl, counter, p)
Read in !COUPLE !
subroutine fstr_dynamic_finalize(fstrdynamic)
Finalizer of fstr_solid.
subroutine fstr_setup_step(ctrl, counter, p)
Read in !STEP !
subroutine fstr_setup_spring(ctrl, counter, p)
Read in !SPRING !
subroutine fstr_heat_init(fstrheat)
Initial setting of heat analysis.
subroutine fstr_setup_echo(ctrl, counter, p)
Read in !ECHO !
subroutine fstr_solid_alloc(hecmesh, fstrsolid)
Initializer of structure fstr_solid.
Definition: fstr_setup.f90:926
subroutine fstr_solid_init(hecmesh, fstrsolid)
Initializer of structure fstr_solid.
Definition: fstr_setup.f90:895
subroutine fstr_dynamic_init(fstrdynamic)
Initial setting of dynamic calculation.
subroutine fstr_setup_sfilm(ctrl, counter, p)
Read in !SFILM !
integer function fstr_setup_orientation(ctrl, hecmesh, cnt, coordsys)
Read in !ORIENTATION.
subroutine fstr_element_init(hecmesh, fstrsolid)
Initialize elements info in static calculation.
subroutine fstr_setup_velocity(ctrl, counter, p)
Read in !VELOCITY !
subroutine fstr_setup_boundary(ctrl, counter, p)
Read in !BOUNDARY !
subroutine fstr_eigen_init(fstreig)
Initial setting of eigen ca;culation.
subroutine fstr_setup_dflux(ctrl, counter, p)
Read in !DFLUX !
subroutine fstr_setup_solver(ctrl, counter, p)
Read in !SOLVER !
subroutine fstr_setup_restart(ctrl, nout, version)
Read in !RESTART !
subroutine fstr_setup_cload(ctrl, counter, p)
Read in !CLOAD !
subroutine fstr_setup_reftemp(ctrl, counter, p)
Read in !REFTEMP !
subroutine fstr_setup_solution(ctrl, counter, p)
Read in !SOLUTION !
subroutine fstr_setup_solid_nastran(ctrl, hecmesh, fstrsolid)
subroutine fstr_setup_contactalgo(ctrl, p)
Read in !CONTACT !
subroutine fstr_dynamic_alloc(hecmesh, fstrdynamic)
Initial setting of dynamic calculation.
subroutine fstr_setup_heat(ctrl, counter, p)
Read in !HEAT !
subroutine fstr_setup_post_phys_alloc(phys, ndof, n_node, n_elem)
Initial setting of postprecessor.
subroutine fstr_setup_post(ctrl, p)
subroutine fstr_setup_static(ctrl, counter, p)
Read in !STATIC(old) !
subroutine fstr_setup_temperature(ctrl, counter, p)
Read in !TEMPERATURE !
subroutine fstr_setup_radiate(ctrl, counter, p)
Read in !RADIATE !
subroutine fstr_setup(cntl_filename, hecmesh, fstrparam, fstrsolid, fstreig, fstrheat, fstrdynamic, fstrcpl, fstrfreq)
Read in and initialize control data !
Definition: fstr_setup.f90:44
subroutine fstr_setup_film(ctrl, counter, p)
Read in !FILM !
subroutine fstr_setup_acceleration(ctrl, counter, p)
Read in !ACCELERATION !
subroutine fstr_setup_dload(ctrl, counter, p)
Read in !DLOAD.
subroutine fstr_setup_sradiate(ctrl, counter, p)
Read in !SRADIATE !
subroutine fstr_convert_contact_type(hecmesh)
Convert SURF-SURF contact to NODE-SURF contact !
subroutine fstr_setup_mpc(ctrl, counter, p)
Read in !MPC !
subroutine fstr_solid_finalize(fstrsolid)
Finalizer of fstr_solid.
integer(kind=kint) function fstr_setup_initial(ctrl, cond, hecmesh)
subroutine fstr_setup_eigen(ctrl, counter, p)
Read in !EIGEN !
subroutine fstr_expand_dload_array(array, old_size, new_size)
Read !FLOAD !
subroutine fstr_setup_sflux(ctrl, counter, p)
Read in !SFLUX !
subroutine fstr_setup_fixtemp(ctrl, counter, p)
Read in !FIXTEMP !
subroutine fstr_setup_cflux(ctrl, counter, p)
Read in !CFLUX !
subroutine fstr_setup_output_sstype(ctrl, p)
Read in !OUTPUT_SSTYPE !
subroutine fstr_setup_dynamic(ctrl, counter, p)
Read in !DYNAMIC !
subroutine fstr_setup_write(ctrl, counter, p)
Read in !WRITE !
This module defined coomon data and basic structures for analysis.
Definition: m_fstr.f90:15
integer(kind=kint), parameter iutb
Definition: m_fstr.f90:93
integer(kind=kint) myrank
PARALLEL EXECUTION.
Definition: m_fstr.f90:80
integer(kind=kint), parameter kbcffstr
boundary condition file type (bcf)
Definition: m_fstr.f90:57
integer(kind=kint), parameter kstdynamic
Definition: m_fstr.f90:40
integer(kind=kint), parameter idbg
Definition: m_fstr.f90:95
integer(kind=kint), parameter kel361fi
section control
Definition: m_fstr.f90:68
integer(kind=kint), parameter kel361ic
Definition: m_fstr.f90:70
integer(kind=kint), parameter ilog
FILE HANDLER.
Definition: m_fstr.f90:91
integer(kind=kint), parameter kststatic
Definition: m_fstr.f90:37
integer(kind=kint), parameter kcaalagrange
Definition: m_fstr.f90:54
integer(kind=kint), parameter kststaticeigen
Definition: m_fstr.f90:42
integer(kind=kint), parameter kstheat
Definition: m_fstr.f90:39
real(kind=kreal), pointer ref_temp
REFTEMP.
Definition: m_fstr.f90:120
integer(kind=kint), parameter kel361fbar
Definition: m_fstr.f90:71
integer(kind=kint), parameter ksteigen
Definition: m_fstr.f90:38
type(tinitialcondition), dimension(:), pointer, save g_initialcnd
Definition: m_fstr.f90:135
logical paracontactflag
PARALLEL CONTACT FLAG.
Definition: m_fstr.f90:84
This module manages step infomation.
Definition: m_out.f90:6
subroutine fstr_init_outctrl(outctrl)
Definition: m_out.f90:206
subroutine fstr_copy_outctrl(outctrl1, outctrl2)
Definition: m_out.f90:214
subroutine fstr_ctrl_get_output(ctrl, outctrl, islog, res, visual, femap)
Definition: m_out.f90:237
This module provide a function to fetch material properties from hecmw.
subroutine fstr_get_prop(hecmesh, shell_var, isect, ee, pp, rho, alpha, thick, n_totlyr, alpha_over_mu, beam_radius, beam_angle1, beam_angle2, beam_angle3, beam_angle4, beam_angle5, beam_angle6)
This module manages step infomation.
Definition: m_step.f90:6
subroutine free_stepinfo(step)
Finalizer.
Definition: m_step.f90:123
subroutine init_stepinfo(stepinfo)
Initializer.
Definition: m_step.f90:65
subroutine init_aincparam(aincparam)
Initializer.
Definition: m_step.f90:162
subroutine setup_stepinfo_starttime(stepinfos)
Definition: m_step.f90:84
This module provides aux functions.
Definition: utilities.f90:6
subroutine cross_product(v1, v2, vn)
Definition: utilities.f90:330
This module provides functions to calcualte contact stiff matrix.
Definition: fstr_contact.f90:6
real(kind=kreal), save cdotp
mu=cdotp*maxval
real(kind=kreal), save mut
penalty along tangent direction
real(kind=kreal), save cgt
convergent condition of relative tangent disp
real(kind=kreal), save cgn
convergent condition of penetration
This module summarizes all infomation of material properties.
Definition: material.f90:6
integer(kind=kint), parameter m_youngs
Definition: material.f90:84
integer(kind=kint), parameter m_beam_radius
Definition: material.f90:101
integer(kind=kint), parameter viscoelastic
Definition: material.f90:70
integer(kind=kint), parameter m_exapnsion
Definition: material.f90:97
integer(kind=kint), parameter m_beam_angle6
Definition: material.f90:107
integer(kind=kint), parameter elastic
Definition: material.f90:58
integer(kind=kint), parameter m_beam_angle3
Definition: material.f90:104
integer(kind=kint), parameter m_density
Definition: material.f90:86
integer(kind=kint), parameter m_beam_angle4
Definition: material.f90:105
integer(kind=kint), parameter m_poisson
Definition: material.f90:85
integer(kind=kint), parameter m_beam_angle1
Definition: material.f90:102
integer(kind=kint), parameter m_thick
Definition: material.f90:87
integer(kind=kint), parameter m_beam_angle5
Definition: material.f90:106
integer(kind=kint), parameter m_beam_angle2
Definition: material.f90:103
integer(kind=kint), parameter m_alpha_over_mu
Definition: material.f90:99
subroutine initmaterial(material)
Initializer.
Definition: material.f90:164
This modules defines a structure to record history dependent parameter in static analysis.
Definition: mechgauss.f90:6
subroutine fstr_init_gauss(gauss)
Initializer.
Definition: mechgauss.f90:41
Data for coupling analysis.
Definition: m_fstr.f90:580
Data for DYNAMIC ANSLYSIS (fstrDYNAMIC)
Definition: m_fstr.f90:473
Package of data used by Lanczos eigenvalue solver.
Definition: m_fstr.f90:562
Data for HEAT ANSLYSIS (fstrHEAT)
Definition: m_fstr.f90:394
FSTR INNER CONTROL PARAMETERS (fstrPARAM)
Definition: m_fstr.f90:138
Package of all data needs to initilize.
Definition: fstr_setup.f90:26
output control such as output filename, output freqency etc.
Definition: m_out.f90:29