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 36 of file parsorc.F.

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