OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
switch_to_dtnoda.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!|| switch_to_dtnoda ../engine/source/time_step/switch_to_dtnoda.F
25!||--- called by ------------------------------------------------------
26!|| radioss2 ../engine/source/engine/radioss2.F
27!||--- calls -----------------------------------------------------
28!|| ancmsg ../engine/source/output/message/message.F
29!|| arret ../engine/source/system/arret.F
30!||--- uses -----------------------------------------------------
31!|| elbufdef_mod ../common_source/modules/mat_elem/elbufdef_mod.F90
32!|| groupdef_mod ../common_source/modules/groupdef_mod.F
33!|| message_mod ../engine/share/message_module/message_mod.F
34!|| my_alloc_mod ../common_source/tools/memory/my_alloc.f90
35!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
36!||====================================================================
37 SUBROUTINE switch_to_dtnoda(
38 . IXR ,GEO ,PM ,IPARG ,ELBUF_TAB,
39 . MS ,IN ,ITAB ,IGEO ,IPM ,
40 . UPARAM ,IPART ,IGRNOD ,IGRPART)
41C-----------------------------------------------
42C M o d u l e s
43C-----------------------------------------------
44 USE elbufdef_mod
45 USE groupdef_mod
46 USE message_mod
47 USE my_alloc_mod
48C-----------------------------------------------
49C I m p l i c i t T y p e s
50C-----------------------------------------------
51 USE spmd_comm_world_mod, ONLY : spmd_comm_world
52#include "implicit_f.inc"
53C-----------------------------------------------
54C G l o b a l P a r a m e t e r s
55C-----------------------------------------------
56#include "mvsiz_p.inc"
57C-----------------------------------------------
58C M e s s a g e P a s s i n g
59C-----------------------------------------------
60#include "spmd.inc"
61C-----------------------------------------------
62C C o m m o n B l o c k s
63C-----------------------------------------------
64#include "param_c.inc"
65#include "com01_c.inc"
66#include "com04_c.inc"
67#include "scr02_c.inc"
68#include "scr17_c.inc"
69#include "scr18_c.inc"
70#include "sms_c.inc"
71#include "sphcom.inc"
72#include "tabsiz_c.inc"
73#include "task_c.inc"
74#include "vect01_c.inc"
75C-----------------------------------------------
76C D u m m y A r g u m e n t s
77C-----------------------------------------------
78 INTEGER IXR(NIXR,*), ITAB(*),
79 . IGEO(NPROPGI,*),IPM(NPROPMI,*),IPARG(NPARG,*)
80 INTEGER, DIMENSION(SIPART), TARGET :: IPART
81C REAL
82 my_real
83 . geo(npropg,*),pm(npropm,*),uparam(*),ms(*),in(*)
84C-----------------------------------------------
85 TYPE(elbuf_struct_), DIMENSION(NGROUP), TARGET :: ELBUF_TAB
86 TYPE (GROUP_) , DIMENSION(NGRNOD) :: IGRNOD
87 TYPE (GROUP_) ,DIMENSION(NGRPART) :: IGRPART
88C-----------------------------------------------
89C L o c a l V a r i a b l e s
90C-----------------------------------------------
91 INTEGER I,N,N1,N2,IPID,IMAT,IADBUF,IEQUI,IP,IERR,IERROR,
92 . K1,K11,K12,K13,K14,
93 . IOK,IDTGRX,NG
94 INTEGER I15ATH,I15A,I15B,I15C,I15D,I15E,I15F,I15G,I15H,I15I,I15J,I15K
95C REAL
96 my_real
97 . xkm, xcm, xkr, xcr, xin(mvsiz)
98 TYPE(g_bufel_) ,POINTER :: GBUF
99 INTEGER, DIMENSION(:), POINTER :: IPARTR
100 INTEGER, DIMENSION(:), ALLOCATABLE :: TAGN
101 INTEGER, DIMENSION(:), ALLOCATABLE :: TAGR
102 INTEGER, DIMENSION(:), ALLOCATABLE :: TAGPRT_SMS
103C-----------------------------------------------------
104 CALL my_alloc(tagn,numnod)
105 CALL my_alloc(tagr,numelr)
106 CALL my_alloc(tagprt_sms,npart)
107C-----------------------------------------------------
108C Check for springs with stiffness but no mass
109C ... Switch for cohesive elements should also be done here ...
110C-----------------------------------------------------
111 i15ath=1+lipart1*(npart+nthpart)
112 i15a=i15ath+2*9*(npart+nthpart)
113 i15b=i15a+numels
114 i15c=i15b+numelq
115 i15d=i15c+numelc
116 i15e=i15d+numelt
117 i15f=i15e+numelp
118 i15g=i15f+numelr
119 i15h=i15g+0
120 i15i=i15h+numeltg
121 i15j=i15i+numelx
122 i15k=i15j+numsph
123C
124 ipartr => ipart(i15f:i15g-1)
125C-----------------------------------------------------
126 IF(nodadt/=0)THEN
127 IF(idtgr(11)==0)THEN
128 tagn(1:numnod)=1
129 ELSE
130 tagn(1:numnod)=0
131 iok = 0
132 DO n=1,ngrnod
133 IF (iabs(idtgr(11))==igrnod(n)%ID) THEN
134 idtgrx= n
135 iok = 1
136 ENDIF
137 ENDDO
138 IF (iok == 0) THEN
139 CALL ancmsg(msgid=237,anmode=aninfo,
140 . i1=iabs(idtgr(11)))
141 CALL arret(2)
142 ENDIF
143 DO n=1,igrnod(idtgrx)%NENTITY
144 tagn(igrnod(idtgrx)%ENTITY(n)) = 1
145 ENDDO
146 ENDIF
147 ELSE
148 tagn(1:numnod)=0
149 ENDIF
150C-----------------------------------------------------
151 tagr(1:numelr)=0
152 IF(idtmins==2)THEN
153C
154 IF(idtgrs==0)THEN
155 DO ip=1,npart
156 tagprt_sms(ip)=1
157 END DO
158 ELSE
159 DO ip=1,npart
160 tagprt_sms(ip)=0
161 END DO
162 IF(idtgrs < 0)THEN
163 DO n=1,ngrpart
164 IF (igrpart(n)%ID==-idtgrs) THEN
165 idtgrx=n
166 GO TO 120
167 END IF
168 END DO
169 CALL ancmsg(msgid=21,anmode=aninfo_blind,
170 . i1=-idtgrs)
171 CALL arret(2)
172 120 CONTINUE
173 END IF
174C
175 DO i=1,igrpart(idtgrx)%NENTITY
176 ip=igrpart(idtgrx)%ENTITY(i)
177 tagprt_sms(ip)=1
178 END DO
179 END IF
180C-----------------------------------------------------
181 IF (isms_selec==1) THEN
182C-- Full AMS
183 DO i=1,numelr
184 tagr(i)=1
185 END DO
186 ELSEIF (isms_selec==2) THEN
187C-- AMS by parts
188 DO i=1,numelr
189 IF(tagprt_sms(ipartr(i))==0)THEN
190 tagr(i)=0
191 ELSE
192 tagr(i)=1
193 END IF
194 END DO
195 ELSEIF (isms_selec==3) THEN
196C-- AMS auto - defined by elements
197 DO ng = 1, ngroup
198 ity =iparg(5,ng)
199 IF(ity==6)THEN
200 nft =iparg(3,ng)
201 lft =1
202 llt =iparg(2,ng)
203 gbuf => elbuf_tab(ng)%GBUF
204 DO i=lft,llt
205 IF(gbuf%ISMS(i)==0)THEN
206 tagr(nft+i)=0
207 ELSE
208 tagr(nft+i)=1
209 END IF
210 END DO
211 END IF
212 END DO
213 ELSEIF (isms_selec==4) THEN
214C-- AMS auto + parts
215 DO ng = 1, ngroup
216 ity =iparg(5,ng)
217 IF(ity==6)THEN
218 nft =iparg(3,ng)
219 lft =1
220 llt =iparg(2,ng)
221 gbuf => elbuf_tab(ng)%GBUF
222 DO i=lft,llt
223 IF(gbuf%ISMS(i)==0.AND.tagprt_sms(ipartr(nft+i))==0)THEN
224 tagr(nft+i)=0
225 ELSE
226 tagr(nft+i)=1
227 END IF
228 END DO
229 END IF
230 END DO
231 END IF
232 END IF
233C-----------------------------------------------------
234 ierr=0
235 DO ng = 1, ngroup
236 ity =iparg(5,ng)
237 IF(ity==6)THEN
238 nft =iparg(3,ng)
239 lft =1
240 llt =iparg(2,ng)
241 gbuf => elbuf_tab(ng)%GBUF
242C
243 ipid = ixr(1,nft+1)
244 igtyp= igeo(11,ipid)
245C
246 IF(igtyp==23)THEN
247C
248 imat = ixr(5,nft+1)
249 iadbuf = ipm(7,imat) - 1
250 mtn = ipm(2,imat)
251C
252 k1 = 4
253 k11 = 64
254 k12 = k11 + 6
255 k13 = k12 + 6
256 k14 = k13 + 6
257C
258 IF(mtn == 108) THEN
259 iequi = uparam(iadbuf+2)
260 xkm= max(uparam(iadbuf + k11 + 1)*uparam(iadbuf + k1 + 1),
261 . uparam(iadbuf + k11 + 2)*uparam(iadbuf + k1 + 2),
262 . uparam(iadbuf + k11 + 3)*uparam(iadbuf + k1 + 3)) ! /XL(I)
263 xcm= max(uparam(iadbuf + k12 + 1),uparam(iadbuf + k12 + 2),uparam(iadbuf + k12 + 3))
264 xkr= max(uparam(iadbuf + k11 + 4)*uparam(iadbuf + k1 + 4),
265 . uparam(iadbuf + k11 + 5)*uparam(iadbuf + k1 + 5),
266 . uparam(iadbuf + k11 + 6)*uparam(iadbuf + k1 + 6)) ! /XL(I)
267 xcr= max(uparam(iadbuf + k12 + 4),uparam(iadbuf + k12 + 5),uparam(iadbuf + k12 + 6))
268 DO i=lft,llt
269 n1 =ixr(2,nft+i)
270 n2 =ixr(3,nft+i)
271 IF(gbuf%MASS(i)==zero)THEN
272 IF(xkm/=zero.OR.xcm/=zero)THEN
273 IF(nodadt==0.AND.idtmins/=2)THEN
274 ierr=1
275 ELSEIF(.NOT.((nodadt/=0 .AND.tagn(n1)/=0 .AND. tagn(n2)/=0).OR.
276 . (idtmins==2.AND.tagr(i)/=0)))THEN
277 ierr=1
278 END IF
279 END IF
280 END IF
281 xin(i)= geo(2,ipid)
282 IF(xin(i)==zero)THEN
283 IF(xkr/=zero.OR.xcr/=zero.OR.(iequi/=0.AND.(xkm/=zero.OR.xcm/=zero)))THEN
284 IF(nodadt==0.AND.idtmins/=2)THEN
285 ierr=1
286 ELSEIF(.NOT.((nodadt/=0 .AND.tagn(n1)/=0 .AND. tagn(n2)/=0).OR.
287 . (idtmins==2.AND.tagr(i)/=0)))THEN
288 ierr=1
289 END IF
290 END IF
291 END IF
292 END DO
293 END IF
294 END IF
295 END IF
296 END DO
297C------------------------------------------
298 IF(nspmd > 0)THEN
299#ifdef MPI
300 CALL mpi_allreduce(mpi_in_place,ierr,1,mpi_integer,mpi_max,spmd_comm_world,ierror)
301#endif
302 END IF
303 IF(ierr/=0)THEN
304 nodadt =1
305 idtgr(11)=0
306 IF(ispmd==0)THEN
307 CALL ancmsg(msgid=286,anmode=aninfo_blind_1)
308 END IF
309 END IF
310C------------------------------------------
311 DEALLOCATE(tagn)
312 DEALLOCATE(tagr)
313 DEALLOCATE(tagprt_sms)
314C-----------------------------------------------------
315 RETURN
316 END
my_real
#define my_real
Definition cppsort.cpp:32
max
#define max(a, b)
Definition macros.h:21
mpi_allreduce
subroutine mpi_allreduce(sendbuf, recvbuf, cnt, datatype, operation, comm, ierr)
Definition mpi.f:103
groupdef_mod
Definition groupdef_mod.F:662
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
arret
subroutine arret(nn)
Definition arret.F:87
switch_to_dtnoda
subroutine switch_to_dtnoda(ixr, geo, pm, iparg, elbuf_tab, ms, in, itab, igeo, ipm, uparam, ipart, igrnod, igrpart)
Definition switch_to_dtnoda.F:41