OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
pblast_1.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!|| pblast_1 ../engine/source/loads/pblast/pblast_1.F
25!||--- called by ------------------------------------------------------
26!|| pblast_load_computation ../engine/source/loads/pblast/pblast.F
27!||--- calls -----------------------------------------------------
28!|| arret ../engine/source/system/arret.F
29!|| my_barrier ../engine/source/system/machine.F
30!|| omp_get_thread_num ../engine/source/engine/openmp_stub.F90
31!|| pblast_parameters__free_air ../common_source/modules/loads/pblast_mod.F90
32!||--- uses -----------------------------------------------------
33!|| groupdef_mod ../common_source/modules/groupdef_mod.F
34!|| h3d_inc_mod ../engine/share/modules/h3d_inc_mod.F
35!|| h3d_mod ../engine/share/modules/h3d_mod.F
36!|| names_and_titles_mod ../common_source/modules/names_and_titles_mod.F
37!|| output_mod ../common_source/modules/output/output_mod.F90
38!|| pblast_mod ../common_source/modules/loads/pblast_mod.f90
39!|| th_mod ../engine/share/modules/th_mod.F
40!|| th_surf_mod ../common_source/modules/interfaces/th_surf_mod.F
41!||====================================================================
42 SUBROUTINE pblast_1(OUTPUT, PBLAST ,ILOADP ,FAC ,A ,V ,X ,
43 1 IADC ,FSKY ,LLOADP ,FEXT ,NODA_SURF ,NODA_PEXT,
44 2 ITAB ,H3D_DATA ,NL ,DTMIN_LOC ,WFEXT_LOC ,
45 3 TH_SURF ,NSEGPL)
46C-----------------------------------------------
47C M o d u l e s
48C-----------------------------------------------
49 USE h3d_mod
50 USE pblast_mod
51 USE groupdef_mod
52 USE h3d_inc_mod
53 USE th_surf_mod , ONLY : th_surf_
54 USE names_and_titles_mod , ONLY : ncharline
55 USE th_mod , ONLY : th_has_noda_pext
56 USE output_mod
57C-----------------------------------------------
58C I m p l i c i t T y p e s
59C-----------------------------------------------
60#include "implicit_f.inc"
61#include "comlock.inc"
62#include "param_c.inc"
63C-----------------------------------------------
64C C o m m o n B l o c k s
65C-----------------------------------------------
66#include "com04_c.inc"
67#include "com08_c.inc"
68#include "parit_c.inc"
69#include "scr14_c.inc"
70#include "scr16_c.inc"
71#include "mvsiz_p.inc"
72#include "units_c.inc"
73#include "sysunit.inc"
74#include "tabsiz_c.inc"
75C-----------------------------------------------
76C D u m m y A r g u m e n t s
77C-----------------------------------------------
78 type(output_), intent(inout) :: OUTPUT
79 INTEGER,INTENT(IN) :: LLOADP(SLLOADP)
80 INTEGER,INTENT(INOUT) :: ILOADP(SIZLOADP,NLOADP)
81 INTEGER,INTENT(IN) :: IADC(*)
82 INTEGER, INTENT(IN) :: ITAB(NUMNOD),NL
83 my_real,INTENT(INOUT) :: dtmin_loc
84 DOUBLE PRECISION,INTENT(INOUT) :: WFEXT_LOC
85 my_real,INTENT(IN) :: v(3,numnod),x(3,numnod)
86 my_real,INTENT(INOUT) :: fac(lfacload,nloadp)
87 my_real,INTENT(INOUT) :: a(3,numnod),fsky(8,sfsky/8)
88 my_real,INTENT(INOUT) :: fext(3,numnod)
89 my_real,INTENT(INOUT) :: noda_surf(numnod)
90 my_real,INTENT(INOUT) :: noda_pext(numnod)
91 TYPE(h3d_database),INTENT(IN) :: H3D_DATA
92 TYPE (TH_SURF_) , INTENT(INOUT) :: TH_SURF
93 INTEGER, INTENT(INOUT) :: NSEGPL
94 TYPE(friedlander_params_) :: FRIEDLANDER_PARAMS
95 TYPE(pblast_) :: PBLAST
96C-----------------------------------------------
97C L o c a l V a r i a b l e s
98C-----------------------------------------------
99 INTEGER :: N1, N2, N3, N4,IL,IS,IAD,I,IANIM_OR_H3D,IZ_UPDATE,ABAC_ID,ISIZ_SEG,IERR1,
100 . ID, ITA_SHIFT,IMODEL,NN(4),NS,KSURF,NDT
101 INTEGER :: NWARN !< number of segment for which it is not possible to correlate the positive impulse. It may happen that for a given Pmax and dt0 value even building a triangle shape leads to a lower impulse that the targeted one.
102
103 my_real :: zx,zy,zz,norm,nx,ny,nz,area,
104 . cos_theta, alpha_inci, alpha_refl, p_inci, p_refl_,p_inci_, p_refl,z,
105 . i_inci,i_refl,i_inci_,i_refl_, dt_0, t_a,dt_0_,
106 . wave_refl,wave_inci, w13,
107 . dnorm, xdet,ydet,zdet,tdet,wtnt,pmin,t_stop,dx,dy,dz,p,
108 . fac_m_bb, fac_l_bb, fac_t_bb, fac_p_bb, fac_i_bb, ta_first, tt_star, z1_,
109 . decay_inci,decay_refl,zeta,
110 . cst_255_div_ln_z1_on_zn, log10_, npt, ff(3), ta_inf_loc,
111 . surf_patch
112
113 INTEGER, EXTERNAL :: OMP_GET_THREAD_NUM
114
115 LOGICAL,SAVE :: IS_UPDATED
116 LOGICAL :: IS_DECAY_TO_BE_COMPUTED
117
118 CHARACTER(LEN=NCHARLINE) :: MSGOUT1,MSGOUT2
119
120 DATA cst_255_div_ln_z1_on_zn/-38.147316611455952998/
121 DATA log10_ /2.30258509299405000000/
122
123C-----------------------------------------------
124C D e s c r i p t i o n
125C-----------------------------------------------
126C This subroutines is applying pressure load to a segment submitted to a blast wave (FREE AIR model).
127C Preussre time histories are built from "UFC 3-340-02, Dec. 5th 2008" tables which are hardcoded in unit system {g, cm, mus}
128C (table sampling : 256 points ; see pblast_mod.F)
129C
130C T* = T + TA_INF (shift with first arrival time for all pblast option, TA_INF=0. if ita_shift/=2)
131C If request made to update blast profile (iz_update==2) then it is made once on T*=TDET
132C
133C-----------------------------------------------
134C P r e - C o n d i t i o n
135C-----------------------------------------------
136 !--- subroutine not relevant if no /LOAD/PBLAST option
137 IF(pblast%NLOADP_B==0)RETURN
138
139 !--- time step
140 ta_first = fac(07,nl) ! arrival time for first segment to be loaded
141 il= nl-nloadp_f
142 tt_star = tt + pblast%PBLAST_DT%TA_INF
143 iz_update = iloadp(06,nl)
144 tdet = fac(01,nl)
145 ta_first = fac(07,nl) + pblast%PBLAST_DT%TA_INF ! arrival time for first segment to be loaded
146 IF(iz_update ==1)THEN
147 !if no update during engine
148 dtmin_loc = (one+em06)*(ta_first - tt)
149 dtmin_loc=max(pblast%PBLAST_TAB(il)%DTMIN, dtmin_loc) !go directly to arrival time but avoid too
150 IF(tt_star<ta_first)RETURN ! (nothing to load for now)
151 ELSE
152 IF(tdet > tt)THEN
153 dtmin_loc = (one+em06)*(tdet - tt)
154 dtmin_loc=max(pblast%PBLAST_TAB(il)%DTMIN, dtmin_loc)!go directly to arrival time but avoid too
155 ELSE
156 dtmin_loc = pblast%PBLAST_TAB(il)%DTMIN
157 ENDIF
158 IF(tt_star<tdet)RETURN ! (nothing to update for now)
159 ENDIF
160C-----------------------------------------------,
161C S o u r c e C o d e
162C-----------------------------------------------
163 ianim_or_h3d = anim_v(5)+outp_v(5)+h3d_data%N_VECT_FINT + anim_v(6)+outp_v(6)+h3d_data%N_VECT_FEXT !output
164
165 !Index Bijection
166 z1_ = half
167
168 !translation from Working unit System to {big bang} unit system
169 fac_m_bb = fac_mass*ep03
170 fac_l_bb = fac_length*ep02
171 fac_t_bb = fac_time*ep06
172 fac_p_bb = fac_m_bb/fac_l_bb/fac_t_bb/fac_t_bb
173 fac_i_bb = fac_p_bb*fac_t_bb
174 fac_i_bb = fac_m_bb/fac_l_bb/fac_t_bb
175
176 is_updated=.false.
177 CALL my_barrier
178
179 !-----------------------------------------------,
180 ! FREE AIR BURST
181 !-----------------------------------------------
182 il = nl-nloadp_f
183 tdet = fac(01,nl)
184 xdet = fac(02,nl)
185 ydet = fac(03,nl)
186 zdet = fac(04,nl)
187 wtnt = fac(05,nl)
188 pmin = fac(06,nl)
189 ta_first = fac(07,nl)
190 t_stop = fac(13,nl)
191 is = iloadp(02,nl)
192 iz_update = iloadp(06,nl)
193 abac_id = iloadp(07,nl)
194 id = iloadp(08,nl) !user_id
195 ita_shift = iloadp(09,nl)
196 ndt = iloadp(10,nl)
197 imodel = iloadp(11,nl)
198 isiz_seg = iloadp(01,nl)/4
199 ierr1 = 0
200 w13 = (wtnt*fac_m_bb)**third ! '*FAC_M' g->work unit '/FAC_M' : WORK_UNIT -> g
201 z = zero
202 ta_inf_loc = ep20
203
204 is_decay_to_be_computed = .false.
205 IF(imodel == 2)is_decay_to_be_computed=.true.
206 nwarn = 0
207
208 !---------------------------------------------
209 ! LOOP ON SEGMENTS (4N or 3N)
210 !---------------------------------------------
211
212!$OMP DO SCHEDULE(GUIDED,MVSIZ)
213 DO i = 1,isiz_seg
214 n1=lloadp(iloadp(4,nl)+4*(i-1))
215 n2=lloadp(iloadp(4,nl)+4*(i-1)+1)
216 n3=lloadp(iloadp(4,nl)+4*(i-1)+2)
217 n4=lloadp(iloadp(4,nl)+4*(i-1)+3)
218 nn(1)=n1
219 nn(2)=n2
220 nn(3)=n3
221 nn(4)=n4
222
223 IF(n4==0 .OR. n3==n4 )THEN
224 !3-NODE-SEGMENT
225 pblast%PBLAST_TAB(il)%NPt(i) = three
226 npt = three
227 !Centroid segment
228 zx = x(1,n1)+x(1,n2)+x(1,n3)
229 zy = x(2,n1)+x(2,n2)+x(2,n3)
230 zz = x(3,n1)+x(3,n2)+x(3,n3)
231 zx = zx*third
232 zy = zy*third
233 zz = zz*third
234 !Normal vector : (NX,NY,NZ) = 2*S*n where |n|=1.0
235 nx = (x(2,n3)-x(2,n1))*(x(3,n3)-x(3,n2)) - (x(3,n3)-x(3,n1))*(x(2,n3)-x(2,n2))
236 ny = (x(3,n3)-x(3,n1))*(x(1,n3)-x(1,n2)) - (x(1,n3)-x(1,n1))*(x(3,n3)-x(3,n2))
237 nz = (x(1,n3)-x(1,n1))*(x(2,n3)-x(2,n2)) - (x(2,n3)-x(2,n1))*(x(1,n3)-x(1,n2))
238 !NORM = 2*S
239 norm = sqrt(nx*nx+ny*ny+nz*nz)
240 ELSE
241 !4-NODE-SEGMENT
242 pblast%PBLAST_TAB(il)%NPt(i) = four
243 npt = four
244 !Centroid side
245 zx = x(1,n1)+x(1,n2)+x(1,n3)+x(1,n4)
246 zy = x(2,n1)+x(2,n2)+x(2,n3)+x(2,n4)
247 zz = x(3,n1)+x(3,n2)+x(3,n3)+x(3,n4)
248 zx = zx*fourth
249 zy = zy*fourth
250 zz = zz*fourth
251 !Normal vector (NX,NY,NZ) = 2*S*n where |n|=1.0
252 nx = (x(2,n3)-x(2,n1))*(x(3,n4)-x(3,n2)) - (x(3,n3)-x(3,n1))*(x(2,n4)-x(2,n2))
253 ny = (x(3,n3)-x(3,n1))*(x(1,n4)-x(1,n2)) - (x(1,n3)-x(1,n1))*(x(3,n4)-x(3,n2))
254 nz = (x(1,n3)-x(1,n1))*(x(2,n4)-x(2,n2)) - (x(2,n3)-x(2,n1))*(x(1,n4)-x(1,n2))
255 !NORM = 2*S
256 norm = sqrt(nx*nx+ny*ny+nz*nz)
257 ENDIF
258
259 pblast%PBLAST_TAB(il)%N(1,i) = n1
260 pblast%PBLAST_TAB(il)%N(2,i) = n2
261 pblast%PBLAST_TAB(il)%N(3,i) = n3
262 pblast%PBLAST_TAB(il)%N(4,i) = n4
263
264 !--------------------------------------------!
265 ! Update Wave parameters !
266 ! (experimental) !
267 ! If requested. Otherwise use Starter param. !
268 ! Default : do not update:use Starter param. !
269 !--------------------------------------------!
270 IF(iz_update == 2)THEN
271
272 dtmin_loc = ep20
273
274 !Dist
275 dx = (xdet - zx)*fac_l_bb ! => working unit to cm
276 dy = (ydet - zy)*fac_l_bb ! => ... to cm
277 dz = (zdet - zz)*fac_l_bb ! => ... to cm
278 dnorm = sqrt(dx*dx+dy*dy+dz*dz)
279
280 !Angle from Detonation Point
281 cos_theta = dx*nx + dy*ny + dz*nz
282 cos_theta = cos_theta/max(em20,norm*dnorm)
283
284 !scaled distance
285 z = dnorm / w13 !in abac unit ID g,cm,mus
286 !display warning message if out of bounds
287 ! precondition for SUBROUTINE PBLAST_PARAMETERS__FREE_AIR
288 IF(z <= 0.5 .AND. pblast%PBLAST_TAB(il)%TAGMSG(i) == 0 )THEN
289 write(iout, fmt='(A,I0,A)') "Warning : /LOAD/PBLAST id=",id," R/W**(1/3) < 0.5 cm/g**(1/3)"
290 write(istdo,fmt='(A,I0,A)') "Warning : /LOAD/PBLAST id=",id," R/W**(1/3) < 0.5 cm/g**(1/3)"
291 write(iout, fmt='(A)') " Radial Distance R too close to the charge"
292 write(istdo,fmt='(A)') " Radial Distance R too close to the charge"
293
294 if (n4 == 0 .OR. n3 == n4)then
295 write(iout, fmt='(A,3I11)') " -> Segment nodes : ", itab(n1),itab(n2),itab(n3)
296 write(istdo,fmt='(A,3I11)') " -> Segment nodes : ", itab(n1),itab(n2),itab(n3)
297 else
298 write(iout, fmt='(A,4I11)') " -> Segment nodes : ", itab(n1),itab(n2),itab(n3),itab(n4)
299 write(istdo,fmt='(A,4I11)') " -> Segment nodes : ", itab(n1),itab(n2),itab(n3),itab(n4)
300 endif
301 pblast%PBLAST_TAB(il)%TAGMSG(i) = 1
302
303 ELSEIF(z > 400. and. pblast%PBLAST_TAB(il)%TAGMSG(i) == 0)THEN
304 write(iout, fmt='(A,I0,A)') "Warning : /LOAD/PBLAST id=",id," R/W**(1/3) > 400. cm/g**(1/3)"
305 write(istdo,fmt='(A,I0,A)') "Warning : /LOAD/PBLAST id=",id," R/W**(1/3) > 400. cm/g**(1/3)"
306 WRITE(iout, fmt='(A)') " Radial Distance R too far from the charge"
307 WRITE(istdo,fmt='(A)') " Radial Distance R too far from the charge"
308 if (n4 == 0 .OR. n3 == n4)then
309 write(iout, fmt='(A,3I11)') " -> Segment nodes : ", itab(n1),itab(n2),itab(n3)
310 write(istdo,fmt='(A,3I11)') " -> Segment nodes : ", itab(n1),itab(n2),itab(n3)
311 else
312 write(iout, fmt='(A,4I11)') " -> Segment nodes : ", itab(n1),itab(n2),itab(n3),itab(n4)
313 write(istdo,fmt='(A,4I11)') " -> Segment nodes : ", itab(n1),itab(n2),itab(n3),itab(n4)
314 endif
315 pblast%PBLAST_TAB(il)%TAGMSG(i) = 1
316 ENDIF
317
318 !------------------------------------------------------------------!
319 CALL pblast_parameters__free_air(pblast,z, w13, tdet,
320 + fac_p_bb, fac_i_bb, fac_t_bb,
321 + is_decay_to_be_computed,
322 + friedlander_params,nwarn)
323
324 p_inci = friedlander_params%P_inci
325 p_inci_ = friedlander_params%P_inci_
326 p_refl = friedlander_params%P_refl
327 p_refl_ = friedlander_params%P_refl_
328 i_inci = friedlander_params%I_inci
329 i_inci_ = friedlander_params%I_inci_
330 i_refl = friedlander_params%I_refl
331 i_refl_ = friedlander_params%I_refl_
332 t_a = friedlander_params%T_A
333 dt_0 = friedlander_params%DT_0
334 dt_0_ = friedlander_params%DT_0_
335 decay_inci = friedlander_params%decay_inci
336 decay_refl = friedlander_params%decay_refl
337 !------------------------------------------------------------------!
338
339 ta_inf_loc = min(ta_inf_loc, t_a)
340
341 !update wave parameters
342 pblast%PBLAST_TAB(il)%cos_theta(i) = cos_theta
343 pblast%PBLAST_TAB(il)%P_inci(i) = p_inci
344 pblast%PBLAST_TAB(il)%P_refl(i) = p_refl
345 pblast%PBLAST_TAB(il)%ta(i) = t_a
346 pblast%PBLAST_TAB(il)%t0(i) = dt_0
347 pblast%PBLAST_TAB(il)%decay_inci(i) = decay_inci
348 pblast%PBLAST_TAB(il)%decay_refl(i) = decay_refl
349
350 dtmin_loc = min(dtmin_loc,dt_0/ndt)
351 is_updated = .true.
352
353 else! => IZ_UPDATE=1
354
355 !use wave parameters from Starter
356 z=zero
357 cos_theta = pblast%PBLAST_TAB(il)%cos_theta(i)
358 p_inci = pblast%PBLAST_TAB(il)%P_inci(i)
359 p_refl = pblast%PBLAST_TAB(il)%P_refl(i)
360 t_a = pblast%PBLAST_TAB(il)%ta(i)
361 dt_0 = pblast%PBLAST_TAB(il)%t0(i)
362 decay_inci = pblast%PBLAST_TAB(il)%decay_inci(i)
363 decay_refl = pblast%PBLAST_TAB(il)%decay_refl(i)
364 dtmin_loc = pblast%PBLAST_TAB(il)%DTMIN
365
366 ENDIF !IF(IZ_UPDATE == 2)
367
368 !Coefficients for wave superimposition
369 !PressureLoad = Reflected_Pressure * cos2X + IncidentPressure * (1 + cos2X -2 cosX)
370 IF(cos_theta<=zero)THEN
371 !Surface not facing the point of explosion
372 alpha_refl = zero
373 alpha_inci = one
374 ELSE
375 alpha_refl = cos_theta**2 ! cos**2 a
376 alpha_inci = one + cos_theta - two * alpha_refl ! 1 + cos a -2 cos**2 a
377 ENDIF
378
379 !Building pressure waves from Friedlander model. (Modified model can bu introduced later if needed)
380 wave_inci = zero
381 wave_refl = zero
382 IF(tt_star>=t_a)THEN
383 wave_inci = p_inci*(one-(tt_star-t_a)/dt_0)*exp(-decay_inci*(tt_star-t_a)/dt_0)
384 wave_refl = p_refl*(one-(tt_star-t_a)/dt_0)*exp(-decay_refl*(tt_star-t_a)/dt_0)
385 ELSE
386 wave_inci = zero
387 wave_refl = zero
388 ENDIF
389 p = alpha_refl * wave_refl + alpha_inci * wave_inci
390 p = max(p,pmin)
391 pblast%PBLAST_TAB(il)%PRES(i) = p
392
393 !!Expand Pressure load to nodes
394 ! FF is nodal force which applied on each node N1,N2,N3, and also N4 if relevant
395 ! FF = FF_elem / NPT = Pload.S.n / NPT where n is the unitary normal vector
396 ! NX,NY,NZ = 2S.n (in all cases:quadrangles & triangles)
397 surf_patch = half*sqrt(nx*nx+ny*ny+nz*nz) / npt
398 ff(1) = -p * half*nx / npt ! -P*S/NPT . nx
399 ff(2) = -p * half*ny / npt ! -P*S/NPT . ny
400 ff(3) = -p * half*nz / npt ! -P*S/NPT . nz
401 !storing force for one node of the current face (for assembly below)
402 pblast%PBLAST_TAB(il)%FX(i) = ff(1)
403 pblast%PBLAST_TAB(il)%FY(i) = ff(2)
404 pblast%PBLAST_TAB(il)%FZ(i) = ff(3)
405 pblast%PBLAST_TAB(il)%SURF_PATCH(i) = surf_patch
406
407 !External Force work
408 ! on a given node : DW = <F,V>*dt
409 ! for this current 4-node or 3-node face : DW = sum( <F_k,V_k>*dt k=1,NPT) where F_k=Fel/NPT
410 wfext_loc=wfext_loc+dt1*(ff(1)*sum(v(1,nn(1:nint(npt)))) +ff(2)*sum(v(2,nn(1:nint(npt)))) +ff(3)*sum(v(3,nn(1:nint(npt)))))
411
412C----- /TH/SURF -------
413 IF(th_surf%LOADP_FLAG > 0 ) THEN
414 nsegpl = nsegpl + 1
415 area = surf_patch * npt
416 DO ns=th_surf%LOADP_KSEGS(nsegpl) +1,th_surf%LOADP_KSEGS(nsegpl+1)
417 ksurf = th_surf%LOADP_SEGS(ns)
418 th_surf%channels(4,ksurf)= th_surf%channels(4,ksurf) + area*p ! mean pressure
419 th_surf%channels(5,ksurf)= th_surf%channels(5,ksurf) + area ! suface where pressure is applied
420 ENDDO
421 ENDIF
422
423 enddo!next I
424!$OMP END DO
425
426 IF(imodel == 2 .AND. nwarn > 0)THEN
427 msgout1=''
428 WRITE(msgout1,fmt='(I0,A)') nwarn,
429 . ' SEGMENT(S) HAS EXCESSIVE POSITIVE IMPULSE REGARDING THE PEAK PRESSURE AND POSITIVE DURATION.'
430 msgout2=''
431 msgout2='A TRIANGULAR WAVEFORM WILL BE USED INSTEAD TO MAXIMIZE THE IMPULSE. DEFINING A PMIN VALUE IS STRONGLY RECOMMENDED'
432 write(iout , fmt='(A,I10,/A,/A)') "Updated parameters for /LOAD/PBLAST id=", id, msgout1, msgout2
433 write(istdo, fmt='(A,I10,/A,/A)') "Updated parameters for /LOAD/PBLAST id=", id, msgout1, msgout2
434 ENDIF
435
436 CALL my_barrier
437 IF(is_updated)THEN
438#include "lockon.inc"
439 !---arrival time
440 zeta = fac(07,nl)
441 fac(07,nl) = min(ta_inf_loc, fac(07,nl)) !smp min value
442 !---time step
443 dtmin_loc = (one+em06)*(fac(07,nl) - tt) ! go directly to trigger time
444 dtmin_loc=max(pblast%PBLAST_TAB(il)%DTMIN, dtmin_loc)
445 !---no update on next cycle
446 iz_update = 1 !update done
447 iloadp(06,nl) = iz_update
448#include "lockoff.inc"
449!$OMP SINGLE
450 write(iout,fmt='(A,I10,A,E16.8,A,E16.8)') "Updated parameters for /LOAD/PBLAST id=",
451 . id,' previous first arrival time :',zeta,
452 . ' is now updated to :',fac(07,nl)
453 write(istdo,fmt='(A,I10,A,E16.8,A,E16.8)') "Updated parameters for /LOAD/PBLAST id=",
454 . id,' previous first arrival time :',zeta,
455 . ' is now updated to :',fac(07,nl)
456!$OMP END SINGLE
457 ENDIF
458
459 !-------------------------------------------------------------------!
460 ! FORCE ASSEMBLY !
461 ! /PARITH/OFF : F directly added in A(1:3,1:NUMNOD). !
462 ! /PARITH/ON : F added FSKY & and automatically treated later !
463 !-------------------------------------------------------------------!
464 ! SPMD/SMP Parith/OFF
465 IF(iparit==0) THEN
466!$OMP SINGLE
467 DO i = 1,isiz_seg
468 n1=lloadp(iloadp(4,nl)+4*(i-1))
469 n2=lloadp(iloadp(4,nl)+4*(i-1)+1)
470 n3=lloadp(iloadp(4,nl)+4*(i-1)+2)
471 n4=lloadp(iloadp(4,nl)+4*(i-1)+3)
472 a(1,n1)=a(1,n1)+pblast%PBLAST_TAB(il)%FX(i)
473 a(2,n1)=a(2,n1)+pblast%PBLAST_TAB(il)%FY(i)
474 a(3,n1)=a(3,n1)+pblast%PBLAST_TAB(il)%FZ(i)
475 a(1,n2)=a(1,n2)+pblast%PBLAST_TAB(il)%FX(i)
476 a(2,n2)=a(2,n2)+pblast%PBLAST_TAB(il)%FY(i)
477 a(3,n2)=a(3,n2)+pblast%PBLAST_TAB(il)%FZ(i)
478 a(1,n3)=a(1,n3)+pblast%PBLAST_TAB(il)%FX(i)
479 a(2,n3)=a(2,n3)+pblast%PBLAST_TAB(il)%FY(i)
480 a(3,n3)=a(3,n3)+pblast%PBLAST_TAB(il)%FZ(i)
481 IF(pblast%PBLAST_TAB(il)%NPt(i) == four)THEN
482 a(1,n4)=a(1,n4)+pblast%PBLAST_TAB(il)%FX(i)
483 a(2,n4)=a(2,n4)+pblast%PBLAST_TAB(il)%FY(i)
484 a(3,n4)=a(3,n4)+pblast%PBLAST_TAB(il)%FZ(i)
485 ENDIF
486 ENDDO
487!$OMP END SINGLE
488 ELSE
489!$OMP DO SCHEDULE(GUIDED,MVSIZ)
490 DO i = 1,isiz_seg
491 iad =iadc(iloadp(4,nl)+4*(i-1))
492 fsky(1,iad) =pblast%PBLAST_TAB(il)%FX(i)
493 fsky(2,iad) =pblast%PBLAST_TAB(il)%FY(i)
494 fsky(3,iad) =pblast%PBLAST_TAB(il)%FZ(i)
495 iad =iadc(iloadp(4,nl)+4*(i-1)+1)
496 fsky(1,iad) =pblast%PBLAST_TAB(il)%FX(i)
497 fsky(2,iad) =pblast%PBLAST_TAB(il)%FY(i)
498 fsky(3,iad) =pblast%PBLAST_TAB(il)%FZ(i)
499 iad =iadc(iloadp(4,nl)+4*(i-1)+2)
500 fsky(1,iad) =pblast%PBLAST_TAB(il)%FX(i)
501 fsky(2,iad) =pblast%PBLAST_TAB(il)%FY(i)
502 fsky(3,iad) =pblast%PBLAST_TAB(il)%FZ(i)
503 IF(pblast%PBLAST_TAB(il)%NPt(i) == four)THEN
504 iad =iadc(iloadp(4,nl)+4*(i-1)+3)
505 fsky(1,iad) =pblast%PBLAST_TAB(il)%FX(i)
506 fsky(2,iad) =pblast%PBLAST_TAB(il)%FY(i)
507 fsky(3,iad) =pblast%PBLAST_TAB(il)%FZ(i)
508 ENDIF
509 ENDDO
510!$OMP END DO
511 ENDIF !IPARIT
512
513
514 !-------------------------------------------!
515 ! ANIMATION FILE /ANIM/VECT/FEXT !
516 ! H3D FILE /H3D/NODA/FEXT !
517 !-------------------------------------------!
518!$OMP SINGLE
519 IF(ianim_or_h3d > 0) THEN
520 DO i = 1,isiz_seg
521 n1=pblast%PBLAST_TAB(il)%N(1,i)
522 n2=pblast%PBLAST_TAB(il)%N(2,i)
523 n3=pblast%PBLAST_TAB(il)%N(3,i)
524 n4=pblast%PBLAST_TAB(il)%N(4,i)
525 fext(1,n1) = fext(1,n1)+pblast%PBLAST_TAB(il)%FX(i)
526 fext(2,n1) = fext(2,n1)+pblast%PBLAST_TAB(il)%FY(i)
527 fext(3,n1) = fext(3,n1)+pblast%PBLAST_TAB(il)%FZ(i)
528 fext(1,n2) = fext(1,n2)+pblast%PBLAST_TAB(il)%FX(i)
529 fext(2,n2) = fext(2,n2)+pblast%PBLAST_TAB(il)%FY(i)
530 fext(3,n2) = fext(3,n2)+pblast%PBLAST_TAB(il)%FZ(i)
531 fext(1,n3) = fext(1,n3)+pblast%PBLAST_TAB(il)%FX(i)
532 fext(2,n3) = fext(2,n3)+pblast%PBLAST_TAB(il)%FY(i)
533 fext(3,n3) = fext(3,n3)+pblast%PBLAST_TAB(il)%FZ(i)
534 IF(pblast%PBLAST_TAB(il)%NPt(i)==four)THEN
535 fext(1,n4) = fext(1,n4)+pblast%PBLAST_TAB(il)%FX(i)
536 fext(2,n4) = fext(2,n4)+pblast%PBLAST_TAB(il)%FY(i)
537 fext(3,n4) = fext(3,n4)+pblast%PBLAST_TAB(il)%FZ(i)
538 ENDIF
539 ENDDO
540 ENDIF
541 IF(th_has_noda_pext > 0 .OR. output%DATA%ANIM_HAS_NODA_PEXT > 0 .OR. output%DATA%H3D_HAS_NODA_PEXT > 0) THEN
542 DO i = 1,isiz_seg
543 n1 = pblast%PBLAST_TAB(il)%N(1,i)
544 n2 = pblast%PBLAST_TAB(il)%N(2,i)
545 n3 = pblast%PBLAST_TAB(il)%N(3,i)
546 n4 = pblast%PBLAST_TAB(il)%N(4,i)
547 surf_patch = pblast%PBLAST_TAB(il)%SURF_PATCH(i)
548 noda_surf(n1) = noda_surf(n1) + surf_patch
549 noda_surf(n2) = noda_surf(n2) + surf_patch
550 noda_surf(n3) = noda_surf(n3) + surf_patch
551 p = pblast%PBLAST_TAB(il)%PRES(i) * surf_patch
552 noda_pext(n1) = noda_pext(n1) + p
553 noda_pext(n2) = noda_pext(n2) + p
554 noda_pext(n3) = noda_pext(n3) + p
555 IF(pblast%PBLAST_TAB(il)%NPT(i) == four)THEN
556 noda_surf(n4) = noda_surf(n4) + surf_patch
557 noda_pext(n4) = noda_pext(n4) + p
558 ENDIF
559 ENDDO
560 ENDIF
561!$OMP END SINGLE
562
563 RETURN
564
565C-----------------------------------------------
566 IF (ierr1/=0) THEN
567 WRITE(iout,*)' ** ERROR IN MEMORY ALLOCATION - PBLAST LOADING'
568 WRITE(istdo,*)' ** ERROR IN MEMORY ALLOCATION - PBLAST LOADING'
569 CALL arret(2)
570 END IF
571C-----------------------------------------------
572 END SUBROUTINE pblast_1
my_real
#define my_real
Definition cppsort.cpp:32
norm
norm(diag(diag(diag(inv(mat))) -id.SOL), 2) % destroy mumps instance id.JOB
area
subroutine area(d1, x, x2, y, y2, eint, stif0)
Definition hm_read_prop32.F:567
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
h3d_inc_mod
Definition h3d_inc_mod.F:42
h3d_mod
Definition h3d_mod.F:311
names_and_titles_mod
Definition names_and_titles_mod.F:1002
names_and_titles_mod::ncharline
integer, parameter ncharline
Definition names_and_titles_mod.F:1006
th_mod
Definition th_mod.F:42
th_mod::th_has_noda_pext
integer th_has_noda_pext
Definition th_mod.F:121
th_surf_mod
OPTION /TH/SURF outputs of Pressure and Area needed Tabs.
Definition th_surf_mod.F:61
pblast_1
subroutine pblast_1(output, pblast, iloadp, fac, a, v, x, iadc, fsky, lloadp, fext, noda_surf, noda_pext, itab, h3d_data, nl, dtmin_loc, wfext_loc, th_surf, nsegpl)
Definition pblast_1.F:46
arret
subroutine arret(nn)
Definition arret.F:86
my_barrier
subroutine my_barrier
Definition machine.F:31
h3d_mod::h3d_database
Definition h3d_mod.F:438
th_surf_mod::th_surf_
Definition th_surf_mod.F:76