OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
spmd_fiadd25e_pon.F File Reference
#include "implicit_f.inc"
#include "parit_c.inc"
#include "scr07_c.inc"
#include "scr14_c.inc"
#include "scr16_c.inc"
#include "com01_c.inc"
#include "com04_c.inc"
#include "com06_c.inc"
#include "com08_c.inc"
#include "assert.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine spmd_fiadd25e_pon (output, nb, len, bufr, nsv, fskyi, isky, ibc, isecin, noint, ibag, icodt, secfcum, nstrf, icontact, fcont, inacti, iadm, intth, ftheskyi, condnskyi, h3d_data, ledge, sedge, nedge, nin, tagncont, kloadpinter, loadpinter, loadp_hyd_inter)

Function/Subroutine Documentation

◆ spmd_fiadd25e_pon()

subroutine spmd_fiadd25e_pon ( type(output_), intent(inout) output,
integer nb,
integer len,
bufr,
integer, dimension(*) nsv,
fskyi,
integer, dimension(*) isky,
integer ibc,
integer isecin,
integer noint,
integer ibag,
integer, dimension(*) icodt,
secfcum,
integer, dimension(*) nstrf,
integer, dimension(*) icontact,
fcont,
integer inacti,
integer iadm,
integer intth,
ftheskyi,
condnskyi,
type(h3d_database) h3d_data,
integer, dimension(sedge,nedge) ledge,
integer sedge,
integer nedge,
integer nin,
integer, dimension(nloadp_hyd_inter,numnod) tagncont,
integer, dimension(ninter+1) kloadpinter,
integer, dimension(ninter*nloadp_hyd) loadpinter,
integer, dimension(nloadp_hyd) loadp_hyd_inter )

Definition at line 37 of file spmd_fiadd25e_pon.F.

44C-----------------------------------------------
45C M o d u l e s
46C-----------------------------------------------
47 USE message_mod
48 USE h3d_mod
49 USE debug_mod
50 USE output_mod
51C-----------------------------------------------
52C I m p l i c i t T y p e s
53C-----------------------------------------------
54#include "implicit_f.inc"
55C-----------------------------------------------
56C C o m m o n B l o c k s
57C-----------------------------------------------
58#include "parit_c.inc"
59#include "scr07_c.inc"
60#include "scr14_c.inc"
61#include "scr16_c.inc"
62#include "com01_c.inc"
63#include "com04_c.inc"
64#include "com06_c.inc"
65#include "com08_c.inc"
66#include "assert.inc"
67C-----------------------------------------------
68C D u m m y A r g u m e n t s
69C-----------------------------------------------
70 TYPE(OUTPUT_), intent(inout) :: OUTPUT
71 INTEGER NB, LEN, IBC ,ISECIN ,IBAG , NOINT, INACTI,
72 . NSV(*), ISKY(*), ICODT(*), NSTRF(*),ICONTACT(*),
73 . TAGNCONT(NLOADP_HYD_INTER,NUMNOD),
74 . KLOADPINTER(NINTER+1),LOADPINTER(NINTER*NLOADP_HYD),
75 . LOADP_HYD_INTER(NLOADP_HYD),
76 . IADM,INTTH,NIN
77 INTEGER :: SEDGE,NEDGE
78 INTEGER :: LEDGE(SEDGE,NEDGE)
79 my_real
80 . bufr(len,*),
81 . fskyi(lskyi,nfskyi), secfcum(7,numnod,nsect),
82 . fcont(3,*),ftheskyi(lskyi),condnskyi(lskyi)
83 TYPE(H3D_DATABASE) :: H3D_DATA
84C-----------------------------------------------
85C L o c a l V a r i a b l e s
86C-----------------------------------------------
87 INTEGER I, J, II, N, NOD, K0, K1S, IBCS, IBCM, NBINTER,
88 . NISKY_SAV,NOD1,NOD2,PP,PPL
89 INTEGER NB_EDGE
90C-----------------------------------------------
91C S o u r c e L i n e s
92C-----------------------------------------------
93 IF ((nisky+nb)> lskyi)THEN
94 CALL ancmsg(msgid=26,anmode=aninfo)
95 CALL arret(2)
96 ENDIF
97C
98 nb_edge = nb
99 nisky_sav = nisky
100 DO i = 1, nb_edge
101 n = nint(bufr(1,i))
102 assert(n > 0)
103 assert(n <= nedge)
104 IF(intth == 0 ) THEN
105C issue: not sure to receive the FKSKY in this order
106C#ifdef D_ES
107C IF(LEDGE(8,N) == D_ES) THEN
108C WRITE(6,*) "EDGE:",N,LEDGE(5,N),LEDGE(6,N),BUFR(10,I)
109C ENDIF
110C#endif
111 nod = ledge(5,n)
112 nisky = nisky + 1
113 fskyi(nisky,1)=bufr(2,i)
114 fskyi(nisky,2)=bufr(3,i)
115 fskyi(nisky,3)=bufr(4,i)
116 fskyi(nisky,4)=bufr(5,i)
117C IF(KDTINT /= 0) FSKYI(NISKY,5) = BUFR(6,I)
118 isky(nisky) = nod
119
120C#ifdef D_EM
121C IF(ITAB_DEBUG(NOD) == 29442) THEN
122C WRITE(6,"(A,I10,3Z20)") __FILE__,ITAB_DEBUG(NOD),BUFR(2,I),BUFR(3,I),BUFR(4,I)
123C ENDIF
124C#endif
125
126 assert(bufr(6,i) == bufr(1,i))
127
128 nod = ledge(6,n)
129 nisky = nisky + 1
130 fskyi(nisky,1)=bufr(7,i)
131 fskyi(nisky,2)=bufr(8,i)
132 fskyi(nisky,3)=bufr(9,i)
133 fskyi(nisky,4)=bufr(10,i)
134C IF(KDTINT /= 0) FSKYI(NISKY,5) = BUFR(11,I)
135 isky(nisky) = nod
136
137
138C#ifdef D_EM
139C IF(ITAB_DEBUG(NOD) == 29442) THEN
140C WRITE(6,"(A,I10,3Z20)") __FILE__,ITAB_DEBUG(NOD),BUFR(7,I),BUFR(8,I),BUFR(9,I)
141C ENDIF
142C#endif
143
144 ENDIF
145 ENDDO
146
147 IF(intth /= 0 ) THEN
148 ! THERMAL ANALYSIS + TYPE25 not available yet
149 assert(.false.)
150C NISKY = NISKY_SAV
151C DO I = 1, NB
152C NISKY = NISKY + 1
153C FTHESKYI(NISKY)=BUFR(TEMP_SIZ,I)
154C ENDDO
155C TEMP_SIZ=TEMP_SIZ+1
156C
157C IF(NODADT_THERM ==1) THEN
158C NISKY = NISKY_SAV
159C DO I = 1, NB
160C NISKY = NISKY + 1
161C CONDNSKYI(NISKY)=BUFR(TEMP_SIZ,I)
162C ENDDO
163C TEMP_SIZ=TEMP_SIZ+1
164C ENDIF
165 ENDIF
166
167
168C
169C continuation of i7for3 and i10for3 processing on secondary node
170C
171 IF((anim_v(4)+outp_v(4)+h3d_data%N_VECT_CONT >0.AND.
172 . ((tt>=output%TANIM .AND. tt<=output%TANIM_STOP).OR.tt>=toutp.OR.(tt>=h3d_data%TH3D.AND.tt<=h3d_data%TH3D_STOP).OR.
173 . (manim>=4.AND.manim<=15)))
174 . .OR.anim_v(26)+h3d_data%N_VECT_CONT_MAX>0)THEN
175C Anim FCONT
176 DO i = 1, nb_edge
177 n = nint(bufr(1,i))
178 nod = ledge(5,n)
179 fcont(1,nod)=fcont(1,nod)+bufr(2,i)
180 fcont(2,nod)=fcont(2,nod)+bufr(3,i)
181 fcont(3,nod)=fcont(3,nod)+bufr(4,i)
182 nod = ledge(6,n)
183 fcont(1,nod)=fcont(1,nod)+bufr(7,i)
184 fcont(2,nod)=fcont(2,nod)+bufr(8,i)
185 fcont(3,nod)=fcont(3,nod)+bufr(9,i)
186 END DO
187 END IF
188C
189C------------For /LOAD/PRESSURE tag nodes in contact-------------
190 IF(nintloadp > 0) THEN
191 DO i = 1, nb
192 n = nint(bufr(1,i))
193 nod1 = ledge(5,n)
194 nod2 = ledge(6,n)
195 DO pp = kloadpinter(nin)+1, kloadpinter(nin+1)
196 ppl = loadp_hyd_inter(pp)
197 tagncont(ppl,nod1) = 1
198 tagncont(ppl,nod2) = 1
199 ENDDO
200 ENDDO
201 ENDIF
202C
203 IF(isecin>0)THEN
204C Sections
205 k0=nstrf(25)
206 IF(nstrf(1)+nstrf(2)/=0)THEN
207 DO i=1,nsect
208 nbinter=nstrf(k0+14)
209 k1s=k0+30
210 DO j=1,nbinter
211 IF(nstrf(k1s)==noint)THEN
212 IF(isecut/=0)THEN
213 DO ii = 1, nb
214 n = nint(bufr(1,ii))
215 nod = ledge(5,n)
216 IF(secfcum(4,nod,i)==1.)THEN
217 secfcum(1,nod,i)=secfcum(1,nod,i)+bufr(2,ii)
218 secfcum(2,nod,i)=secfcum(2,nod,i)+bufr(3,ii)
219 secfcum(3,nod,i)=secfcum(3,nod,i)+bufr(4,ii)
220 ENDIF
221 nod = ledge(6,n)
222 IF(secfcum(4,nod,i)==1.)THEN
223 secfcum(1,nod,i)=secfcum(1,nod,i)+bufr(7,ii)
224 secfcum(2,nod,i)=secfcum(2,nod,i)+bufr(8,ii)
225 secfcum(3,nod,i)=secfcum(3,nod,i)+bufr(9,ii)
226 ENDIF
227 ENDDO
228 ENDIF
229 ENDIF
230 k1s=k1s+1
231 ENDDO
232 k0=nstrf(k0+24)
233 ENDDO
234 ENDIF
235 ENDIF
236C
237 IF((ibag/=0.AND.inacti/=7).OR.
238 . (iadm/=0).OR.(idamp_rdof/=0)) THEN ! warning: conflict inacti = 7 and ibag = 3
239C Airbags IBAG
240 DO i = 1, nb
241 IF(bufr(2,i)/=zero.OR.bufr(3,i)/=zero.OR.
242 + bufr(4,i)/=zero) THEN
243 n = nint(bufr(1,i))
244 nod = ledge(5,n)
245 icontact(nod)=1
246 nod = ledge(6,n)
247 icontact(nod)=1
248 END IF
249 END DO
250 END IF
251C
252 IF(ibc/=0) THEN
253 ibcm = ibc / 8
254 ibcs = ibc - 8 * ibcm
255C Boundary cond.
256 IF(ibcs>0) THEN
257 DO i = 1, nb
258 n = nint(bufr(1,i))
259 nod = ledge(5,n)
260 CALL ibcoff(ibcs,icodt(nod))
261 nod = ledge(6,n)
262 CALL ibcoff(ibcs,icodt(nod))
263 END DO
264 END IF
265 END IF
266
267 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
ibcoff
subroutine ibcoff(ibc, icodt)
Definition ibcoff.F:44
debug_mod
Definition debug_mod.F:47
h3d_mod
Definition h3d_mod.F:311
message_mod
Definition message_mod.F:1257
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
arret
subroutine arret(nn)
Definition arret.F:86