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