OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
dxyzsect.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 SPMD_AGETMSR /spe/spmd_anim.F
24C SSPMD_AGET_SECT /spe/spmd_anim.F
25!||====================================================================
26!|| dxyzsect ../engine/source/output/anim/generate/dxyzsect.F
27!||--- called by ------------------------------------------------------
28!|| genani ../engine/source/output/anim/generate/genani.F
29!||--- calls -----------------------------------------------------
30!|| dxwalc ../engine/source/output/anim/generate/dxwalc.f
31!|| dxwall ../engine/source/output/anim/generate/dxwall.f
32!|| dxwalp ../engine/source/output/anim/generate/dxwalp.F
33!|| dxwals ../engine/source/output/anim/generate/dxwals.F
34!|| spmd_aget_sect ../engine/source/mpi/anim/spmd_aget_sect.F
35!|| spmd_agetmsr ../engine/source/mpi/anim/spmd_agetmsr.F
36!|| write_r_c ../common_source/tools/input_output/write_routtines.c
37!||====================================================================
38 SUBROUTINE dxyzsect (NSTRF,RWBUF,NPRW ,X ,XMIN ,
39 2 YMIN ,ZMIN ,XMAX ,YMAX , ZMAX,
40 3 FR_SEC,FR_WALL,WEIGHT,ITAB)
41C-----------------------------------------------
42C I m p l i c i t T y p e s
43C-----------------------------------------------
44#include "implicit_f.inc"
45C-----------------------------------------------
46C C o m m o n B l o c k s
47C-----------------------------------------------
48#include "param_c.inc"
49#include "com04_c.inc"
50#include "task_c.inc"
51#include "com01_c.inc"
52C-----------------------------------------------
53C D u m m y A r g u m e n t s
54C-----------------------------------------------
55 INTEGER NSTRF(*),NPRW(*),ITAB(*)
56 my_real
57 . rwbuf(nrwlp,*),x(3,*),xmin ,ymin ,zmin ,xmax ,ymax, zmax
58 integer
59 . fr_sec(nspmd+1,*),fr_wall(nspmd+2,*),weight(*)
60C-----------------------------------------------
61C L o c a l V a r i a b l e s
62C-----------------------------------------------
63 INTEGER J, I, K, K0, K1, N, NSEG, N1, N2, N3, N4,MSR, ITYP
64 my_real
65 . xx1, yy1, zz1, xx2, yy2, zz2, xx3, yy3, zz3,
66 . xx4, yy4, zz4, d13, xxc, yyc, zzc, al4,xwl,ywl,zwl,
67 . pmain,loc_proc
68
69 my_real
70 . xsec(3,3,nsect)
71 REAL R4,SBUF(3*NSECT)
72CC-----------------------------------------------
73 loc_proc=ispmd+1
74 k1=1
75 IF (nspmd == 1) THEN
76 k1 = 33
77 DO i=1,nsect
78 n1 = nstrf(k1+1)
79 n2 = nstrf(k1+2)
80 n3 = nstrf(k1+3)
81 xx1=x(1,n1)
82 yy1=x(2,n1)
83 zz1=x(3,n1)
84 xx2=x(1,n2)
85 yy2=x(2,n2)
86 zz2=x(3,n2)
87 xx3=x(1,n3)
88 yy3=x(2,n3)
89 zz3=x(3,n3)
90 xx4=xx2-xx1
91 yy4=yy2-yy1
92 zz4=zz2-zz1
93 al4=sqrt(xx4**2+yy4**2+zz4**2)
94 xx4=xx4/max(al4,em20)
95 yy4=yy4/max(al4,em20)
96 zz4=zz4/max(al4,em20)
97C
98 d13=(xx3-xx1)*xx4+(yy3-yy1)*yy4+(zz3-zz1)*zz4
99 xxc=xx1+d13*xx4
100 yyc=yy1+d13*yy4
101 zzc=zz1+d13*zz4
102C
103 r4 = xxc
104 CALL write_r_c(r4,1)
105 r4 = yyc
106 CALL write_r_c(r4,1)
107 r4 = zzc
108 CALL write_r_c(r4,1)
109C
110 k1= nstrf(k1+22)+2
111 ENDDO
112 ELSE
113 IF (nsect > 0) CALL spmd_aget_sect(nstrf,x,xsec,weight,itab)
114
115 IF (ispmd==0) THEN
116
117 DO i=1,nsect
118
119 xx1 = xsec(1,1,i)
120 yy1 = xsec(1,2,i)
121 zz1 = xsec(1,3,i)
122
123 xx2 = xsec(2,1,i)
124 yy2 = xsec(2,2,i)
125 zz2 = xsec(2,3,i)
126
127 xx3 = xsec(3,1,i)
128 yy3 = xsec(3,2,i)
129 zz3 = xsec(3,3,i)
130C
131 xx4=xx2-xx1
132 yy4=yy2-yy1
133 zz4=zz2-zz1
134 al4=sqrt(xx4**2+yy4**2+zz4**2)
135
136 xx4=xx4/max(al4,em20)
137 yy4=yy4/max(al4,em20)
138 zz4=zz4/max(al4,em20)
139C
140 d13=(xx3-xx1)*xx4+(yy3-yy1)*yy4+(zz3-zz1)*zz4
141 xxc=xx1+d13*xx4
142 yyc=yy1+d13*yy4
143 zzc=zz1+d13*zz4
144C
145 r4 = xxc
146 CALL write_r_c(r4,1)
147 r4 = yyc
148 CALL write_r_c(r4,1)
149 r4 = zzc
150 CALL write_r_c(r4,1)
151 ENDDO
152 ENDIF
153 ENDIF
154C
155 k=1
156 DO n=1,nrwall
157 n2=n +nrwall
158 n3=n2+nrwall
159 n4=n3+nrwall
160 msr = nprw(n3)
161 IF (nspmd == 1) THEN
162 IF(msr==0)THEN
163 xwl=rwbuf(4,n)
164 ywl=rwbuf(5,n)
165 zwl=rwbuf(6,n)
166 ELSE
167C verifier que ce noeud est sur proc0 !
168 xwl=x(1,msr)
169 ywl=x(2,msr)
170 zwl=x(3,msr)
171 ENDIF
172 ELSE
173 CALL spmd_agetmsr(fr_wall(1,n),x,msr,xwl,ywl,zwl,rwbuf(1,n))
174 END IF
175 IF (ispmd==0) THEN
176 ityp= nprw(n4)
177 IF(ityp==4)THEN
178 xwl = xwl + half*(rwbuf(7,n)+rwbuf(10,n))
179 ywl = ywl + half*(rwbuf(8,n)+rwbuf(11,n))
180 zwl = zwl + half*(rwbuf(9,n)+rwbuf(12,n))
181 ENDIF
182 k=k+nprw(n)
183 IF(nprw(n4)==-1)k=k+nint(rwbuf(8,n))
184 r4 = xwl
185 CALL write_r_c(r4,1)
186 r4 = ywl
187 CALL write_r_c(r4,1)
188 r4 = zwl
189 CALL write_r_c(r4,1)
190 END IF
191 ENDDO
192C
193 k=1
194 DO n=1,nrwall
195 n2=n +nrwall
196 n3=n2+nrwall
197 n4=n3+nrwall
198 ityp= nprw(n4)
199
200 IF(iabs(ityp)==1)THEN
201 CALL dxwall(x,rwbuf(1,n),nprw(n3),xmin ,ymin ,
202 . zmin ,xmax ,ymax , zmax,fr_wall(1,n))
203 ELSEIF(ityp==2)THEN
204 CALL dxwalc(x,rwbuf(1,n),nprw(n3),xmin ,ymin ,
205 . zmin ,xmax ,ymax , zmax,fr_wall(1,n))
206 ELSEIF(ityp==3)THEN
207 CALL dxwals(x,rwbuf(1,n),nprw(n3),fr_wall(1,n))
208 ELSEIF(ityp==4)THEN
209 CALL dxwalp(x,rwbuf(1,n),nprw(n3),fr_wall(1,n))
210 ENDIF
211 k=k+nprw(n)
212 IF(nprw(n4)==-1)k=k+nint(rwbuf(8,n))
213 ENDDO
214C
215 RETURN
216 END
dxyzsect
subroutine dxyzsect(nstrf, rwbuf, nprw, x, xmin, ymin, zmin, xmax, ymax, zmax, fr_sec, fr_wall, weight, itab)
Definition dxyzsect.F:41
ymax
subroutine ymax(idn, fac, npc, pld, stiffmin, stiffmax, stiffini, stiffavg)
Definition law100_upd.F:272
max
#define max(a, b)
Definition macros.h:21
spmd_aget_sect
subroutine spmd_aget_sect(nstrf, x, xsec, weight, itab)
Definition spmd_aget_sect.F:32
spmd_agetmsr
subroutine spmd_agetmsr(fr_wall, x, msr, xwl, ywl, zwl, rwl)
Definition spmd_agetmsr.F:36
dxwalc
subroutine dxwalc(x, rwl, msr, xmin, ymin, zmin, xmax, ymax, zmax)
Definition dxwalc.F:32
dxwall
subroutine dxwall(x, rwl, msr, xmin, ymin, zmin, xmax, ymax, zmax)
Definition dxwall.F:32
dxwalp
subroutine dxwalp(x, rwl, msr)
Definition dxwalp.F:30
dxwals
subroutine dxwals(x, rwl, msr)
Definition dxwals.F:30
write_r_c
void write_r_c(float *w, int *len)
Definition write_routtines.c:519