OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
parsorc.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/.
23!||====================================================================
24!|| parsorc ../starter/source/output/anim/parsorc.F
25!||--- called by ------------------------------------------------------
26!|| genani1 ../starter/source/output/anim/genani1.F
27!||--- calls -----------------------------------------------------
28!|| facnor ../starter/source/output/anim/facnor.F
29!||--- uses -----------------------------------------------------
30!||====================================================================
31 SUBROUTINE parsorc(X ,D ,XNORM,IADD ,CDG ,
32 . BUFEL,IPARG,IXQ ,IXC ,IXTG ,
33 . INVERT,EL2FA,
34 . MATER,IPARTQ,IPARTC,IPARTTG,
35 . ELBUF_TAB)
36C-----------------------------------------------
37C M o d u l e s
38C-----------------------------------------------
39 USE elbufdef_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"
50C-----------------------------------------------
51C D u m m y A r g u m e n t s
52C-----------------------------------------------
53C REAL
54 my_real
55 . x(*),d(*),xnorm(3,*),cdg(*),bufel(*)
56 INTEGER IXC(NIXC,*),IXTG(NIXTG,*),IADD(*),IPARG(NPARG,*),
57 . IXQ(NIXQ,*),
58 . invert(*), el2fa(*),mater(*),
59 . ipartq(*),ipartc(*),iparttg(*)
60 TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP) :: ELBUF_TAB
61C-----------------------------------------------
62C REAL
63 my_real
64 . off
65 INTEGER II(4),IE,NG, ITY, LFT, LLT, KPT, N, I, J,
66 . IPRT, NEL, IAD, NPAR, NFT, IMID,IALEL,MTN,
67 . nn1,nn2,nn3,nn4,nn5,nn6,nn7,nn8,nn9,nn10,
68 . jj, k, sh_ih, ihbe,buf
69 INTEGER NP((NUMELQ + NUMELC + NUMELTG )*4)
70C-----------------------------------------------
71C NORMALE
72C-----------------------------------------------
73 DO k=1,numnod
74 DO j=1,3
75 xnorm(j,k) = zero
76 ENDDO
77 ENDDO
78 ie = 0
79C
80 nn1 = 1
81 nn2 = 1
82 nn3 = 1
83 nn4 = nn3 + numelq
84 nn5 = nn4 + numelc
85 nn6 = nn5 + numeltg
86 nn7 = nn6
87 nn8 = nn7
88 nn9 = nn8
89C-----------------------------------------------
90 npar = 0
91C
92C-----------------------------------------------
93C PART
94C-----------------------------------------------
95 IF(numelq + numelc + numeltg/=0)THEN
96 jj = 0
97
98 DO 500 iprt=1,npart
99 IF(mater(iprt)==0)GOTO 500
100 npar = npar + 1
101 DO 490 ng=1,ngroup
102 mtn =iparg(1,ng)
103 nel =iparg(2,ng)
104 nft =iparg(3,ng)
105 iad =iparg(4,ng)
106 ity =iparg(5,ng)
107 lft=1
108 llt=nel
109C-----------------------------------------------
110C QUAD
111C-----------------------------------------------
112 IF(ity==2)THEN
113 DO 20 i=lft,llt
114 n = i + nft
115 IF(ipartq(n)/=iprt) GOTO 20
116 IF (mtn/=0 .AND. mtn/=13) off=elbuf_tab(ng)%GBUF%OFF(i)
117 ii(1) = ixq(2,n)
118 ii(2) = ixq(3,n)
119 ii(3) = ixq(4,n)
120 ii(4) = ixq(5,n)
121
122 xnorm(1,ii(1)) = one
123 xnorm(2,ii(1)) = zero
124 xnorm(3,ii(1)) = zero
125 ii(1) = ii(1)-1
126 ii(2) = ii(2)-1
127 ii(3) = ii(3)-1
128 ii(4) = ii(4)-1
129 CALL write_i_c(ii,4)
130 ie = ie + 1
131 invert(ie) = 1
132 el2fa(nn3+n) = ie
133 jj = jj + 4
134 20 CONTINUE
135C-----------------------------------------------
136C COQUES
137C-----------------------------------------------
138 ELSEIF(ity==3)THEN
139 kpt =iparg(6,ng)
140 ihbe = iparg(23,ng)
141 sh_ih = 16
142 IF (ihbe>=21.AND.ihbe<=29) sh_ih = 17
143 IF (ihbe==22) sh_ih = sh_ih + 6
144 DO 130 i=lft,llt
145 n = i + nft
146 IF(ipartc(n)/=iprt)GOTO 130
147 IF (mtn/=0 .AND. mtn/=13) off=elbuf_tab(ng)%GBUF%OFF(i)
148 ii(1) = ixc(2,n)
149 ii(2) = ixc(3,n)
150 ii(3) = ixc(4,n)
151 ii(4) = ixc(5,n)
152 ie = ie + 1
153
154 CALL facnor(x,d,ii,xnorm,cdg,invert(ie))
155
156 ii(1) = ii(1)-1
157 ii(2) = ii(2)-1
158 ii(3) = ii(3)-1
159 ii(4) = ii(4)-1
160 CALL write_i_c(ii,4)
161 el2fa(nn4+n) = ie
162 jj = jj + 4
163 130 CONTINUE
164C-----------------------------------------------
165C COQUES 3 NOEUDS
166C-----------------------------------------------
167 ELSEIF(ity==7)THEN
168 kpt =iparg(6,ng)
169 DO 170 i=lft,llt
170 n = i + nft
171 IF(iparttg(n)/=iprt)GOTO 170
172 IF (mtn/=0 .AND. mtn/=13) off=elbuf_tab(ng)%GBUF%OFF(i)
173 ii(1) = ixtg(2,n)
174 ii(2) = ixtg(3,n)
175 ii(3) = ixtg(4,n)
176 ii(4) = ii(3)
177 ie = ie + 1
178 CALL facnor(x,d,ii,xnorm,cdg,invert(ie))
179 ii(1) = ii(1)-1
180 ii(2) = ii(2)-1
181 ii(3) = ii(3)-1
182 ii(4) = ii(4)-1
183 CALL write_i_c(ii,4)
184 el2fa(nn5+n) = ie
185 jj = jj + 4
186 170 CONTINUE
187
188 ELSE
189 ENDIF
190 490 CONTINUE
191C
192
193C-----------------------------------------------
194C PART ADRESS
195C-----------------------------------------------
196 iadd(npar) = ie
197 500 CONTINUE
198 ENDIF
199C-----------------------------------------------
200 RETURN
201 END
my_real
#define my_real
Definition cppsort.cpp:32
invert
subroutine invert(matrix, inverse, n, errorflag)
Definition hm_read_rbe3.F:1354
facnor
subroutine facnor(x, d, ii, xnorm, cdg, invert)
Definition facnor.F:30
parsorc
subroutine parsorc(x, d, xnorm, iadd, cdg, bufel, iparg, ixq, ixc, ixtg, invert, el2fa, mater, ipartq, ipartc, iparttg, elbuf_tab)
Definition parsorc.F:36
write_i_c
void write_i_c(int *w, int *len)
Definition write_routtines.c:645