OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
r2r_fork.F File Reference
#include "implicit_f.inc"
#include "com01_c.inc"
#include "com04_c.inc"
#include "units_c.inc"
#include "warn_c.inc"
#include "scr03_c.inc"
#include "scr15_c.inc"
#include "param_c.inc"
#include "r2r_c.inc"
#include "execinp.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine r2r_fork (chrun, filnam, lsubmodel)
subroutine win_waitpid (ipid_ret)
subroutine create_child (id, flg_swale)
subroutine read_flag_ale (chrun)

Function/Subroutine Documentation

◆ create_child()

subroutine create_child ( integer id,
integer flg_swale )

Definition at line 259 of file r2r_fork.F.

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
my_exit
void my_exit(int *i)
Definition analyse.c:1038
id
initmumps id
Definition multiplerhs_example.m:4
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

◆ r2r_fork()

subroutine r2r_fork ( character chrun,
character filnam,
type(submodel_data), dimension(*), intent(in) lsubmodel )

Definition at line 40 of file r2r_fork.F.

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
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
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_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

◆ read_flag_ale()

subroutine read_flag_ale ( character chrun)

Definition at line 321 of file r2r_fork.F.

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

◆ win_waitpid()

subroutine win_waitpid ( integer ipid_ret)

Definition at line 231 of file r2r_fork.F.

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