OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
parsorc.F File Reference
#include "implicit_f.inc"
#include "com01_c.inc"
#include "com04_c.inc"
#include "param_c.inc"
#include "task_c.inc"
#include "spmd_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine parsorc (x, d, xnorm, iadd, cdg, bufel, iparg, ixq, ixc, ixtg, elbuf_tab, invert, el2fa, iadg, mater, ipartq, ipartc, ipartur, iparttg, nodglob)

Function/Subroutine Documentation

◆ parsorc()

subroutine parsorc ( x,
d,
xnorm,
integer, dimension(*) iadd,
cdg,
bufel,
integer, dimension(nparg,*) iparg,
integer, dimension(nixq,*) ixq,
integer, dimension(nixc,*) ixc,
integer, dimension(nixtg,*) ixtg,
type (elbuf_struct_), dimension(ngroup) elbuf_tab,
integer, dimension(*) invert,
integer, dimension(*) el2fa,
integer, dimension(nspmd,*) iadg,
integer, dimension(*) mater,
integer, dimension(*) ipartq,
integer, dimension(*) ipartc,
integer, dimension(*) ipartur,
integer, dimension(*) iparttg,
integer, dimension(*) nodglob )

Definition at line 37 of file parsorc.F.

42C-----------------------------------------------
43C M o d u l e s
44C-----------------------------------------------
45 USE elbufdef_mod
46 USE my_alloc_mod
47 use element_mod , only : nixq,nixc,nixtg
48C-----------------------------------------------
49C I m p l i c i t T y p e s
50C-----------------------------------------------
51#include "implicit_f.inc"
52C-----------------------------------------------
53C C o m m o n B l o c k s
54C-----------------------------------------------
55#include "com01_c.inc"
56#include "com04_c.inc"
57#include "param_c.inc"
58#include "task_c.inc"
59#include "spmd_c.inc"
60C-----------------------------------------------
61C D u m m y A r g u m e n t s
62C-----------------------------------------------
63C REAL
64 my_real
65 . x(*),d(*),xnorm(3,*),cdg(*),bufel(*)
66 INTEGER IXC(NIXC,*),IXTG(NIXTG,*),IADD(*),IPARG(NPARG,*),
67 . IXQ(NIXQ,*),
68 . INVERT(*), EL2FA(*),MATER(*),
69 . IADG(NSPMD,*),
70 . IPARTQ(*),IPARTC(*),IPARTTG(*),IPARTUR(*),NODGLOB(*)
71 TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP) :: ELBUF_TAB
72C-----------------------------------------------
73C REAL
74 my_real
75 . off
76 INTEGER II(4),IE,NG, ITY, LFT, LLT, N, I, J,
77 . IPRT, NEL, IAD, NPAR, NFT,MTN,
78 . NN1,NN2,NN3,NN4,NN5,NN6,NN7,NN8,NN9,NN10,
79 . JJ, K, BUF
80 INTEGER,DIMENSION(:),ALLOCATABLE::NP
81C-----------------------------------------------
82 CALL my_alloc(np,(numelq + numelc + numeltg)*4)
83C-----------------------------------------------
84C NORMALE
85C-----------------------------------------------
86C DO 5 I=1,NUMNOD
87
88 DO k=1,numnod
89 DO j=1,3
90 xnorm(j,k) = zero
91 ENDDO
92 ENDDO
93
94 ie = 0
95C
96 nn1 = 1
97 nn2 = 1
98 nn3 = 1
99 nn4 = nn3 + numelq
100 nn5 = nn4 + numelc
101 nn6 = nn5 + numeltg
102 nn7 = nn6
103 nn8 = nn7
104 nn9 = nn8
105 nn10= nn9
106C-----------------------------------------------
107 npar = 0
108C
109C-----------------------------------------------
110C PART
111C-----------------------------------------------
112 jj = 0
113
114 DO 500 iprt=1,npart
115 IF(mater(iprt) == 0)GOTO 500
116 npar = npar + 1
117 DO 490 ng=1,ngroup
118 mtn =iparg(1,ng)
119 nel =iparg(2,ng)
120 nft =iparg(3,ng)
121 iad =iparg(4,ng)
122 ity =iparg(5,ng)
123 lft=1
124 llt=nel
125C-----------------------------------------------
126C QUAD
127C-----------------------------------------------
128 IF(ity == 2)THEN
129 DO 20 i=lft,llt
130 n = i + nft
131 IF(ipartq(n)/=iprt) GOTO 20
132 IF (mtn/=0 .AND. mtn/=13) off=elbuf_tab(ng)%GBUF%OFF(i)
133 ii(1) = ixq(2,n)
134 ii(2) = ixq(3,n)
135 ii(3) = ixq(4,n)
136 ii(4) = ixq(5,n)
137
138 xnorm(1,ii(1)) = one
139 xnorm(2,ii(1)) = zero
140 xnorm(3,ii(1)) = zero
141 IF (nspmd == 1) THEN
142 ii(1) = ii(1)-1
143 ii(2) = ii(2)-1
144 ii(3) = ii(3)-1
145 ii(4) = ii(4)-1
146 CALL write_i_c(ii,4)
147 ELSE
148 np(jj+1) = nodglob(ii(1))-1
149 np(jj+2) = nodglob(ii(2))-1
150 np(jj+3) = nodglob(ii(3))-1
151 np(jj+4) = nodglob(ii(4))-1
152
153 END IF
154 ie = ie + 1
155 invert(ie) = 1
156 el2fa(nn3+n) = ie
157 jj = jj + 4
158 20 CONTINUE
159C-----------------------------------------------
160C COQUES
161C-----------------------------------------------
162 ELSEIF(ity == 3)THEN
163 DO 130 i=lft,llt
164 n = i + nft
165 IF(ipartc(n)/=iprt)GOTO 130
166 IF (mtn /= 0 .AND. mtn /= 13) off=elbuf_tab(ng)%GBUF%OFF(i)
167 ii(1) = ixc(2,n)
168 ii(2) = ixc(3,n)
169 ii(3) = ixc(4,n)
170 ii(4) = ixc(5,n)
171 ie = ie + 1
172
173 CALL facnor(x,d,ii,xnorm,cdg,invert(ie))
174
175 IF (nspmd == 1) THEN
176 ii(1) = ii(1)-1
177 ii(2) = ii(2)-1
178 ii(3) = ii(3)-1
179 ii(4) = ii(4)-1
180 CALL write_i_c(ii,4)
181 ELSE
182 np(jj+1) = nodglob(ii(1))-1
183 np(jj+2) = nodglob(ii(2))-1
184 np(jj+3) = nodglob(ii(3))-1
185 np(jj+4) = nodglob(ii(4))-1
186
187 END IF
188C IE = IE + 1
189 el2fa(nn4+n) = ie
190 jj = jj + 4
191 130 CONTINUE
192C-----------------------------------------------
193C COQUES 3 NOEUDS
194C-----------------------------------------------
195 ELSEIF(ity == 7)THEN
196 DO 170 i=lft,llt
197 n = i + nft
198 IF(iparttg(n)/=iprt)GOTO 170
199 IF (mtn /= 0 .AND. mtn /= 13) off=elbuf_tab(ng)%GBUF%OFF(i)
200 ii(1) = ixtg(2,n)
201 ii(2) = ixtg(3,n)
202 ii(3) = ixtg(4,n)
203 ii(4) = ii(3)
204 ie = ie + 1
205 CALL facnor(x,d,ii,xnorm,cdg,invert(ie))
206 IF (nspmd == 1) THEN
207 ii(1) = ii(1)-1
208 ii(2) = ii(2)-1
209 ii(3) = ii(3)-1
210 ii(4) = ii(4)-1
211 CALL write_i_c(ii,4)
212 ELSE
213 np(jj+1) = nodglob(ii(1))-1
214 np(jj+2) = nodglob(ii(2))-1
215 np(jj+3) = nodglob(ii(3))-1
216 np(jj+4) = nodglob(ii(4))-1
217
218 END IF
219 el2fa(nn5+n) = ie
220 jj = jj + 4
221 170 CONTINUE
222 ELSE
223 ENDIF
224 490 CONTINUE
225C
226
227C-----------------------------------------------
228C PART ADRESS
229C-----------------------------------------------
230 iadd(npar) = ie
231 500 CONTINUE
232c ENDIF
233 IF (nspmd > 1) THEN
234C build global part array on proc 0
235
236 IF (ispmd == 0) THEN
237
238 CALL spmd_iglob_partn(iadd,npar,iadg,npart)
239
240 buf = (numelqg+numelcg+numeltgg)*4
241 CALL spmd_iget_partn(4,jj,np,npar,iadg,buf,1)
242
243 ELSE
244 buf = 1
245 CALL spmd_iglob_partn(iadd,npar,iadg,1)
246 CALL spmd_iget_partn(4,jj,np,npar,iadg,buf,1)
247
248 ENDIF
249 ELSE ! IADG filling for mono/multi compatibility
250 DO i = 1, npart
251 iadg(1,i) = iadd(i)
252 END DO
253 ENDIF
254 DEALLOCATE(np)
255C-----------------------------------------------
256 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
invert
subroutine invert(matrix, inverse, n, errorflag)
Definition hm_read_rbe3.F:1368
spmd_iget_partn
subroutine spmd_iget_partn(size, nbf_l, np, nbpart, iadg, srbuf, iflag)
Definition spmd_iget_partn.F:50
spmd_iglob_partn
subroutine spmd_iglob_partn(iad, nbpart, iadg, sbuf)
Definition spmd_iglob_partn.F:39
facnor
subroutine facnor(x, d, ii, xnorm, cdg, invert)
Definition facnor.F:30
write_i_c
void write_i_c(int *w, int *len)
Definition write_routines.c:645