OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
asspar3.F File Reference
#include "implicit_f.inc"
#include "comlock.inc"
#include "com01_c.inc"
#include "com04_c.inc"
#include "com08_c.inc"
#include "parit_c.inc"
#include "units_c.inc"
#include "param_c.inc"
#include "task_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine asspar3 (a, ar, itask, nodft, nodlt, stifn, stifr, itab, fsky, fskyv, isky, indsky, fskyi, adskyi, partft, partlt, partsav, ms, fthe, fthesky, ftheskyi, greft, grelt, gresav, itherm_fe, intheat)

Function/Subroutine Documentation

◆ asspar3()

subroutine asspar3 ( a,
ar,
integer itask,
integer nodft,
integer nodlt,
stifn,
stifr,
integer, dimension(*) itab,
fsky,
fskyv,
integer, dimension(*) isky,
integer, dimension(0:*) indsky,
fskyi,
integer, dimension(0:*) adskyi,
integer partft,
integer partlt,
partsav,
ms,
fthe,
fthesky,
ftheskyi,
integer greft,
integer grelt,
gresav,
integer, intent(in) itherm_fe,
integer, intent(in) intheat )

Definition at line 30 of file asspar3.F.

37C----6---------------------------------------------------------------7---------8
38C-----------------------------------------------
39C I m p l i c i t T y p e s
40C-----------------------------------------------
41#include "implicit_f.inc"
42#include "comlock.inc"
43C-----------------------------------------------
44C C o m m o n B l o c k s
45C-----------------------------------------------
46#include "com01_c.inc"
47#include "com04_c.inc"
48#include "com08_c.inc"
49#include "parit_c.inc"
50#include "units_c.inc"
51#include "param_c.inc"
52#include "task_c.inc"
53 integer maxbloc
54 parameter(maxbloc=1000)
55 common/tmparit/nbloc,adbloc(0:maxbloc),nbcol(0:maxbloc),
56 . nbdone(maxbloc),ideb(parasiz),ifin(parasiz)
57 integer nbloc,adbloc,nbcol,nbdone,ideb,ifin
58C-----------------------------------------------------------------
59C D u m m y A r g u m e n t s
60C-----------------------------------------------
61 INTEGER ,INTENT(IN) :: ITHERM_FE
62 INTEGER ,INTENT(IN) :: INTHEAT
63C REAL
64 my_real
65 . a(3,*) ,ar(3,*), stifn(*), stifr(*),fskyv(lsky,8),
66 . fskyi(lskyi,4),partsav(*),fsky(8,lsky), ms(*),
67 . fthe(*), fthesky(*),ftheskyi(lskyi),gresav(*)
68 INTEGER ITASK,NODFT,NODLT,PARTFT,PARTLT,GREFT,GRELT
69 INTEGER ISKY(*),INDSKY(0:*),ADSKYI(0:*),ITAB(*)
70C-----------------------------------------------
71C L o c a l V a r i a b l e s
72C-----------------------------------------------
73 INTEGER I,J,K,L,N,KK,JJ1,JJ2,NN,KM,NUM7,LL,
74 . NISKYFT,NISKYLT, LDONE,IDONE,NC,NL,IFT,ILT,KFT,KLT,
75 . I0,IBAR,KKK,NCT
76 my_real
77 . ff, fskyt(nisky), ftheskyt(nisky)
78 COMMON /assp2/ ldone, idone, ibar
79C-----------------------------------------------
80 IF(nthread*nisky+numnod+2>lenwa)THEN
81 WRITE(iout,*) ' **ERROR** : MEMORY PROBLEM IN PARITH OPTION'
82 WRITE(istdo,*)' **ERROR** : MEMORY PROBLEM IN PARITH OPTION'
83 tstop=zero
84 RETURN
85 ENDIF
86 IF(nisky>lskyi)THEN
87 WRITE(iout,*) ' **ERROR** : MEMORY PROBLEM IN PARITH OPTION'
88 WRITE(istdo,*)' **ERROR** : MEMORY PROBLEM IN PARITH OPTION'
89 tstop=zero
90 RETURN
91 ENDIF
92 niskyft = 1+itask*nisky/ nthread
93 niskylt = (itask+1)*nisky/nthread
94c print *,' nisky=',nisky,' nodlt=',nodlt
95C
96 DO n=nodft,nodlt
97 adskyi(n) = 0
98 ENDDO
99 adskyi(numnod+1) = 0
100C
101 idone = 0
102 ldone = 0
103 ibar = 0
104 DO l=1,nbloc
105 nbdone(l) = -1
106 ENDDO
107 CALL my_barrier
108C-----------------------------------------------
109C FORCES D'INTERFACES
110C-----------------------------------------------
111#include "lockon.inc"
112 IF(idone/=0)THEN
113#include "lockoff.inc"
114 ELSE
115 idone = 1
116#include "lockoff.inc"
117C
118 DO i=1,nisky
119 n = isky(i) +1
120 adskyi(n) = adskyi(n) + 1
121 ENDDO
122C-----------------------------------------------
123C CALCUL DES ADRESSES DU VECTEUR SKYLINE
124C-----------------------------------------------
125 adskyi(0) = 1
126 adskyi(1) = 1
127 DO n=1,numnod
128 nn = n+1
129 adskyi(nn) = adskyi(nn) + adskyi(n)
130 ENDDO
131C-----------------------------------------------
132C TRI DES FORCES EN SKYLINE
133C-----------------------------------------------
134 DO i=1,nisky
135 n = isky(i)
136 j = adskyi(n)
137 isky(i) = j
138 adskyi(n) = adskyi(n) + 1
139 ENDDO
140C
141#include "lockon.inc"
142 idone = 2
143#include "lockoff.inc"
144 ENDIF
145C-----------------------------------------------
146C FORCES D'ELEMENTS
147C-----------------------------------------------
148
149 IF(ivector==1) THEN
150 ELSE
151 DO n = ideb(itask+1), ifin(itask+1)
152 nct = indsky(n)-1
153 nc = indsky(n+1)-indsky(n)
154 IF(itherm_fe == 0 )THEN
155 DO k = nct+1, nct+nc-1
156 DO kk=nct+2,nct+nc
157 DO ll=1,8
158 IF(fsky(ll,kk)<fsky(ll,k))THEN
159 ff = fsky(ll,kk)
160 fsky(ll,kk) = fsky(ll,k)
161 fsky(ll,k) = ff
162 ENDIF
163 ENDDO
164 ENDDO
165 ENDDO
166 ELSE
167 DO k = nct+1, nct+nc-1
168 DO kk=nct+2,nct+nc
169 DO ll=1,8
170 IF(fsky(ll,kk)<fsky(ll,k))THEN
171 ff = fsky(ll,kk)
172 fsky(ll,kk) = fsky(ll,k)
173 fsky(ll,k) = ff
174 ENDIF
175 ENDDO
176 IF(fthesky(kk)<fthesky(k))THEN
177 ff = fthesky(kk)
178 fthesky(kk) = fthesky(k)
179 fthesky(k) = ff
180 ENDIF
181 ENDDO
182 ENDDO
183 ENDIF
184C
185 IF(itherm_fe == 0 ) THEN
186 DO k=nct+1, nct+nc
187 a(1,n) = a(1,n) + max(zero,fsky(1,k))
188 a(2,n) = a(2,n) + max(zero,fsky(2,k))
189 a(3,n) = a(3,n) + max(zero,fsky(3,k))
190 ar(1,n) = ar(1,n) + max(zero,fsky(4,k))
191 ar(2,n) = ar(2,n) + max(zero,fsky(5,k))
192 ar(3,n) = ar(3,n) + max(zero,fsky(6,k))
193 stifn(n) = stifn(n) + max(zero,fsky(7,k))
194 stifr(n) = stifr(n) + max(zero,fsky(8,k))
195 ENDDO
196 DO k=nct+nc, nct+1,-1
197 a(1,n) = a(1,n) + min(zero,fsky(1,k))
198 a(2,n) = a(2,n) + min(zero,fsky(2,k))
199 a(3,n) = a(3,n) + min(zero,fsky(3,k))
200 ar(1,n) = ar(1,n) + min(zero,fsky(4,k))
201 ar(2,n) = ar(2,n) + min(zero,fsky(5,k))
202 ar(3,n) = ar(3,n) + min(zero,fsky(6,k))
203 ENDDO
204 ELSE
205 DO k=nct+1, nct+nc
206 a(1,n) = a(1,n) + max(zero,fsky(1,k))
207 a(2,n) = a(2,n) + max(zero,fsky(2,k))
208 a(3,n) = a(3,n) + max(zero,fsky(3,k))
209 ar(1,n) = ar(1,n) + max(zero,fsky(4,k))
210 ar(2,n) = ar(2,n) + max(zero,fsky(5,k))
211 ar(3,n) = ar(3,n) + max(zero,fsky(6,k))
212 stifn(n) = stifn(n) + max(zero,fsky(7,k))
213 stifr(n) = stifr(n) + max(zero,fsky(8,k))
214 fthe(n) = fthe(n) + max(zero,fthesky(k))
215 ENDDO
216 DO k=nct+nc, nct+1,-1
217 a(1,n) = a(1,n) + min(zero,fsky(1,k))
218 a(2,n) = a(2,n) + min(zero,fsky(2,k))
219 a(3,n) = a(3,n) + min(zero,fsky(3,k))
220 ar(1,n) = ar(1,n) + min(zero,fsky(4,k))
221 ar(2,n) = ar(2,n) + min(zero,fsky(5,k))
222 ar(3,n) = ar(3,n) + min(zero,fsky(6,k))
223 fthe(n) = fthe(n) + min(zero,fthesky(k))
224 ENDDO
225 ENDIF
226C
227 ENDDO
228 ENDIF
229C
230 IF(n2d/=0) THEN
231 CALL my_barrier
232 DO i = nodft, nodlt
233 ms(i) = a(1,i)
234 a(1,i) = zero
235 ENDDO
236 CALL my_barrier
237 ENDIF
238C-----------------------------------------------
239C LE CALL BARRIER EST FAIT SUR TOUS LES PROCES.
240C SI ET SEULEMENT SI LA TACHE IDONE N'EST PAS FAITE
241C QUAND LE PREMIER DES PROCES. ARRIVE ICI
242C-----------------------------------------------
243#include "lockon.inc"
244 IF(idone/=2)ibar = 1
245#include "lockoff.inc"
246 IF(ibar==1)CALL my_barrier
247C-----------------------------------------------
248 DO l=1,4
249#include "lockon.inc"
250 IF(ldone>=l)THEN
251#include "lockoff.inc"
252 ELSE
253 ldone = l
254#include "lockoff.inc"
255 DO i=1,nisky
256 j = isky(i)
257 fskyt(j) = fskyi(i,l)
258 ENDDO
259 DO i=1,nisky
260 fskyi(i,l) = fskyt(i)
261 ENDDO
262C
263 IF(intheat > 0 .AND. l == 1) THEN
264 DO i=1,nisky
265 j = isky(i)
266 ftheskyt(j) = ftheskyi(i)
267 ENDDO
268 DO i=1,nisky
269 ftheskyi(i) = ftheskyt(i)
270 ENDDO
271 ENDIF
272C
273 ENDIF
274 ENDDO
275C
276 CALL my_barrier
277C
278 DO i=niskyft,niskylt
279 isky(i) = 0
280 ENDDO
281 nisky = 0
282C adsKy est decale de 1
283C-----------------------------------------------
284C FORCES D'INTERFACES
285C-----------------------------------------------
286 DO 800 n=nodft,nodlt
287 nn = n-1
288 jj1 = adskyi(nn)
289 jj2 = adskyi(n)-1
290C-----------------------------------------------
291C TRI DES FORCES D'INTERFACES
292C-----------------------------------------------
293 IF(intheat == 0) THEN
294 DO 500 k=jj1,jj2-1
295 DO 500 kk=k+1,jj2
296 DO 500 ll=1,4
297 IF(fskyi(kk,ll)<fskyi(k,ll))THEN
298 ff = fskyi(kk,ll)
299 fskyi(kk,ll) = fskyi(k,ll)
300 fskyi(k,ll) = ff
301 ENDIF
302 500 CONTINUE
303C + la thermique
304 ELSE
305 DO k=jj1,jj2-1
306 DO kk=k+1,jj2
307 DO ll=1,4
308 IF(fskyi(kk,ll)<fskyi(k,ll))THEN
309 ff = fskyi(kk,ll)
310 fskyi(kk,ll) = fskyi(k,ll)
311 fskyi(k,ll) = ff
312 ENDIF
313 ENDDO
314 IF(ftheskyi(kk) < ftheskyi(k))THEN
315 ff = ftheskyi(kk)
316 ftheskyi(kk) = ftheskyi(k)
317 ftheskyi(k) = ff
318 ENDIF
319 ENDDO
320 ENDDO
321 ENDIF
322C-----------------------------------------------
323C ASSEMBLAGE DES FORCES
324C-----------------------------------------------
325 IF(intheat == 0 ) THEN
326 DO k=jj1,jj2
327 a(1,n) = a(1,n) + max(zero,fskyi(k,1))
328 a(2,n) = a(2,n) + max(zero,fskyi(k,2))
329 a(3,n) = a(3,n) + max(zero,fskyi(k,3))
330 stifn(n) = stifn(n) + fskyi(k,4)
331 ENDDO
332 DO k=jj2,jj1,-1
333 a(1,n) = a(1,n) + min(zero,fskyi(k,1))
334 a(2,n) = a(2,n) + min(zero,fskyi(k,2))
335 a(3,n) = a(3,n) + min(zero,fskyi(k,3))
336 ENDDO
337C + la thermique
338 ELSE
339 DO k=jj1,jj2
340 a(1,n) = a(1,n) + max(zero,fskyi(k,1))
341 a(2,n) = a(2,n) + max(zero,fskyi(k,2))
342 a(3,n) = a(3,n) + max(zero,fskyi(k,3))
343 stifn(n) = stifn(n) + fskyi(k,4)
344 fthe(n) = fthe(n) + max(zero,ftheskyi(k))
345 ENDDO
346 DO k=jj2,jj1,-1
347 a(1,n) = a(1,n) + min(zero,fskyi(k,1))
348 a(2,n) = a(2,n) + min(zero,fskyi(k,2))
349 a(3,n) = a(3,n) + min(zero,fskyi(k,3))
350 fthe(n) = fthe(n) + min(zero,ftheskyi(k))
351 ENDDO
352 ENDIF
353 800 CONTINUE
354C-----------------------------------------------
355C
356C 003 NUM7 = 7*NPART
357 num7 = npsav*npart
358C
359 km = 0
360 DO 950 k=1,nthread-1
361 km = km + num7
362 DO 940 i=partft,partlt
363 partsav(i) = partsav(i) + partsav(i+km)
364 partsav(i+km) = zero
365 940 CONTINUE
366 950 CONTINUE
367C
368 CALL my_barrier
369C
370 num7 = npsav*ngpe
371C
372 km = 0
373 IF (nthpart > 0) THEN
374 DO 970 k=1,nthread-1
375 km = km + num7
376#include "vectorize.inc"
377 DO 960 i=greft,grelt
378 gresav(i) = gresav(i) + gresav(i+km)
379 gresav(i+km) = 0.
380 960 CONTINUE
381 970 CONTINUE
382 ENDIF
383 CALL my_barrier
384C
385 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
my_barrier
subroutine my_barrier
Definition machine.F:31