OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
r2r_fork.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!|| r2r_fork ../starter/source/coupling/rad2rad/r2r_fork.F
25!||--- called by ------------------------------------------------------
26!|| starter0 ../starter/source/starter/starter0.F
27!||--- calls -----------------------------------------------------
28!|| ancmsg ../starter/source/output/message/message.F
29!|| create_child ../starter/source/coupling/rad2rad/r2r_fork.F
30!|| my_fork ../starter/source/system/rad_sys_call.c
31!|| my_waitpid ../starter/source/system/rad_sys_call.c
32!|| r2r_prelec_name ../starter/source/coupling/rad2rad/r2r_prelec_name.F
33!|| read_flag_ale ../starter/source/coupling/rad2rad/r2r_fork.F
34!|| win_waitpid ../starter/source/coupling/rad2rad/r2r_fork.F
35!||--- uses -----------------------------------------------------
36!|| message_mod ../starter/share/message_module/message_mod.F
37!|| r2r_mod ../starter/share/modules1/r2r_mod.F
38!|| submodel_mod ../starter/share/modules1/submodel_mod.F
39!||====================================================================
40 SUBROUTINE r2r_fork(CHRUN,FILNAM,LSUBMODEL)
41C-----------------------------------------------
42C M o d u l e s
43C-----------------------------------------------
44 USE message_mod
45 USE r2r_mod
46 USE inoutfile_mod
47 USE qa_out_mod
48 USE submodel_mod
49C-----------------------------------------------
50C I m p l i c i t T y p e s
51C-----------------------------------------------
52#include "implicit_f.inc"
53C-----------------------------------------------
54C C o m m o n B l o c k s
55C-----------------------------------------------
56#include "com01_c.inc"
57#include "com04_c.inc"
58#include "units_c.inc"
59#include "warn_c.inc"
60#include "scr03_c.inc"
61#include "scr15_c.inc"
62#include "param_c.inc"
63#include "r2r_c.inc"
64C-----------------------------------------------
65C D u m m y A r g u m e n t s
66C-----------------------------------------------
67 CHARACTER FILNAM*2148,CHRUN*4,ROOT_SUB*80
68 TYPE(submodel_data),INTENT(IN)::LSUBMODEL(*)
69C-----------------------------------------------
70C L o c a l V a r i a b l e s
71C-----------------------------------------------
72 INTEGER ISTAT,KDOM,IPID_RET,IERROR,WAIT,IPID_L,STAT,DOM_SWITCH
73 LOGICAL(4) WAITA
74#if defined(COMP_ARMFLANG) || defined(COMP_LLVM) || defined(COMP_AOCC)
75 INTEGER :: GETPID
76#endif
77#if defined(COMP_NVFORTRAN)
78 INTEGER, EXTERNAL :: GETPID
79#endif
80
81 INTEGER :: LEN_TMP_NAME
82 CHARACTER(len=4096) :: TMP_NAME
83C-----------------------------------------------
84
85 kdom = 0
86 dom_switch = 0
87 dom_name = ''
88 rootnam0 = ''
89 rootnam0 = rootnam(1:rootlen)
90 ALLOCATE (isubdom(8,nsubdom),stat=stat)
91
922000 CONTINUE
93
94C----------------------------------------------------------------------
95C----------------------------- WINDOWS --------------------------------
96C----------------------------------------------------------------------
97#if CPP_mach == CPP_p4win64 || CPP_mach == CPP_p4win32
98 IF (ipid/=0) CALL create_child(ipid_ret,flg_swale)
99C----------------------------------------------------------------------
100C-------------PGI -> LINUX / SUN -> SOLARISX64 / IBM -> AIX64----------
101C----------------------------------------------------------------------
102#elif CPP_mach == CPP_linux964 || CPP_mach == CPP_sun25 || CPP_mach == CPP_pwr4
103 ipid = fork()
104#if defined(_OPENMP)
105 IF (ipid==0) CALL omp_set_num_threads(nthread_r2r)
106#endif
107C----------------------------------------------------------------------
108C-------------------INTEL -> LINUX/LINUXIA64/MACOSX--------------------
109C----------------------------------------------------------------------
110#else
111#if defined(COMP_GFORTRAN) || defined(COMP_ARMFLANG)|| defined(COMP_LLVM) || defined(COMP_AOCC) || defined(COMP_NVFORTRAN)
112 CALL my_fork(ipid)
113 ipid_ret = getpid()
114#else
115 CALL pxffork(ipid,ierror)
116 CALL pxfgetpid(ipid_ret,ierror)
117#endif
118#if defined(_OPENMP)
119 IF (ipid==0) CALL omp_set_num_threads(nthread_r2r)
120#endif
121#endif
122C----------------------------------------------------------------------
123C----------------------------------------------------------------------
124 kdom = kdom + 1
125 ipid_l = ipid
126C
127 IF (ipid/=0) THEN
128 istat = 0
129C----------------------------------------------------------------------
130C----------------------------- WINDOWS --------------------------------
131C----------------------------------------------------------------------
132#if CPP_mach == CPP_p4win64 || CPP_mach == CPP_p4win32
133 CALL win_waitpid(ipid_ret)
134C----------------------------------------------------------------------
135C-------------PGI -> LINUX / SUN -> SOLARISX64 / IBM -> AIX64----------
136C----------------------------------------------------------------------
137#elif CPP_mach == CPP_linux964 || CPP_mach == CPP_sun25 || CPP_mach == CPP_pwr4
138 ierror = wait(istat)
139C----------------------------------------------------------------------
140C-------------------INTEL -> LINUX/LINUXIA64/MACOSX--------------------
141C----------------------------------------------------------------------
142#else
143#if defined(COMP_GFORTRAN) || defined(COMP_ARMFLANG) || defined(COMP_LLVM) || defined(COMP_AOCC) || defined(COMP_NVFORTRAN)
144 CALL my_waitpid(ipid,istat,0,ipid_ret)
145#else
146 CALL pxfwaitpid(ipid,istat,0,ipid_ret,ierror)
147#endif
148
149#endif
150 CALL r2r_prelec_name(kdom,lsubmodel)
151 iddom = 0
152 iddom_l = iddom
153 CALL read_flag_ale(chrun)
154 IF (flg_fsi==1) THEN
155 IF (flg_swale<1) THEN
156 flg_swale = flg_swale + 1
157 dom_switch = kdom
158 kdom = kdom - 1
159#if CPP_mach == CPP_p4win64 || CPP_mach == CPP_p4win32
160 CLOSE(iout)
161#endif
162 GOTO 2000
163 ELSE
164 CALL ancmsg(msgid=1103,
165 . msgtype=msgerror,
166 . anmode=aninfo)
167 ierr=ierr+1
168 ENDIF
169 ELSEIF (kdom<nsubdom) THEN
170 GOTO 2000
171 ENDIF
172 IF (flg_swale==1) THEN
173 ipid_l = 0
174 iddom_l = 1
175 ENDIF
176C----------------------------------------------------------------------
177C----------------------------------------------------------------------
178 ELSE
179 CALL r2r_prelec_name(kdom,lsubmodel)
180 iddom = kdom
181 iddom_l = iddom
182 IF (flg_swale==1) THEN
183 ipid_l = 1
184 iddom_l = 0
185 ENDIF
186 ENDIF
187C
188 IF (ipid_l/=0) THEN
189 WRITE(istdo,'(A)') '-----------------------------------'
190 WRITE(istdo,'(A)')' .. TREATMENT OF THE FULL DOMAIN'
191 WRITE(istdo,'(A)') '-----------------------------------'
192 WRITE(istdo,'(A)') ''
193 ELSE
194 rootnam = dom_name
195 rootlen = len_trim(rootnam)
196c-----------Initialisations for the starter processes of the subdomains----
197 filnam =rootnam(1:rootlen)//'_'//chrun//'.out'
198 r2r_filnam = filnam
199 tmp_name=outfile_name(1:outfile_name_len)//r2r_filnam(1:len_trim(r2r_filnam))
200 len_tmp_name = outfile_name_len+len_trim(r2r_filnam)
201 OPEN(unit=iout,file=tmp_name(1:len_tmp_name),
202 . access='SEQUENTIAL',
203 . form='FORMATTED',status='UNKNOWN')
204C-----------Repointing of temporary files for error messages
205 res_mes = 123458
206 res_tmp = 123459
207 OPEN (unit=res_mes,status='SCRATCH',form='FORMATTED')
208c
209 WRITE(istdo,'(A)') ''
210 WRITE(istdo,'(A)') '-----------------------------------'
211 WRITE(istdo,'(A)')' .. TREATMENT OF SUBDOMAIN '
212 . //rootnam(1:rootlen)
213 WRITE(istdo,'(A)') '-----------------------------------'
214 WRITE(istdo,'(A)') ''
215C-----------printout only for main domain
216 doqa = 0
217C
218 ENDIF
219
220C--------------------------------------------------------------------C
221 RETURN
222 END
223
224#if CPP_mach == CPP_p4win64 || CPP_mach == CPP_p4win32
225!||====================================================================
226!|| win_waitpid ../starter/source/coupling/rad2rad/r2r_fork.F
227!||--- called by ------------------------------------------------------
228!|| r2r_fork ../starter/source/coupling/rad2rad/r2r_fork.F
229!||--- uses -----------------------------------------------------
230!||====================================================================
231 SUBROUTINE win_waitpid(IPID_RET)
232C-----------------------------------------------
233 USE dfwin
234 USE dflib
235C-----------------------------------------------
236C I m p l i c i t T y p e s
237C-----------------------------------------------
238#include "implicit_f.inc"
239C-----------------------------------------------
240 INTEGER IPID_RET
241C-----------------------------------------------
242 LOGICAL(4) WAITA
243C-----------------------------------------------
244
245 waita = waitforsingleobject(ipid_ret,infinite)
246
247 END
248
249!||====================================================================
250!|| create_child ../starter/source/coupling/rad2rad/r2r_fork.F
251!||--- called by ------------------------------------------------------
252!|| r2r_fork ../starter/source/coupling/rad2rad/r2r_fork.F
253!||--- calls -----------------------------------------------------
254!|| ancmsg ../starter/source/output/message/message.F
255!|| my_exit ../starter/source/output/analyse/analyse.c
256!||--- uses -----------------------------------------------------
257!|| message_mod ../starter/share/message_module/message_mod.F
258!||====================================================================
259 SUBROUTINE create_child(ID,FLG_SWALE)
260 USE message_mod
261C-----------------------------------------------
262 USE dfwin
263 USE dflib
264C-----------------------------------------------
265C I m p l i c i t T y p e s
266C-----------------------------------------------
267#include "implicit_f.inc"
268C-----------------------------------------------
269C C o m m o n B l o c k s
270C-----------------------------------------------
271#include "scr15_c.inc"
272#include "execinp.inc"
273#include "warn_c.inc"
274C-----------------------------------------------
275C D u m m y A r g u m e n t s
276C-----------------------------------------------
277 INTEGER ID,FLG_SWALE
278C-----------------------------------------------
279C L o c a l V a r i a b l e s
280C-----------------------------------------------
281 LOGICAL(4) SUCCESS
282 INTEGER PROCESS_ERROR,STATUS,LEN,I
283 INTEGER SIZEOFSTARTUPINFO,SIZESECURITYATTRIBUTES
284 CHARACTER*2048 COMMAND,LAUNCH
285 type(t_startupinfo) si
286 type(t_process_information) tpi
287C-----------------------------------------------
288
289 success = setenvqq("R2R_ENV_IPID=5")
290 IF (flg_swale>0) success = setenvqq("R2R_ENV_SWALE=5")
291
292 CALL get_command(command,len,status)
293
294C-------Incompatibility of "<" remplaced by "-i" ----------------
295 IF (len_trim(input)==0) THEN
296 CALL ancmsg(msgid=840,
297 . msgtype=msgerror,
298 . anmode=aninfo)
299 ierr=ierr+1
300 ENDIF
301
302
303 process_error=0
304 CALL rad2rad_createprocess(command,len,id,process_error)
305
306
307 IF (process_error==1) THEN
308 CALL my_exit(2)
309 ENDIF
310
311 END
312#endif
313
314!||====================================================================
315!|| read_flag_ale ../starter/source/coupling/rad2rad/r2r_fork.F
316!||--- called by ------------------------------------------------------
317!|| r2r_fork ../starter/source/coupling/rad2rad/r2r_fork.F
318!||--- uses -----------------------------------------------------
319!|| r2r_mod ../starter/share/modules1/r2r_mod.F
320!||====================================================================
321 SUBROUTINE read_flag_ale(CHRUN)
322C-----------------------------------------------
323C M o d u l e s
324C-----------------------------------------------
325 USE r2r_mod
326 USE inoutfile_mod
327C-----------------------------------------------
328C I m p l i c i t T y p e s
329C-----------------------------------------------
330#include "implicit_f.inc"
331C-----------------------------------------------
332C C o m m o n B l o c k s
333C-----------------------------------------------
334#include "r2r_c.inc"
335C-----------------------------------------------
336C D u m m y A r g u m e n t s
337C-----------------------------------------------
338 CHARACTER CHRUN*4
339C-----------------------------------------------
340C L o c a l V a r i a b l e s
341C-----------------------------------------------
342 INTEGER DOMLEN,REF,ERR
343 CHARACTER NAM*150
344 INTEGER :: LEN_TMP_NAME
345 CHARACTER(len=4096) :: TMP_NAME
346C-----------------------------------------------
347
348 ref = 991982
349
350 nam=dom_name(isubdom(8,1):isubdom(8,1)+
351 . isubdom(7,1)-1)//'_'//chrun//'.domdec'
352 domlen = isubdom(7,1)+12
353
354 tmp_name=outfile_name(1:outfile_name_len)//nam(1:len_trim(nam))
355 len_tmp_name = outfile_name_len+len_trim(nam)
356 OPEN(unit=ref,file=tmp_name(1:len_tmp_name),
357 . access='SEQUENTIAL',form='FORMATTED',status='UNKNOWN')
358
359 READ(ref,1303,iostat=err) flg_fsi
360
361 CLOSE(unit=ref,status='KEEP')
362
363C--------------------------------------------------------------C
364 RETURN
365
3661303 FORMAT( 1x,i9)
367
368C--------------------------------------------------------------C
369 RETURN
370 END
my_exit
void my_exit(int *i)
Definition analyse.c:1038
inoutfile_mod
Definition inoutfile_mod.F:96
inoutfile_mod::outfile_name
character(len=outfile_char_len) outfile_name
Definition inoutfile_mod.F:111
inoutfile_mod::outfile_name_len
integer outfile_name_len
Definition inoutfile_mod.F:109
message_mod
Definition message_mod.F:1249
qa_out_mod
Definition qa_out_mod.F:78
qa_out_mod::doqa
integer doqa
Definition qa_out_mod.F:84
r2r_mod
Definition r2r_mod.F:125
r2r_mod::isubdom
integer, dimension(:,:), allocatable isubdom
Definition r2r_mod.F:144
submodel_mod
Definition submodel_mod.F:712
read_flag_ale
subroutine read_flag_ale(chrun)
Definition r2r_fork.F:322
win_waitpid
subroutine win_waitpid(ipid_ret)
Definition r2r_fork.F:232
create_child
subroutine create_child(id, flg_swale)
Definition r2r_fork.F:260
r2r_fork
subroutine r2r_fork(chrun, filnam, lsubmodel)
Definition r2r_fork.F:41
r2r_prelec_name
subroutine r2r_prelec_name(kdom, lsubmodel)
Definition r2r_prelec_name.F:40
my_waitpid
void my_waitpid(int *pid, int *istat, int *pidp, int *pidret)
Definition rad_sys_call.c:98
my_fork
void my_fork(int *pid)
Definition rad_sys_call.c:82
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
submodel_mod::submodel_data
Definition submodel_mod.F:723