OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
hm_read_perturb_part_solid.F
Go to the documentation of this file.
1Copyright> OpenRadioss
2Copyright> Copyright (C) 1986-2025 Altair Engineering Inc.
3Copyright>
4Copyright> This program is free software: you can redistribute it and/or modify
5Copyright> it under the terms of the GNU Affero General Public License as published by
6Copyright> the Free Software Foundation, either version 3 of the License, or
7Copyright> (at your option) any later version.
8Copyright>
9Copyright> This program is distributed in the hope that it will be useful,
10Copyright> but WITHOUT ANY WARRANTY; without even the implied warranty of
11Copyright> MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12Copyright> GNU Affero General Public License for more details.
13Copyright>
14Copyright> You should have received a copy of the GNU Affero General Public License
15Copyright> along with this program. If not, see <https://www.gnu.org/licenses/>.
16Copyright>
17Copyright>
18Copyright> Commercial Alternative: Altair Radioss Software
19Copyright>
20Copyright> As an alternative to this open-source version, Altair also offers Altair Radioss
21Copyright> software under a commercial license. Contact Altair to discuss further if the
22Copyright> commercial version may interest you: https://www.altair.com/radioss/.
23!||====================================================================
24!|| hm_read_perturb_part_solid ../starter/source/general_controls/computation/hm_read_perturb_part_solid.F
25!||--- called by ------------------------------------------------------
26!|| hm_read_perturb ../starter/source/general_controls/computation/hm_read_perturb.F
27!||--- calls -----------------------------------------------------
28!|| ancmsg ../starter/source/output/message/message.F
29!|| hm_get_floatv ../starter/source/devtools/hm_reader/hm_get_floatv.F
30!|| hm_get_intv ../starter/source/devtools/hm_reader/hm_get_intv.f
31!|| hm_get_string ../starter/source/devtools/hm_reader/hm_get_string.F
32!|| hm_option_read_key ../starter/source/devtools/hm_reader/hm_option_read_key.F
33!|| hm_option_start ../starter/source/devtools/hm_reader/hm_option_start.F
34!|| plot_distrib ../starter/source/general_controls/computation/plot_distrib.F
35!||--- uses -----------------------------------------------------
36!|| hm_option_read_mod ../starter/share/modules1/hm_option_read_mod.F
37!|| message_mod ../starter/share/message_module/message_mod.F
38!|| submodel_mod ../starter/share/modules1/submodel_mod.F
39!||====================================================================
40 SUBROUTINE hm_read_perturb_part_solid(
41 1 IPART ,RNOISE ,IGRPART ,IPM ,IPARTS ,
42 2 PERTURB ,LSUBMODEL,UNITAB ,IDPERTURB,INDEX ,
43 3 INDEX_ITYP,NPART_SOLID ,OFFS ,QP_IPERTURB,
44 4 QP_RPERTURB)
45C-----------------------------------------------
46C M o d u l e s
47C-----------------------------------------------
48 USE message_mod
49 USE groupdef_mod
50 USE unitab_mod
51 USE submodel_mod
52 USE hm_option_read_mod
53 USE names_and_titles_mod , ONLY : nchartitle, ncharkey, ncharfield
54C-----------------------------------------------
55C I m p l i c i t T y p e s
56C-----------------------------------------------
57#include "implicit_f.inc"
58C-----------------------------------------------
59C C o m m o n B l o c k s
60C-----------------------------------------------
61#include "com04_c.inc"
62#include "scr17_c.inc"
63#include "units_c.inc"
64#include "param_c.inc"
65#include "sphcom.inc"
66C-----------------------------------------------
67C D u m m y A r g u m e n t s
68C-----------------------------------------------
69 TYPE (UNIT_TYPE_),INTENT(IN) ::UNITAB
70 my_real
71 . RNOISE(NPERTURB,NUMELC+NUMELTG+NUMELS+NUMSPH),
72 . QP_RPERTURB(NPERTURB,4)
73 INTEGER IPART(LIPART1,*),
74 . ipm(npropmi,*),offs,
75 . iparts(*),perturb(nperturb),
76 . idperturb(nperturb),index(numelc+numeltg+numels+numsph),
77 . index_ityp(numelc+numeltg+numels+numsph),npart_solid,
78 . qp_iperturb(nperturb,6)
79 TYPE(submodel_data) LSUBMODEL(*)
80C-----------------------------------------------
81 TYPE (GROUP_) , DIMENSION(NGRPART) :: IGRPART
82C-----------------------------------------------
83C L o c a l V a r i a b l e s
84C-----------------------------------------------
85 INTEGER I,J,K,NUMA,I_METHOD,MAX_PART,
86 . CPT_PART,NB_RANDOM,I_SEED,DISTRIB(50),
87 . II,NB_INTERV,N,IOK,SEED,SEED_RANDOM,
88 . ITYP,L,I_PERTURB_VAR,IGRPRTS,SIZEY
89 CHARACTER(LEN=NCHARTITLE) :: TITR
90 CHARACTER(LEN=NCHARKEY) :: KEY
91 CHARACTER MES*40
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,interv,VALUE,max_value1,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/SOLID')
119 !----------------------------------------------------------------------
120 ! 1st Loop over /PERTURB/PART for computing table dimension
121 !----------------------------------------------------------------------
122 DO i=1+offs,npart_solid+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 ! Checking perturbation type
131 ityp = 3
132c
133 i_perturb_var = 0
134 cpt_part = 0
135 igrprts = 0
136 iok = 0
137C
138 ! Reading the number of the Group of Part + the perturbed variable
139 CALL hm_get_intv('grpart_ID',igrprts,is_available,lsubmodel)
140 CALL hm_get_string('chvar',chvar,ncharfield,is_available)
141 IF (chvar(1:4) == 'dens' .OR. chvar(1:4) == 'DENS') i_perturb_var = 1
142c
143 ! Checking the perturbed variable
144 IF (i_perturb_var /= 1) CALL ancmsg(msgid=1194,
145 . msgtype=msgerror,
146 . anmode=aninfo,
147 . i1=idperturb(i),
148 . c1=titr,
149 . c2=chvar)
150c
151 ! Checking solid part group
152 IF (igrprts /= 0)THEN
153 DO n=1,ngrpart
154 IF (igrpart(n)%ID == igrprts) THEN
155 igrprts = n
156 iok = 1
157 ityp = 3
158 EXIT
159 END IF
160 END DO
161 ENDIF
162c
163 ! Saving the perturbation type
164 perturb(i) = ityp
165c
166 ! Error messages or counting
167 IF (iok == 0) THEN
168 CALL ancmsg(msgid=1137,
169 . msgtype=msgerror,
170 . anmode=aninfo,
171 . i1=idperturb(i),
172 . c1=titr,
173 . i2=igrprts,
174 . c2='GROUP OF PART')
175 ELSEIF (iok == 1)THEN
176 cpt_part = igrpart(igrprts)%NENTITY
177 ENDIF
178 max_part = max(max_part,cpt_part)
179 ENDDO
180 ! Allocation of tables
181 ALLOCATE(tab_part(nperturb,max_part))
182c
183 !----------------------------------------------------------------------
184 ! 2nd Loop over /PERTURB/PART for reading and computing perturbation
185 !----------------------------------------------------------------------
186 CALL hm_option_start('/PERTURB/PART/SOLID')
187 DO i=1+offs,npart_solid+offs
188C
189 ! Resetting index tables
190 index(1:(numelc+numeltg+numels+numsph)) = 0
191 index_ityp(1:numelc+numeltg+numels+numsph) = 0
192C
193 ! Reading the option
194 titr = ''
195 CALL hm_option_read_key(lsubmodel,
196 . option_id = idperturb(i),
197 . option_titr = titr)
198C
199 ! Perturbation type
200 ityp = 3
201C
202 ! Reading the card
203 CALL hm_get_floatv('F_Mean' ,mean ,is_available, lsubmodel, unitab)
204 CALL hm_get_floatv('Deviation' ,sd ,is_available, lsubmodel, unitab)
205 CALL hm_get_floatv('Min_cut' ,minval ,is_available, lsubmodel, unitab)
206 CALL hm_get_floatv('Max_cut' ,maxval ,is_available, lsubmodel, unitab)
207 CALL hm_get_intv('Seed' ,seed ,is_available, lsubmodel)
208 CALL hm_get_intv('Idistri' ,i_method,is_available, lsubmodel)
209c
210 ! Default value
211 IF(i_method == 0) i_method = 2
212 IF(minval == zero .AND. maxval == zero) THEN
213 IF(i_method == 1) THEN
214 ELSEIF(i_method == 2)THEN
215 minval = -ep30
216 maxval = ep30
217 ENDIF
218 ENDIF
219 sd_input = sd
220 mean_input = mean
221c
222 ! QAPRINT table
223 qp_iperturb(i,1) = idperturb(i)
224 qp_iperturb(i,2) = ityp
225 qp_iperturb(i,3) = seed
226 qp_iperturb(i,4) = i_method
227 qp_rperturb(i,1) = mean
228 qp_rperturb(i,2) = sd
229 qp_rperturb(i,3) = minval
230 qp_rperturb(i,4) = maxval
231c
232 ! Initialization flag and counter
233 cpt_part = 0
234 igrprts = 0
235 iok = 0
236C
237 ! Reading the number of the Group of Part + the perturbed variable
238 CALL hm_get_intv('grpart_ID' ,igrprts ,is_available,lsubmodel)
239 qp_iperturb(i,5) = igrprts
240 CALL hm_get_string('chvar',chvar,ncharfield,is_available)
241 IF (chvar(1:4) == 'dens' .OR. chvar(1:4) == 'DENS') qp_iperturb(i,6) = 1
242c
243 ! Checking solid part group
244 IF (igrprts /= 0)THEN
245 DO n=1,ngrpart
246 IF (igrpart(n)%ID == igrprts) THEN
247 igrprts = n
248 iok = 1
249 ityp = 3
250 EXIT
251 END IF
252 END DO
253 ENDIF
254c
255 ! Tag the parts
256 IF (iok == 1) THEN
257 cpt_part = 0
258 DO j=1,igrpart(igrprts)%NENTITY
259 cpt_part = cpt_part + 1
260 numa = igrpart(igrprts)%ENTITY(j)
261 tab_part(i,cpt_part) = numa
262 END DO
263 ENDIF
264c
265 ! Printing out the information
266 IF(i_method == 2) THEN
267 WRITE (iout,6000)
268 . idperturb(i),'GAUSSIAN',mean_input,sd_input,seed
269 WRITE (iout,'(10I10)') ipart(4,tab_part(i,1:cpt_part))
270 WRITE(iout,*) ' '
271 WRITE(IOUT,*) ' '
272 ELSEIF(I_METHOD == 1) THEN
273 WRITE (IOUT,6100)
274 . IDPERTURB(I),'random',SEED
275 WRITE (IOUT,'(10i10)') IPART(4,TAB_PART(I,1:CPT_PART))
276 WRITE(IOUT,*) ' '
277 WRITE(IOUT,*) ' '
278 ENDIF
279c
280 ! Filling the index table
281 NB_RANDOM = 0
282 DO II=1,NUMELS
283 DO K=1,CPT_PART
284 IF(IPARTS(II) == TAB_PART(I,K)) THEN
285 NB_RANDOM = NB_RANDOM + 1
286 INDEX(NB_RANDOM) = II
287 INDEX_ITYP(NB_RANDOM) = 1
288 ENDIF
289 ENDDO
290 ENDDO
291C
292 ! Set up random seed
293 IF( SEED == 0 )THEN
294 CALL RANDOM_SEED(SIZE=I_SEED)
295 ALLOCATE(A_SEED(1:I_SEED))
296 CALL RANDOM_SEED(GET=A_SEED)
297 CALL DATE_AND_TIME(values=DT_SEED)
298 A_SEED=DT_SEED(8)*DT_SEED(7)*DT_SEED(6)
299 SEED=DT_SEED(8)*DT_SEED(7)*DT_SEED(6)
300 CALL RANDOM_SEED(PUT=A_SEED)
301 SEED_RANDOM = 1
302 DEALLOCATE(A_SEED)
303 ELSE
304 CALL RANDOM_SEED(SIZE=I_SEED)
305 ALLOCATE(A_SEED(1:I_SEED))
306 A_SEED=SEED
307 CALL RANDOM_SEED(PUT=A_SEED)
308 SEED_RANDOM = 0
309 DEALLOCATE(A_SEED)
310 ENDIF
311C
312 ! Build uniform distribution
313 CHAR=''
314 CHAR1=''
315 CHAR2=''
316 DISTRIB(1:50) = 0
317 ALLOCATE(ARRAY(NB_RANDOM+2))
318 CALL RANDOM_NUMBER(ARRAY)
319C
320 ! Build normal distribution
321 MAX_VALUE = -EP30
322 MIN_VALUE = EP30
323 IF ( I_METHOD == 2) THEN
324 DO II = 1, NB_RANDOM+1, 2
325 TEMP = SD * SQRT(-2.0*LOG(ARRAY(II))) * COS(2*pi*array(II+1)) + MEAN
326 ARRAY(II+1) = SD * SQRT(-2.0*LOG(ARRAY(II))) * SIN(2*pi*ARRAY(II+1)) + MEAN
327 ARRAY(II) = TEMP
328 END DO
329 DO II = 1, NB_RANDOM
330 ARRAY(II) = MAX(MIN(MAXVAL,ARRAY(II)),MINVAL)
331 MAX_VALUE = MAX(ARRAY(II),MAX_VALUE)
332 MIN_VALUE = MIN(ARRAY(II),MIN_VALUE)
333 END DO
334 ELSEIF(I_METHOD == 1)THEN
335 DO II = 1, NB_RANDOM
336 ARRAY(II) = ARRAY(II)*(MAXVAL-MINVAL)+MINVAL
337 MAX_VALUE = MAX(ARRAY(II),MAX_VALUE)
338 MIN_VALUE = MIN(ARRAY(II),MIN_VALUE)
339 END DO
340 ENDIF
341c
342 ! Filling RNOISE table
343 DO II = 1, NB_RANDOM
344 IF (INDEX_ITYP(II) == 1) THEN
345 RNOISE(I,INDEX(II)+NUMELC+NUMELTG) = ARRAY(II)
346 ENDIF
347 ENDDO
348c
349 ! Check mean and standard deviation
350 MEAN = SUM(ARRAY)/NB_RANDOM
351 SD = SQRT(SUM((ARRAY - MEAN)**2)/NB_RANDOM)
352c
353 ! Plot the normal distribution
354 IF(I_METHOD == 2) THEN
355 MAX_DISTRIB = ONE /(SD*SQRT(TWO * pi))
356 ELSEIF(I_METHOD == 1) THEN
357 MAX_DISTRIB = ONE /(MAX_VALUE-MIN_VALUE)
358 ENDIF
359 WRITE (IOUT,4500)
360 WRITE(IOUT,*) ' '
361 NB_INTERV = 50
362 SIZEY = 20
363.AND. IF (MINVAL /= -EP30 MAXVAL /= EP30)THEN
364 MIN_VALUE = MINVAL
365 MAX_VALUE = MAXVAL
366 ENDIF
367 CALL PLOT_DISTRIB( ARRAY,NB_RANDOM, NB_INTERV,SIZEY,MIN_VALUE,
368 . MAX_VALUE,MAX_DISTRIB,'#')
369 IF(I_METHOD == 2) THEN
370 WRITE (IOUT,2000) MEAN,SD
371 ELSEIF(I_METHOD == 1) THEN
372 WRITE (IOUT,2050) MEAN
373 ENDIF
374 IF(SEED_RANDOM == 1) WRITE (IOUT,2100) SEED
375 WRITE(IOUT,*) ' '
376 WRITE(IOUT,*) ' '
377 IF (ALLOCATED(ARRAY)) DEALLOCATE(ARRAY)
378 ENDDO
379 DEALLOCATE(TAB_PART)
380C-------------------------------------------------------------
381 6000 FORMAT(/' perturbation id',I10/
382 + ' ---------------'/
383 + ' TYPE . . . . . . . . . . . . . . .',A/
384 + ' input mean VALUE . . . . . . . . .',1PG20.13/
385 + ' input standard deviation . . . . .',1PG20.13/
386 + ' input seed VALUE . . . . . . . . .',I10/
387 + ' solid densities, parts:')
388 6100 FORMAT(/' perturbation id',I10/
389 + ' ---------------'/
390 + ' TYPE . . . . . . . . . . . . . . .',A/
391 + ' input seed VALUE . . . . . . . . .',I10/
392 + ' solid densities, parts:')
393C-------------------------------------------------------------
394 2000 FORMAT(/
395 + ' generated mean VALUE . . . . . . .',1PG20.13/
396 + ' generated standard deviation . . .',1PG20.13)
397 2050 FORMAT(/
398 + ' generated mean VALUE . . . . . . .',1PG20.13)
399 2100 FORMAT(/
400 + ' generated seed VALUE . . . . . . .',I10/)
401C-------------------------------------------------------------
402 4500 FORMAT(/
403 + ' distribution of scale factors applied to densities of solids')
404C------------------------------
405C------------------------------
406 END
hm_get_floatv
subroutine hm_get_floatv(name, rval, is_available, lsubmodel, unitab)
Definition hm_get_floatv.F:415
hm_get_intv
subroutine hm_get_intv(name, ival, is_available, lsubmodel)
Definition hm_get_intv.F:523
hm_get_string
subroutine hm_get_string(name, sval, size, is_available)
Definition hm_get_string.F:76
hm_option_start
subroutine hm_option_start(entity_type)
Definition hm_option_start.F:251
hm_read_perturb_part_solid
subroutine hm_read_perturb_part_solid(ipart, rnoise, igrpart, ipm, iparts, perturb, lsubmodel, unitab, idperturb, index, index_ityp, npart_solid, offs, qp_iperturb, qp_rperturb)
Definition hm_read_perturb_part_solid.F:45
hm_option_read_mod::hm_option_read_key
Definition hm_option_read_mod.F:410
max
#define max(a, b)
Definition macros.h:21
id
initmumps id
Definition multiplerhs_example.m:4
groupdef_mod
Definition groupdef_mod.F:662
hm_option_read_mod
Definition hm_option_read_mod.F:408
message_mod
Definition message_mod.F:1249
names_and_titles_mod
Definition names_and_titles_mod.F:997
names_and_titles_mod::nchartitle
integer, parameter nchartitle
Definition names_and_titles_mod.F:1003
names_and_titles_mod::ncharkey
integer, parameter ncharkey
Definition names_and_titles_mod.F:1000
names_and_titles_mod::ncharfield
integer, parameter ncharfield
Definition names_and_titles_mod.F:1005
submodel_mod
Definition submodel_mod.F:712
unitab_mod
Definition unitab_mod.F:513
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:889
starter
program starter
Definition starter.F:39
submodel_mod::submodel_data
Definition submodel_mod.F:723