OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
sppro3.F File Reference
#include "implicit_f.inc"
#include "mvsiz_p.inc"
#include "sphcom.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine sppro3 (il, kxsp, ixsp, nod2sp, jvois, jstor, jperm, dvois, ireduce, kreduce, kxspr, ixspr, tab_dk)

Function/Subroutine Documentation

◆ sppro3()

subroutine sppro3 ( integer il,
integer, dimension(nisp,*) kxsp,
integer, dimension(kvoisph,*) ixsp,
integer, dimension(*) nod2sp,
integer, dimension(*) jvois,
integer, dimension(*) jstor,
integer, dimension(*) jperm,
dvois,
integer ireduce,
integer, dimension(*) kreduce,
integer, dimension(*) kxspr,
integer, dimension(kvoisph,*) ixspr,
tab_dk )

Definition at line 32 of file sppro3.F.

35C-----------------------------------------------
36C M o d u l e s
37C-----------------------------------------------
38 USE sphbox
39C-----------------------------------------------
40C I m p l i c i t T y p e s
41C-----------------------------------------------
42#include "implicit_f.inc"
43C-----------------------------------------------
44C G l o b a l P a r a m e t e r s
45C-----------------------------------------------
46#include "mvsiz_p.inc"
47C-----------------------------------------------
48C C o m m o n B l o c k s
49C-----------------------------------------------
50#include "sphcom.inc"
51C-----------------------------------------------
52C D u m m y A r g u m e n t s
53C-----------------------------------------------
54 INTEGER KXSP(NISP,*), IXSP(KVOISPH,*), NOD2SP(*),
55 . JVOIS(*),JSTOR(*), JPERM(*), IREDUCE, KREDUCE(*),
56 . KXSPR(*), IXSPR(KVOISPH,*)
57C REAL
58 my_real
59 . dvois(*),tab_dk(*)
60C-----------------------------------------------
61C L o c a l V a r i a b l e s
62C-----------------------------------------------
63 INTEGER J, KB, JB, NSBT, IB, IL, MM1, MM2, KM, MM, MG,
64 . JJL, NFT, LLT, JL, JG, JLO, LL1, LL2, LL, LG, N, NN,
65 . NVOIS, KL, K, JK, L, NVOIS1, NVOIS2, IERROR
66C REAL
67 my_real
68 . cms2(mvsiz),xjj, yjj, zjj,dk, dl
69 my_real, DIMENSION(:), ALLOCATABLE :: dstor
70
71
72 IF(il <= numsph.AND.il > 0)THEN
73C-----------------
74C TRI DE LA LISTE, GARDE LES KVOISPH PREMIERS
75C (COEF DE SECURITE CROISSANT).
76
77C-----------------
78 nvois=kxsp(5,il)
79 tab_dk(il) = -one
80 IF(nvois>kvoisph)THEN
81
82 ireduce =1
83 kreduce(il)=1
84
85 CALL myqsort(nvois,dvois,jperm,ierror)
86 DO k=1,nvois
87 jstor(k)=jvois(k)
88 ENDDO
89 DO k=1,kvoisph
90 jvois(k)=jstor(jperm(k))
91 ENDDO
92 dk=dvois(kvoisph)
93 tab_dk(il) = dk
94C-----------------
95C Choix des cellules a conserver tq distance < DK pour eviter pb de parith/on
96 nvois=0
97 DO k=1,kxsp(5,il)
98 IF(dvois(k)<dk)THEN
99 nvois=nvois+1
100 END IF
101 END DO
102
103 ENDIF
104C-----------------
105 nvois=min(nvois,kvoisph)
106 kxsp(5,il)=nvois
107 DO k=1,nvois
108 jk=jvois(k)
109 dk=dvois(k)
110
111 IF(jk<=numsph) THEN
112 jg =kxsp(3,jk)
113 ELSE
114 jg = -jk+numsph ! si voisin remote alors no noeud = - no cellule remote
115 xsphr(1,-jg) = -abs(xsphr(1,-jg)) ! reperage cell remote utile
116 END IF
117 ixsp(k,il)=jg
118 ENDDO
119C-----------------------------------------------------------
120 ELSEIF(il > numsph)THEN ! traitement pour cell remote inutile
121C-----------------
122 xsphr(1,il-numsph) = -abs(xsphr(1,il-numsph)) ! reperage cell remote utile
123C
124C TRI DE LA LISTE, GARDE LES KVOISPH PREMIERS
125C (COEF DE SECURITE CROISSANT).
126C-----------------
127! Get the DK of the original cell
128 dk = dkr(il - numsph)
129 nvois=kxspr(il-numsph)
130 IF(dk>=zero) THEN
131 IF(nvois>kvoisph) THEN
132C-----------------
133C Choix des cellules a conserver tq distance < DK pour eviter pb de parith/on
134 nvois=kxspr(il-numsph)
135 CALL myqsort(nvois,dvois,jperm,ierror)
136 DO k=1,nvois
137 jstor(k)=jvois(k)
138 ENDDO
139 DO k=1,min(kvoisph,nvois)
140 jvois(k)=jstor(jperm(k))
141 ENDDO
142 nvois=min(nvois,kvoisph)
143 ELSE
144 ALLOCATE(dstor(kxspr(il-numsph)))
145 DO k=1,kxspr(il-numsph)
146 jstor(k)=jvois(k)
147 dstor(k)=dvois(k)
148 ENDDO
149 nvois=0
150 DO k=1,kxspr(il-numsph)
151 IF(dstor(k)<dk)THEN
152 nvois=nvois+1
153 jvois(nvois)=jstor(k)
154 dvois(nvois)=dstor(k)
155 END IF
156 END DO
157 DEALLOCATE(dstor)
158 nvois=min(nvois,kvoisph)
159 ENDIF
160 ELSE
161 nvois=kxspr(il-numsph)
162 ENDIF
163C-----------------
164 kxspr(il-numsph)=nvois
165 DO k=1,nvois
166 jk=jvois(k)
167 dk=dvois(k)
168 IF(jk<=numsph) THEN
169 jg=kxsp(3,jk)
170 ELSE
171 jg = 0
172 print *,'internal error'
173 END IF
174 ixspr(k,il-numsph)=jg
175 ENDDO
176 ELSE ! IL < 0 <=> Gauge
177C
178Cf gauges IL=-NUMSPH-...
179 il=abs(il)
180C-----------------
181C TRI DE LA LISTE, GARDE LES KVOISPH PREMIERS
182C (COEF DE SECURITE CROISSANT).
183
184C-----------------
185 nvois=kxsp(5,il)
186 IF(nvois>kvoisph)THEN
187
188 CALL myqsort(nvois,dvois,jperm,ierror)
189 DO k=1,nvois
190 jstor(k)=jvois(k)
191 ENDDO
192 DO k=1,kvoisph
193 jvois(k)=jstor(jperm(k))
194 ENDDO
195 dk=dvois(kvoisph)
196C-----------------
197C Choix des cellules a conserver tq distance < DK pour eviter pb de parith/on
198 nvois=0
199 DO k=1,kxsp(5,il)
200 IF(dvois(k)<dk)THEN
201 nvois=nvois+1
202 END IF
203 END DO
204 ENDIF
205C-----------------
206 nvois=min(nvois,kvoisph)
207 kxsp(5,il)=nvois
208 nvois1=0
209 nvois2=nvois
210 DO k=1,nvois
211 jk =jvois(k)
212 dk =dvois(k)
213 IF(jk<=numsph) THEN
214 jg =kxsp(3,jk)
215 ELSE
216 jg = -jk+numsph ! si voisin remote alors no noeud = - no cellule remote
217 xsphr(1,-jg) = -abs(xsphr(1,-jg)) ! reperage cell remote utile
218 END IF
219
220 IF(dk<one)THEN
221 nvois1=nvois1+1
222 ixsp(nvois1,il)=jg
223 ELSE
224 ixsp(nvois2,il)=jg
225 nvois2=nvois2-1
226 ENDIF
227 ENDDO
228 kxsp(4,il)=nvois1
229C-----------------------------------------------------------
230 END IF
231
232 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
min
#define min(a, b)
Definition macros.h:20
myqsort
subroutine myqsort(n, a, perm, error)
Definition myqsort.F:51