OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
w_isph.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/.
23C
24!||====================================================================
25!|| w_isph ../starter/source/restart/ddsplit/w_isph.F
26!||--- called by ------------------------------------------------------
27!|| ddsplit ../starter/source/restart/ddsplit/ddsplit.F
28!||--- calls -----------------------------------------------------
29!|| ancmsg ../starter/source/output/message/message.F
30!||--- uses -----------------------------------------------------
31!|| message_mod ../starter/share/message_module/message_mod.F
32!||====================================================================
33 SUBROUTINE w_isph(KXSP ,IXSP ,NUMSPH_L,CEPSP ,PROC ,
34 + NODLOCAL,NUMNOD_L,ISPCOND ,IPARG ,ISPHIO ,
35 + LEN_IA,SLONFSPH_L,SLPRTSPH_L,IPARTSP,
36 + LONFSPH,LPRTSPH, IBUFSSG_IO, CELSPH ,
37 + NSPHSOL_L,FIRST_SPHSOL_L,SPH2SOL ,SOL2SPH,
38 + IRST ,NUMELS8_L,CEP ,CEL ,SOL2SPH_TYP)
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
304 END
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
w_isph
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)
Definition w_isph.F:39
write_i_c
void write_i_c(int *w, int *len)
Definition write_routtines.c:645