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