OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
w_isph.F File Reference
#include "implicit_f.inc"
#include "com01_c.inc"
#include "com04_c.inc"
#include "param_c.inc"
#include "sphcom.inc"
#include "tabsiz_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine w_isph (kxsp, ixsp, numsph_l, cepsp, proc, nodlocal, numnod_l, ispcond, iparg, isphio, len_ia, slonfsph_l, slprtsph_l, ipartsp, lonfsph, lprtsph, ibufssg_io, celsph, nsphsol_l, first_sphsol_l, sph2sol, sol2sph, irst, numels8_l, cep, cel, sol2sph_typ)

Function/Subroutine Documentation

◆ w_isph()

subroutine w_isph ( integer, dimension(nisp,*) kxsp,
integer, dimension(kvoisph,*) ixsp,
integer numsph_l,
integer, dimension(*) cepsp,
integer proc,
integer, dimension(*) nodlocal,
integer numnod_l,
integer, dimension(*) ispcond,
integer, dimension(nparg,*) iparg,
integer, dimension(*) isphio,
integer len_ia,
integer slonfsph_l,
integer slprtsph_l,
integer, dimension(*) ipartsp,
integer, dimension(*) lonfsph,
integer, dimension(*) lprtsph,
integer, dimension(sibufssg_io) ibufssg_io,
integer, dimension(numsph) celsph,
integer nsphsol_l,
integer first_sphsol_l,
integer, dimension(*) sph2sol,
integer, dimension(2,*) sol2sph,
integer, dimension(3,*) irst,
integer numels8_l,
integer, dimension(*) cep,
integer, dimension(*) cel,
integer, dimension(*) sol2sph_typ )

Definition at line 33 of file w_isph.F.

39 USE message_mod
40C-----------------------------------------------
41C I m p l i c i t T y p e s
42C-----------------------------------------------
43#include "implicit_f.inc"
44C-----------------------------------------------
45C C o m m o n B l o c k s
46C-----------------------------------------------
47#include "com01_c.inc"
48#include "com04_c.inc"
49#include "param_c.inc"
50#include "sphcom.inc"
51#include "tabsiz_c.inc"
52C-----------------------------------------------
53C D u m m y A r g u m e n t s
54C-----------------------------------------------
55 INTEGER NUMSPH_L, PROC, LEN_IA, NUMNOD_L,
56 . KXSP(NISP,*), IXSP(KVOISPH,*), CEPSP(*), NODLOCAL(*),
57 . ISPCOND(*), IPARG(NPARG,*),
58 . ISPHIO(*), SLONFSPH_L, SLPRTSPH_L,
59 . IPARTSP(*),LONFSPH(*),LPRTSPH(*),
60 . IBUFSSG_IO(SIBUFSSG_IO),CELSPH(NUMSPH),
61 . NSPHSOL_L,FIRST_SPHSOL_L,SPH2SOL(*),SOL2SPH(2,*),
62 . IRST(3,*), NUMELS8_L,CEP(*),CEL(*),SOL2SPH_TYP(*)
63
64 INTEGER, DIMENSION(:), ALLOCATABLE :: LPRTSPH_L
65 INTEGER, DIMENSION(:), ALLOCATABLE :: LONFSPH_L,IBUFSSG_IO_L
66 INTEGER, DIMENSION(:), ALLOCATABLE :: SPH2SOL_L,ISPSYM,SOL2SPH_TYPL
67 INTEGER, DIMENSION(:,:), ALLOCATABLE :: SOL2SPH_L,IRST_L,IXSP_L
68C-----------------------------------------------
69C L o c a l V a r i a b l e s
70C-----------------------------------------------
71 INTEGER I, J, IE_L, NG, NG_L,
72 . KXSP_L(NISP,NUMSPH_L),
73 . SUIVSPH_L,IPRT,
74 . N,STAT, INULL, IUN, NUMSPH_EL
75 INTEGER, DIMENSION(:), ALLOCATABLE :: NOD2SP_L,NGLOCAL,ISPHIO_L
76C-----------------------------------------------
77! allocate 1d array
78 ALLOCATE( nod2sp_l(numnod_l),nglocal(ngroup) )
79 ALLOCATE( isphio_l(sisphio) )
80! ------------------------------------
81C
82 ALLOCATE( ixsp_l(kvoisph,numsph_l) ,stat=stat)
83 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
84 . msgtype=msgerror,
85 . c1='IXSP_L')
86c inlet outl spmd
87 IF(nsphio>0)THEN
88 ALLOCATE(lonfsph_l(slonfsph_l) ,stat=stat)
89 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
90 . msgtype=msgerror,
91 . c1='DOMDEC')
92 lonfsph_l(1:slonfsph_l)= 0
93
94 ALLOCATE(lprtsph_l(slprtsph_l) ,stat=stat)
95 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
96 . msgtype=msgerror,
97 . c1='DOMDEC')
98 lprtsph_l(1:slprtsph_l) = 0
99
100 ALLOCATE(ibufssg_io_l(sibufssg_io) ,stat=stat)
101 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
102 . msgtype=msgerror,
103 . c1='DOMDEC')
104 ibufssg_io_l(1:sibufssg_io) = 0
105 ENDIF
106c
107 IF(nsphsol_l/=0)THEN
108 ALLOCATE(sph2sol_l(numsph_l) ,stat=stat)
109 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
110 . msgtype=msgerror,
111 . c1='SPH2SOL_L')
112 sph2sol_l(1:numsph_l)= 0
113 ALLOCATE(sol2sph_l(2,numels8_l) ,stat=stat)
114 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
115 . msgtype=msgerror,
116 . c1='SOL2SPH_L')
117 sol2sph_l(1:2,1:numels8_l)= 0
118 ALLOCATE(irst_l(3,nsphsol_l) ,stat=stat)
119 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
120 . msgtype=msgerror,
121 . c1='IRST_L')
122 irst_l(1:3,1:nsphsol_l)= 0
123 ALLOCATE(sol2sph_typl(numels8_l) ,stat=stat)
124 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
125 . msgtype=msgerror,
126 . c1='SOL2SPH_TYPL')
127 sol2sph_typl(1:numels8_l)= 0
128 END IF
129c
130 IF(nspcond>0)THEN
131 ALLOCATE(ispsym(numsph_l*nspcond) ,stat=stat)
132 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
133 . msgtype=msgerror,
134 . c1='ISPSYM')
135 END IF
136c
137 ng_l = 0
138 DO ng = 1, ngroup
139 IF(iparg(32,ng)==proc) THEN
140 ng_l = ng_l + 1
141 nglocal(ng) = ng_l
142 ELSE
143 nglocal(ng) = 0
144 END IF
145 END DO
146C
147 DO i = 1, numnod_l
148 nod2sp_l(i) = 0
149 END DO
150 DO i = 1, kvoisph
151 DO j = 1, numsph_l
152 ixsp_l(i,j) = 0
153 END DO
154 END DO
155C
156 ie_l = 0
157C
158 DO i = 1, numsph
159 IF(cepsp(i)==proc) THEN
160 ie_l = ie_l + 1
161c num locale des cellules SPH
162 DO j = 1, nisp
163 kxsp_l(j,ie_l) = kxsp(j,i)
164 END DO
165 kxsp_l(2,ie_l) = sign(nglocal(sign(kxsp_l(2,ie_l),1)),
166 . kxsp_l(2,ie_l))
167 kxsp_l(3,ie_l) = nodlocal(kxsp_l(3,ie_l))
168 nod2sp_l(kxsp_l(3,ie_l)) = ie_l
169 DO j = 1, kxsp_l(5,ie_l)
170 ixsp_l(j,ie_l) = nodlocal(ixsp(j,i))
171 END DO
172 END IF
173 END DO
174C
175 CALL write_i_c(kxsp_l,numsph_l*nisp)
176 inull=0
177 iun =1
178 DO i=1,nbgauge*nisp
179 CALL write_i_c(inull,iun)
180 END DO
181 CALL write_i_c(ixsp_l,numsph_l*kvoisph)
182 DO i=1,nbgauge*kvoisph
183 CALL write_i_c(inull,iun)
184 END DO
185 CALL write_i_c(nod2sp_l,numnod_l)
186
187 len_ia = len_ia + (numsph_l+nbgauge)*nisp
188 . + (numsph_l+nbgauge)*kvoisph + numnod_l
189C
190 IF(nspcond>0)THEN
191 DO i = 1, nspcond*numsph_l
192 ispsym(i) = 0
193 END DO
194 CALL write_i_c(ispsym,numsph_l*nspcond)
195 CALL write_i_c(ispcond,nispcond*nspcond)
196 len_ia = len_ia + numsph_l*nspcond + nispcond*nspcond
197 DEALLOCATE(ispsym)
198 END IF
199
200 IF(nsphio > 0) THEN
201c SLPRTSPH_L is already set to SLPRTSPH
202 suivsph_l = 0
203 DO iprt=1,npart
204 DO n=1,numsph
205 IF(cepsp(n)==proc.AND.ipartsp(n)==iprt.AND.
206 . (kxsp(2,n) > 0 .OR. (kxsp(2,n)/=0.AND.
207 . n >= first_sphsol .AND. n < first_sphsol+nsphsol)))THEN
208 suivsph_l=suivsph_l+1
209 lonfsph_l(suivsph_l)=celsph(n)
210 ENDIF
211 ENDDO
212 lprtsph_l((iprt-1)*2+1+2)=suivsph_l
213 DO n=1,numsph
214 IF(cepsp(n)==proc.AND.ipartsp(n)==iprt.AND.
215 . (kxsp(2,n) < 0.AND.
216 . (n < first_sphsol .OR. n >= first_sphsol+nsphsol)))THEN
217 suivsph_l=suivsph_l+1
218 lonfsph_l(suivsph_l)=celsph(n)
219 ENDIF
220 ENDDO
221 lprtsph_l((iprt-1)*2+2+2)=suivsph_l
222 ENDDO
223
224c on passe IBUFSSG_IO en local
225 DO i = 1, sibufssg_io
226 ibufssg_io_l(i) = nodlocal(ibufssg_io(i))
227 ENDDO
228
229c on passe ISPHIO en local pour les outlet definies par noeuds
230 DO i = 1, nsphio
231 DO n=1,nisphio
232 isphio_l(nisphio*(i-1)+n) = isphio(nisphio*(i-1)+n)
233 END DO
234 IF (isphio(nisphio*(i-1)+12)==2) THEN
235 isphio_l(nisphio*(i-1)+13) = nodlocal(isphio(nisphio*(i-1)+13))
236 isphio_l(nisphio*(i-1)+14) = nodlocal(isphio(nisphio*(i-1)+14))
237 isphio_l(nisphio*(i-1)+15) = nodlocal(isphio(nisphio*(i-1)+15))
238 ENDIF
239 ENDDO
240
241 CALL write_i_c(isphio_l,sisphio)
242 CALL write_i_c(lprtsph_l,slprtsph_l)
243 CALL write_i_c(lonfsph_l,slonfsph_l)
244 CALL write_i_c(ibufssg_io_l,sibufssg_io)
245 len_ia = len_ia + sisphio + slprtsph_l + slonfsph_l +
246 . sibufssg_io
247
248 DEALLOCATE(lprtsph_l,lonfsph_l,ibufssg_io_l)
249 END IF
250C
251 IF(nsphsol_l/=0)THEN
252
253 ie_l = 0
254 DO i = 1, nsphsol
255 IF(cepsp(first_sphsol+i-1)==proc) THEN
256 ie_l = ie_l + 1
257 IF(cep(sph2sol(first_sphsol+i-1))/=proc)THEN
258 write(6,'(A)')
259 . 'internal error - Solid and SPH not on the same domain'
260 stop
261 END IF
262 sph2sol_l(first_sphsol_l+ie_l-1)=
263 . cel(sph2sol(first_sphsol+i-1))
264c
265 irst_l(1,ie_l)=irst(1,i)
266 irst_l(2,ie_l)=irst(2,i)
267 irst_l(3,ie_l)=irst(3,i)
268c
269 END IF
270 END DO
271C
272 ie_l = 0
273 DO i=1,numels8
274 IF (cep(i)==proc) THEN
275 ie_l = ie_l + 1
276 numsph_el = sol2sph(2,i) - sol2sph(1,i)
277 IF (numsph_el > 0) THEN
278C SOL2SPH(1,N)+1<=I<=SOLSPH(2,N) <=> N==SPH2SOL(I)
279 sol2sph_l(1,ie_l)=celsph(sol2sph(1,i)+1)-1
280 sol2sph_l(2,ie_l)=celsph(sol2sph(2,i))
281 sol2sph_typl(ie_l)=sol2sph_typ(i)
282 ENDIF
283 END IF
284 END DO
285C
286 CALL write_i_c(sph2sol_l,numsph_l)
287 CALL write_i_c(sol2sph_l,2*numels8_l)
288 CALL write_i_c(irst_l ,3*nsphsol_l)
289 CALL write_i_c(sol2sph_typl,numels8_l)
290 len_ia = len_ia + numsph_l + 2*numels8_l + 3*nsphsol_l
291C
292 DEALLOCATE(sph2sol_l,sol2sph_l,irst_l,sol2sph_typl)
293C
294 END IF
295C
296! ------------------------------------
297! deallocate 1d array
298 DEALLOCATE(ixsp_l)
299 DEALLOCATE( nod2sp_l,nglocal )
300 DEALLOCATE( isphio_l )
301! ------------------------------------
302C
303 RETURN
message_mod
Definition message_mod.F:1249
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
write_i_c
void write_i_c(int *w, int *len)
Definition write_routtines.c:645