OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
hm_read_perturb_part_shell.F File Reference
#include "implicit_f.inc"
#include "com04_c.inc"
#include "scr17_c.inc"
#include "units_c.inc"
#include "param_c.inc"
#include "sphcom.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine hm_read_perturb_part_shell (ipart, rnoise, ipartc, ipartg, igrpart, ipm, perturb, lsubmodel, unitab, idperturb, index, index_ityp, npart_shell, offs, qp_iperturb, qp_rperturb)

Function/Subroutine Documentation

◆ hm_read_perturb_part_shell()

subroutine hm_read_perturb_part_shell ( integer, dimension(lipart1,*) ipart,
rnoise,
integer, dimension(*) ipartc,
integer, dimension(*) ipartg,
type (group_), dimension(ngrpart) igrpart,
integer, dimension(npropmi,*) ipm,
integer, dimension(nperturb) perturb,
type(submodel_data), dimension(*) lsubmodel,
type (unit_type_), intent(in) unitab,
integer, dimension(nperturb) idperturb,
integer, dimension(numelc+numeltg+numels+numsph) index,
integer, dimension(numelc+numeltg+numels+numsph) index_ityp,
integer npart_shell,
integer offs,
integer, dimension(nperturb,6) qp_iperturb,
qp_rperturb )

Definition at line 41 of file hm_read_perturb_part_shell.F.

46C-----------------------------------------------
47C M o d u l e s
48C-----------------------------------------------
49 USE message_mod
50 USE groupdef_mod
51 USE unitab_mod
52 USE submodel_mod
53 USE hm_option_read_mod
54 USE names_and_titles_mod , ONLY : nchartitle, ncharfield, ncharkey
55 USE format_mod , ONLY : lfield
56C-----------------------------------------------
57C I m p l i c i t T y p e s
58C-----------------------------------------------
59#include "implicit_f.inc"
60C-----------------------------------------------
61C C o m m o n B l o c k s
62C-----------------------------------------------
63#include "com04_c.inc"
64#include "scr17_c.inc"
65#include "units_c.inc"
66#include "param_c.inc"
67#include "sphcom.inc"
68C-----------------------------------------------
69C D u m m y A r g u m e n t s
70C-----------------------------------------------
71 TYPE (UNIT_TYPE_),INTENT(IN) ::UNITAB
72 my_real
73 . rnoise(nperturb,numelc+numeltg+numels+numsph),
74 . qp_rperturb(nperturb,4)
75 INTEGER IPART(LIPART1,*),IPARTC(*),
76 . IPARTG(*),IPM(NPROPMI,*),
77 . PERTURB(NPERTURB),OFFS,
78 . IDPERTURB(NPERTURB),INDEX(NUMELC+NUMELTG+NUMELS+NUMSPH),
79 . INDEX_ITYP(NUMELC+NUMELTG+NUMELS+NUMSPH),NPART_SHELL,
80 . QP_IPERTURB(NPERTURB,6)
81 TYPE(SUBMODEL_DATA) LSUBMODEL(*)
82C-----------------------------------------------
83 TYPE (GROUP_) , DIMENSION(NGRPART) :: IGRPART
84C-----------------------------------------------
85C L o c a l V a r i a b l e s
86C-----------------------------------------------
87 INTEGER I,J,K,NUMA,I_METHOD,MAX_PART,
88 . CPT_PART,NB_RANDOM,I_SEED,DISTRIB(50),
89 . II,NB_INTERV,IGRPRT,N,IOK,SEED,SEED_RANDOM,
90 . ITYP,I_PERTURB_VAR,SIZEY,EMPTY
91 CHARACTER(LEN=NCHARTITLE) :: TITR
92 INTEGER, DIMENSION(:,:), ALLOCATABLE :: TAB_PART
93 INTEGER, DIMENSION(:), ALLOCATABLE :: A_SEED
94 INTEGER, DIMENSION(1:8) :: DT_SEED
95 my_real
96 . mean,sd,mean_input,sd_input,max_distrib,temp,min_value,
97 . max_value,minval,maxval,bid
98 my_real, DIMENSION(:), ALLOCATABLE :: array
99 CHARACTER*100 CHAR(100)
100 CHARACTER*100 CHAR1(100)
101 CHARACTER*100 CHAR2
102 CHARACTER MESS*40
103 CHARACTER(LEN=NCHARFIELD)::CHVAR
104 LOGICAL IS_AVAILABLE
105C-----------------------------------------------
106C E x t e r n a l F u n c t i o n s
107C-----------------------------------------------
108 DATA mess/'PERTURBATION DEFINITION '/
109C=======================================================================
110C-----------------------------------------------
111C B e g i n n i n g o f s o u r c e
112C-----------------------------------------------
113 ! Initialization and allocation of tables
114 max_part = 0
115 ityp = 0
116 bid = 0
117 is_available = .false.
118 CALL hm_option_start('/PERTURB/PART/SHELL')
119 !----------------------------------------------------------------------
120 ! 1st Loop over /PERTURB/PART for computing table dimension
121 !----------------------------------------------------------------------
122 DO i=1+offs,npart_shell+offs
123C
124 ! Reading the option
125 titr = ''
126 CALL hm_option_read_key(lsubmodel,
127 . option_id = idperturb(i),
128 . option_titr = titr)
129C
130 ! Perturbation type
131 ityp = 1
132c
133 i_perturb_var = 0
134 cpt_part = 0
135 igrprt = 0
136 iok = 0
137 chvar = ''
138C
139 ! Reading the number of the Group of Part + the perturbed variable
140 CALL hm_get_intv('grpart_ID' ,igrprt ,is_available,lsubmodel)
141 CALL hm_get_string('chvar',chvar ,ncharfield,is_available)
142 IF (chvar(1:5) == 'thick' .OR. chvar(1:5) == 'THICK') i_perturb_var = 1
143c
144 empty = 1
145 DO k = 1,lfield
146 IF(chvar(k:k) /= ' ') empty = 0
147 ENDDO
148c
149 ! Checking the perturbed variable
150 IF (i_perturb_var /= 1 .AND. empty == 0) CALL ancmsg(msgid=1194,
151 . msgtype=msgerror,
152 . anmode=aninfo,
153 . i1=idperturb(i),
154 . c1=titr,
155 . c2=chvar)
156c
157 ! Checking Shell part group
158 IF (igrprt /= 0) THEN
159 DO n=1,ngrpart
160 IF (igrpart(n)%ID == igrprt) THEN
161 igrprt=n
162 iok = 1
163 ityp = 1
164 EXIT
165 END IF
166 END DO
167 ENDIF
168c
169 ! Saving the perturbation type
170 perturb(i) = ityp
171c
172 ! Error messages or counting
173 IF (iok == 0) THEN
174 CALL ancmsg(msgid=1137,
175 . msgtype=msgerror,
176 . anmode=aninfo,
177 . i1=idperturb(i),
178 . c1=titr,
179 . i2=igrprt,
180 . c2='GROUP OF PART')
181 ELSEIF(iok == 1)THEN
182 cpt_part = igrpart(igrprt)%NENTITY
183 ENDIF
184 max_part = max(max_part,cpt_part)
185 ENDDO
186 ! Allocation of tables
187 ALLOCATE(tab_part(nperturb,max_part))
188c
189 !----------------------------------------------------------------------
190 ! 2nd Loop over /PERTURB/PART for reading and computing perturbation
191 !----------------------------------------------------------------------
192 CALL hm_option_start('/PERTURB/PART/SHELL')
193 DO i = 1+offs,npart_shell+offs
194C
195 ! Resetting index tables
196 index(1:(numelc+numeltg+numels+numsph)) = 0
197 index_ityp(1:numelc+numeltg+numels+numsph) = 0
198C
199 ! Reading the option
200 titr = ''
201 CALL hm_option_read_key(lsubmodel,
202 . option_id = idperturb(i),
203 . option_titr = titr)
204C
205 ! Perturbation type
206 ityp = 1
207C
208 ! Reading the card
209 CALL hm_get_floatv('F_Mean' ,mean ,is_available, lsubmodel, unitab)
210 CALL hm_get_floatv('Deviation' ,sd ,is_available, lsubmodel, unitab)
211 CALL hm_get_floatv('Min_cut' ,minval ,is_available, lsubmodel, unitab)
212 CALL hm_get_floatv('Max_cut' ,maxval ,is_available, lsubmodel, unitab)
213 CALL hm_get_intv('Seed' ,seed ,is_available, lsubmodel)
214 CALL hm_get_intv('Idistri' ,i_method,is_available, lsubmodel)
215c
216 ! Default value
217 IF(i_method == 0) i_method = 2
218 IF(minval == zero .AND. maxval == zero) THEN
219 IF(i_method == 1) THEN
220 ELSEIF(i_method == 2)THEN
221 minval = -ep30
222 maxval = ep30
223 ENDIF
224 ENDIF
225 sd_input = sd
226 mean_input = mean
227c
228 ! QAPRINT table
229 qp_iperturb(i,1) = idperturb(i)
230 qp_iperturb(i,2) = ityp
231 qp_iperturb(i,3) = seed
232 qp_iperturb(i,4) = i_method
233 qp_rperturb(i,1) = mean
234 qp_rperturb(i,2) = sd
235 qp_rperturb(i,3) = minval
236 qp_rperturb(i,4) = maxval
237c
238 ! Initialization flag and counter
239 cpt_part = 0
240 igrprt = 0
241 iok = 0
242C
243 ! Reading the number of the Group of Part + the perturbed variable
244 CALL hm_get_intv('grpart_ID',igrprt,is_available,lsubmodel)
245 qp_iperturb(i,5) = igrprt
246 CALL hm_get_string('chvar',chvar,ncharfield,is_available)
247 IF (chvar(1:5) == 'thick' .OR. chvar(1:5) == 'THICK') qp_iperturb(i,6) = 1
248c
249 ! Checking Shell part group
250 IF (igrprt /= 0) THEN
251 DO n=1,ngrpart
252 IF (igrpart(n)%ID == igrprt) THEN
253 igrprt = n
254 iok = 1
255 ityp = 1
256 EXIT
257 END IF
258 END DO
259 ENDIF
260c
261 ! Tag the parts
262 IF (iok == 1) THEN
263 cpt_part = 0
264 DO j=1,igrpart(igrprt)%NENTITY
265 cpt_part = cpt_part + 1
266 numa = igrpart(igrprt)%ENTITY(j)
267 tab_part(i,cpt_part) = numa
268 END DO
269 ENDIF
270c
271 ! Printing out the information
272 IF(i_method == 2) THEN
273 WRITE (iout,1000)
274 . idperturb(i),'GAUSSIAN',mean_input,sd_input,seed
275 WRITE (iout,'(10I10)') ipart(4,tab_part(i,1:cpt_part))
276 WRITE(iout,*) ' '
277 WRITE(iout,*) ' '
278 ELSEIF(I_METHOD == 1) THEN
279 WRITE (IOUT,1100)
280 . IDPERTURB(I),'random',SEED
281 WRITE (IOUT,'(10i10)') IPART(4,TAB_PART(I,1:CPT_PART))
282 WRITE(IOUT,*) ' '
283 WRITE(IOUT,*) ' '
284 ENDIF
285c
286 ! Filling the index table
287 nb_random = 0
288 DO ii=1,numelc
289 DO k=1,cpt_part
290 IF (ipartc(ii) == tab_part(i,k)) THEN
291 nb_random = nb_random + 1
292 index(nb_random) = ii
293 index_ityp(nb_random) = 3
294 ENDIF
295 ENDDO
296 ENDDO
297 DO ii=1,numeltg
298 DO k=1,cpt_part
299 IF(ipartg(ii) == tab_part(i,k)) THEN
300 nb_random = nb_random + 1
301 index(nb_random) = ii
302 index_ityp(nb_random) = 7
303 ENDIF
304 ENDDO
305 ENDDO
306C
307 ! Set up random seed
308 IF( seed == 0 )THEN
309 CALL random_seed(size=i_seed)
310 ALLOCATE(a_seed(1:i_seed))
311 CALL random_seed(get=a_seed)
312 CALL date_and_time(values=dt_seed)
313 a_seed=dt_seed(8)*dt_seed(7)*dt_seed(6)
314 seed=dt_seed(8)*dt_seed(7)*dt_seed(6)
315 CALL random_seed(put=a_seed)
316 seed_random = 1
317 DEALLOCATE(a_seed)
318 ELSE
319 CALL random_seed(size=i_seed)
320 ALLOCATE(a_seed(1:i_seed))
321 a_seed=seed
322 CALL random_seed(put=a_seed)
323 seed_random = 0
324 DEALLOCATE(a_seed)
325 ENDIF
326C
327 ! Build uniform distribution
328 char=''
329 char1=''
330 char2=''
331 distrib(1:50) = 0
332 ALLOCATE(array(nb_random+2))
333 CALL random_number(array)
334C
335 ! Build normal distribution
336 max_value = -ep30
337 min_value = ep30
338 IF ( i_method == 2) THEN
339 DO ii = 1, nb_random+1, 2
340 temp = sd * sqrt(-2.0*log(array(ii))) * cos(2*pi*array(ii+1)) +
341 . mean
342 array(ii+1) =
343 . sd * sqrt(-2.0*log(array(ii))) * sin(2*pi*array(ii+1)) + mean
344 array(ii) = temp
345 END DO
346 DO ii = 1, nb_random
347 array(ii) = max(min(maxval,array(ii)),minval)
348 max_value = max(array(ii),max_value)
349 min_value = min(array(ii),min_value)
350 END DO
351 ELSEIF(i_method == 1)THEN
352 DO ii = 1, nb_random
353 array(ii) = array(ii)*(maxval-minval)+minval
354 max_value = max(array(ii),max_value)
355 min_value = min(array(ii),min_value)
356 END DO
357 ENDIF
358c
359 ! Filling RNOISE table
360 DO ii = 1, nb_random
361 IF (index_ityp(ii) == 3) THEN
362 rnoise(i,index(ii)) = array(ii)
363 ELSEIF (index_ityp(ii) == 7) THEN
364 rnoise(i,index(ii)+numelc) = array(ii)
365 ENDIF
366 ENDDO
367c
368 ! Check mean and standard deviation
369 mean = sum(array)/nb_random
370 sd = sqrt(sum((array - mean)**2)/nb_random)
371c
372 ! Plot the normal distribution
373 IF(i_method == 2) THEN
374 max_distrib = one /(sd*sqrt(two * pi))
375 ELSEIF(i_method == 1) THEN
376 max_distrib = one /(max_value-min_value)
377 ENDIF
378 WRITE (iout,3000)
379 WRITE(iout,*) ' '
380 nb_interv = 50
381 sizey = 20
382 IF (minval /= -ep30 .AND. maxval /= ep30)THEN
383 min_value = minval
384 max_value = maxval
385 ENDIF
386 CALL plot_distrib( array,nb_random, nb_interv,sizey,min_value,
387 . max_value,max_distrib,'#')
388 IF(i_method == 2) THEN
389 WRITE (iout,2000) mean,sd
390 ELSEIF(i_method == 1) THEN
391 WRITE (iout,2050) mean
392 ENDIF
393 IF(seed_random == 1) WRITE (iout,2100) seed
394 WRITE(iout,*) ' '
395 WRITE(iout,*) ' '
396 IF (ALLOCATED(array)) DEALLOCATE(array)
397 ENDDO
398 DEALLOCATE(tab_part)
399C-------------------------------------------------------------
400 1000 FORMAT(/' PERTURBATION ID',i10/
401 + ' ---------------'/
402 + ' TYPE . . . . . . . . . . . . . . .',a/
403 + ' INPUT MEAN VALUE . . . . . . . . .',1pg20.13/
404 + ' INPUT STANDARD DEVIATION . . . . .',1pg20.13/
405 + ' INPUT SEED VALUE . . . . . . . . .',i10/
406 + ' SHELL THICKNESSES, PARTS:')
407 1100 FORMAT(/' PERTURBATION ID',i10/
408 + ' ---------------'/
409 + ' TYPE . . . . . . . . . . . . . . .',a/
410 + ' INPUT SEED VALUE . . . . . . . . .',i10/
411 + ' SHELL THICKNESSES, PARTS:')
412C-------------------------------------------------------------
413 2000 FORMAT(/
414 + ' GENERATED MEAN VALUE . . . . . . .',1pg20.13/
415 + ' GENERATED STANDARD DEVIATION . . .',1pg20.13)
416 2050 FORMAT(/
417 + ' GENERATED MEAN VALUE . . . . . . .',1pg20.13)
418 2100 FORMAT(/
419 + ' GENERATED SEED VALUE . . . . . . .',i10/)
420C-------------------------------------------------------------
421 3000 FORMAT(/
422 + ' DISTRIBUTION OF SCALE FACTORS APPLIED TO THICKNESSES OF SHELLS')
423C------------------------------
424C------------------------------
my_real
#define my_real
Definition cppsort.cpp:32
hm_get_floatv
subroutine hm_get_floatv(name, rval, is_available, lsubmodel, unitab)
Definition hm_get_floatv.F:418
hm_get_intv
subroutine hm_get_intv(name, ival, is_available, lsubmodel)
Definition hm_get_intv.F:528
hm_get_string
subroutine hm_get_string(name, sval, size, is_available)
Definition hm_get_string.F:78
hm_option_start
subroutine hm_option_start(entity_type)
Definition hm_option_start.F:253
hm_option_read_mod::hm_option_read_key
Definition hm_option_read_mod.F:414
seed
#define seed()
Definition macros.h:43
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
groupdef_mod
Definition groupdef_mod.F:668
hm_option_read_mod
Definition hm_option_read_mod.F:412
message_mod
Definition message_mod.F:1257
names_and_titles_mod
Definition names_and_titles_mod.F:1002
names_and_titles_mod::nchartitle
integer, parameter nchartitle
Definition names_and_titles_mod.F:1008
names_and_titles_mod::ncharkey
integer, parameter ncharkey
Definition names_and_titles_mod.F:1005
names_and_titles_mod::ncharfield
integer, parameter ncharfield
Definition names_and_titles_mod.F:1010
submodel_mod
Definition submodel_mod.F:717
unitab_mod
Definition unitab_mod.F:517
plot_distrib
subroutine plot_distrib(array, s_array, nb_interv, sizey, x_minvalue, x_maxvalue, y_maxvalue, ecrit)
Definition plot_distrib.F:34
ancmsg
subroutine ancmsg(msgid, msgtype, anmode, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, r1, r2, r3, r4, r5, r6, r7, r8, r9, c1, c2, c3, c4, c5, c6, c7, c8, c9, prmode)
Definition message.F:895