OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
inipar.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#ifdef MPI
24!||====================================================================
25!|| inipar ../engine/source/mpi/init/inipar.F
26!||--- called by ------------------------------------------------------
27!|| radioss2 ../engine/source/engine/radioss2.F
28!||--- calls -----------------------------------------------------
29!|| arret ../engine/source/system/arret.F
30!|| omp_get_max_threads ../engine/source/engine/openmp_stub.F90
31!|| omp_set_num_threads ../engine/source/engine/openmp_stub.F90
32!||--- uses -----------------------------------------------------
33!|| coupling_adapter_mod ../engine/source/coupling/coupling_adapter.F90
34!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
35!||====================================================================
36 SUBROUTINE inipar(coupling,ITID,ICAS,NNODES,INPUT,GOT_INPUT,NBTASK)
37C-----------------------------------------------------------------
38 USE coupling_adapter_mod
39 USE spmd_comm_world_mod, ONLY : spmd_comm_world
40#include "implicit_f.inc"
41#include "comlock.inc"
42#include "r4r8_p.inc"
43C-----------------------------------------------------------------
44C M e s s a g e P a s s i n g
45C-----------------------------------------------
46#include "spmd.inc"
47C-----------------------------------------------
48C D u m m y A r g u m e n t s
49C-----------------------------------------------
50 INTEGER ITID(*),ICAS, NNODES,GOT_INPUT,NBTASK(*)
51 CHARACTER*100 INPUT
52 type(coupling_type), intent(inout) :: coupling
53C-----------------------------------------------
54C C o m m o n B l o c k s
55C-----------------------------------------------
56#include "com01_c.inc"
57#include "task_c.inc"
58#include "scr05_c.inc"
59#include "units_c.inc"
60#include "commandline.inc"
61 INTEGER KEY, IERR
62C-----------------------------------------------
63C L o c a l V a r i a b l e s
64C-----------------------------------------------
65 INTEGER STATUS(MPI_STATUS_SIZE),IERROR,ICODE
66 INTEGER MYRANK, JRANK, I, J, NTHREAD1, LOCAL, RLEN
67 CHARACTER (LEN=255) :: STR
68 CHARACTER (LEN=MPI_MAX_PROCESSOR_NAME) :: HSTNAM,HOST
69 character(len=MPI_MAX_PROCESSOR_NAME), dimension(:), allocatable :: hostname
70 integer, dimension(:), allocatable :: perm,host_numbers,buffer
71 INTEGER HOST_NUMBER
72 INTEGER NSPMDx2
73 INTEGER :: COLOUR
74 INTEGER (kind=MPI_ADDRESS_KIND) :: COLOUR_ADDR
75 INTEGER :: VALID
76 CHARACTER FILNAM*100
77#if defined(_OPENMP)
78 INTEGER OMP_GET_MAX_THREADS
79#endif
80C--------------------------------------------------
81C CONVENTIONS:
82C ispmd 0...NSPMD-1
83C--------------------------------------------------
84 IF(icas==1) THEN
85 REAL = mpi_real
86 IF(ir4r8==2) real = mpi_double_precision
87C
88 key = 0
89 CALL mpi_initialized(key, ierr)
90 valid = 0
91 colour_addr = 0
92
93 CALL mpi_init(ierror)
94
95 CALL mpi_comm_get_attr(mpi_comm_world, mpi_appnum,
96 * colour_addr, valid, ierror)
97
98 IF (ierror == mpi_success) THEN
99 colour = int(colour_addr)
100 ELSE
101 colour = 0 ! Default color if attribute not found
102 ENDIF
103 call coupling_configure(coupling, trim(coupling%FILNAM))
104
105#ifndef WITH_CWIPI
106 CALL mpi_comm_split(mpi_comm_world,colour,key,
107 * spmd_comm_world,ierror)
108#else
109 spmd_comm_world = coupling_get_communicator(coupling%adapter_ptr)
110#endif
111 CALL mpi_comm_size(spmd_comm_world, nnodes, ierror)
112 CALL mpi_comm_rank(spmd_comm_world, myrank, ierror)
113C
114 DO jrank=1,nnodes
115 it_spmd(jrank) = jrank-1
116 END DO
117C
118 IF (myrank==0) THEN
119C I AM THE FIRST ONE
120 ispmd = 0
121C
122C Calculation of the number of threads
123C
124#if defined(_OPENMP)
125 str = ' '
126 CALL getenv('OMP_NUM_THREADS',str)
127 nthread1=0
128C nthread1 : fixed number of threads by the environment variable
129 READ(str,'(I10)',err=999)nthread1
130 GOTO 1000
131 999 CONTINUE
132 nthread1 = -1
133 1000 CONTINUE
134 IF(nthread1>0)THEN
135 nthread=nthread1
136 ELSE
137 nthread=nthread0 ! defaut run precedent
138 END IF
139 IF (got_nth == 1) THEN
140 IF (nthread>1 .AND. (nth/= nthread .OR. (nth==nthread .AND.
141 + nthread1>0.AND.nthread0>1.AND.nthread1/=nthread0)))THEN
142 WRITE(iout,*)
143 + '** WARNING : -nthread OPTION USED, DEFAULT SETTING IGNORED'
144 WRITE(iout,*)' '
145 END IF
146 nthread = nth
147 ELSE
148 IF(nthread1>0.AND.nthread0>1.AND.nthread1/=nthread0)THEN
149 WRITE(iout,*)
150 + '** WARNING : OMP_NUM_THREADS SET, DEFAULT SETTING IGNORED'
151 WRITE(iout,*)' '
152 END IF
153 ENDIF
154 IF(nthread<=0) nthread=1
155 IF(nthread>nthmax) nthread=nthmax
156#elif 1
157 nthread = 1
158#endif
159 ELSE
160 CALL mpi_bcast(
161 1 nspmd,1,mpi_integer,it_spmd(1),spmd_comm_world,
162 2 ierror )
163C recuperation de NTHREAD depuis process 0 { recovery of NTHREAD from process 0 }
164 CALL mpi_bcast(
165 1 nthread,1,mpi_integer,it_spmd(1),spmd_comm_world,
166 2 ierror )
167C
168 IF (got_input == 0)THEN
169 CALL mpi_bcast(input,100,mpi_character,it_spmd(1),
170 . spmd_comm_world,ierror)
171 ENDIF
172C
173 DO j=2,nspmd
174 IF(myrank==it_spmd(j))THEN
175 ispmd = j-1
176 END IF
177 END DO
178cccc
179C special code for MIC
180#if defined(__MIC__)
181 str = ' '
182 CALL getenv('OMP_NUM_THREADS',str)
183 nthread1=0
184C nthread1 : fixed number of threads by the environment variable on the MIC
185 READ(str,'(I10)',err=1999)nthread1
186 GOTO 2000
187 1999 CONTINUE
188 nthread1 = -1
189 2000 CONTINUE
190 IF(nthread1>0 .AND. nthread1 /= nthread)THEN
191 nthread=nthread1
192 WRITE(istdo,'(A,I4,A,I4)')
193 . '** WARNING: RESET OMP_NUM_THREADS TO:',
194 . nthread,' FOR MPI PROCESS',ispmd+1
195 ENDIF
196#endif
197C control of nthread per MPI process
198 CALL mpi_gather(nthread,1,mpi_integer,nbtask,1,mpi_integer,
199 . it_spmd(1),spmd_comm_world,ierror)
200
201 END IF
202 ELSE IF(icas==3) THEN
203 IF(ispmd == 0) THEN
204C
205C NSPMD COOHENENCE test and number of MPI requests (-NP)
206C
207 IF (nspmd /= nnodes) THEN
208 WRITE(iout,*)
209 . 'THE REQUIRED NUMBER OF MPI PROCESSES DOES NOT MATCH MPIRUN'
210 WRITE(iout,*)
211 . 'PLEASE, RUN WITH THE PROPER NUMBER OF MPI PROCESSES'
212 WRITE(iout,*)
213 . 'REQUIRED (number of .rst files) NSPMD =',nspmd
214 WRITE(iout,*)
215 . 'AVAILABLE (-np argument of mpirun) =',nnodes
216 WRITE(iout,*)' '
217 WRITE(istdo,*)
218 . 'THE REQUIRED NUMBER OF MPI PROCESSES DOES NOT MATCH MPIRUN'
219 WRITE(istdo,*)
220 . 'PLEASE, RUN WITH THE PROPER NUMBER OF MPI PROCESSES'
221 WRITE(istdo,*)' '
222 WRITE(iout,*)
223 . ' E R R O R T E R M I N A T I O N'
224 WRITE(istdo,*)
225 . ' E R R O R T E R M I N A T I O N'
226 WRITE(iout,*)
227 . ' TOTAL NUMBER OF CYCLES :', ncycle
228 WRITE(istdo,*)
229 . ' TOTAL NUMBER OF CYCLES :', ncycle
230 icode=2
231 CALL mpi_abort(spmd_comm_world,icode,ierror)
232 CALL arret(7)
233 END IF
234 IF(nspmd > 1) THEN
235C sending NSPMD from process0 to other processes
236 CALL mpi_bcast(nspmd,1,mpi_integer,it_spmd(1),
237 . spmd_comm_world,ierror)
238C sending NTHREAD from process0 to other processes
239 CALL mpi_bcast(nthread,1,mpi_integer,it_spmd(1),
240 . spmd_comm_world,ierror)
241C
242 IF (got_input == 0)THEN
243 CALL mpi_bcast(input,100,mpi_character,it_spmd(1),
244 . spmd_comm_world,ierror)
245 ENDIF
246
247C control of nthread per MPI process
248 CALL mpi_gather(nthread,1,mpi_integer,nbtask,1,mpi_integer,
249 . it_spmd(1),spmd_comm_world,ierror)
250 IF(ispmd==0)THEN
251 nbtask(nspmd+1)=0
252 DO i=1,nspmd
253 nbtask(nspmd+1)=nbtask(nspmd+1)+nbtask(i)
254 END DO
255 END IF
256 ELSE
257 nbtask(1)=nthread
258 nbtask(2)=nthread
259 END IF
260C
261 END IF
262C------------------------------------------------------------
263C Starting from now, ALL TASK ARE EQUAL ===> SPMD program
264C------------------------------------------------------------
265C
266C Init OpenMP
267C
268#if defined(_OPENMP)
269 CALL omp_set_num_threads(nthread)
270 DO i = 1, 2*intseg
271 CALL omp_init_lock(llock(1,i))
272 ENDDO
273#endif
274C
275C Init local SPMD numbering on a node (L_SPMD)
276C
277 allocate(hostname(nspmd))
278 CALL mpi_get_processor_name(hstnam,rlen,ierror)
279 CALL mpi_gather(
280 . hstnam,mpi_max_processor_name,mpi_character,
281 . hostname ,mpi_max_processor_name,mpi_character,
282 . it_spmd(1),spmd_comm_world,ierror)
283
284 allocate(perm(nspmd))
285 allocate(host_numbers(nspmd))
286 allocate(buffer(2*nspmd))
287 IF(ispmd==0)THEN
288C permutations during sort are saved
289 DO i = 1,nspmd
290 perm(i) = i
291 END DO
292C tri bulle basic
293 DO i = 1, nspmd-1
294 DO j = i, nspmd
295 IF(hostname(i) > hostname(j))THEN
296 host = hostname(i)
297 hostname(i) = hostname(j)
298 perm(i) = j
299 hostname(j) = host
300 perm(j) = i
301 END IF
302 END DO
303 END DO
304 host = ' '
305 local=0
306 host_number = 0
307 DO i = 1, nspmd
308 IF(host /= hostname(i))THEN
309 host = hostname(i)
310 local = 1
311 host_number = host_number + 1
312 ELSE
313 local = local + 1
314 ENDIF
315 l_spmd(perm(i))=local-1
316 host_numbers(perm(i))=host_number
317 ENDDO
318C preparing MPI buffer
319C Local rank in the node
320 buffer(1:nspmd) = l_spmd(1:nspmd)
321C host numbers
322 buffer(nspmd+1:2*nspmd) = host_numbers(1:nspmd)
323 deallocate(perm)
324 ENDIF
325 nspmdx2 = nspmd*2
326 CALL mpi_bcast(buffer,nspmdx2,mpi_integer,it_spmd(1),
327 . spmd_comm_world,ierror)
328
329 l_spmd(1:nspmd) = buffer(1:nspmd)
330 host_numbers(1:nspmd) = buffer(nspmd+1:2*nspmd)
331
332 nspmd_per_node=0
333C Count the number of SPMD on the local host
334 DO i = 1,nspmd
335 IF(host_numbers(i) == host_numbers(ispmd+1)) THEN
336 nspmd_per_node = nspmd_per_node + 1
337 ENDIF
338 END DO
339
340 deallocate(hostname)
341 deallocate(host_numbers)
342 deallocate(buffer)
343
344 ELSE IF(icas==2) THEN
345C
346 CALL mpi_barrier(spmd_comm_world,ierror)
347C
348 CALL mpi_finalize(ierror)
349 ENDIF
350C
351 RETURN
352 END
353C MPI
354
355#elif 1
356C
357C Simplified routines not mpi
358C
359!||====================================================================
360!|| inipar ../engine/source/mpi/init/inipar.F
361!||--- called by ------------------------------------------------------
362!|| radioss2 ../engine/source/engine/radioss2.F
363!||--- calls -----------------------------------------------------
364!|| arret ../engine/source/system/arret.F
365!|| omp_get_max_threads ../engine/source/engine/openmp_stub.F90
366!|| omp_set_num_threads ../engine/source/engine/openmp_stub.F90
367!||--- uses -----------------------------------------------------
368!|| coupling_adapter_mod ../engine/source/coupling/coupling_adapter.f90
369!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
370!||====================================================================
371 SUBROUTINE inipar(coupling, ITID,ICAS,NNODES,INPUT,GOT_INPUT,NBTASK)
372C-----------------------------------------------------------------
373 USE spmd_comm_world_mod, ONLY : spmd_comm_world
374 USE coupling_adapter_mod
375#include "implicit_f.inc"
376#include "comlock.inc"
377#include "r4r8_p.inc"
378C-----------------------------------------------
379C D u m m y A r g u m e n t s
380C-----------------------------------------------
381 INTEGER ITID(*),ICAS, NNODES,GOT_INPUT,NBTASK(*)
382 CHARACTER*100 INPUT
383C-----------------------------------------------
384C C o m m o n B l o c k s
385C-----------------------------------------------
386#include "spmd.inc"
387#include "com01_c.inc"
388#include "task_c.inc"
389#include "scr05_c.inc"
390#include "units_c.inc"
391#include "commandline.inc"
392C-----------------------------------------------
393C L o c a l V a r i a b l e s
394C-----------------------------------------------
395 type(coupling_type), intent(inout) :: coupling
396 INTEGER ICODE, I, NTHREAD1
397#if defined(_OPENMP)
398 INTEGER OMP_GET_MAX_THREADS
399#endif
400 CHARACTER (LEN=255) :: STR
401C--------------------------------------------------
402C CONVENTIONS:
403C ispmd 0...NSPMD-1
404C--------------------------------------------------
405 IF(icas==1) THEN
406C
407 REAL = 4
408 IF(ir4r8==2) real = 8
409C
410 nnodes= 1
411 ispmd = 0
412#if defined(_OPENMP)
413 str = ' '
414 CALL getenv('OMP_NUM_THREADS',str)
415 nthread1=0
416C nthread1 : fixed number of threads by the environment variable
417 READ(str,'(I10)',err=999)nthread1
418 GOTO 1000
419 999 CONTINUE
420 nthread1 = -1
421 1000 CONTINUE
422 IF(nthread1>0)THEN
423 nthread=nthread1
424 ELSE
425 nthread=nthread0 ! defaut run precedent
426 END IF
427 IF (got_nth == 1) THEN
428 IF (nthread>1 .AND. (nth/= nthread .OR. (nth==nthread .AND.
429 + nthread1>0.AND.nthread0>1.AND.nthread1/=nthread0)))THEN
430 WRITE(iout,*)
431 + '** WARNING : -nthread OPTION USED, DEFAULT SETTING IGNORED'
432 WRITE(iout,*)' '
433 END IF
434 nthread = nth
435 ELSE
436 IF(nthread1>0.AND.nthread0>1.AND.nthread1/=nthread0)THEN
437 WRITE(iout,*)
438 + '** WARNING : OMP_NUM_THREADS SET, DEFAULT SETTING IGNORED'
439 WRITE(iout,*)' '
440 END IF
441 ENDIF
442 IF(nthread<=0) nthread=1
443 IF(nthread>nthmax) nthread=nthmax
444C
445#elif 1
446 nthread = 1
447#endif
448 ELSE IF(icas==3) THEN
449C
450 IF (nspmd /= nnodes) THEN
451 WRITE(iout,*)
452 . 'NON HYBRID EXECUTABLE ONLY SUPPORTS ONE SPMD DOMAIN'
453 WRITE(iout,*)
454 . 'PLEASE, RUN STARTER WITH -nspmd 1 OR USE HMPP EXECUTABLE'
455 WRITE(iout,*)
456 . 'REQUIRED (number of .rst files) NSPMD =',nspmd
457 WRITE(iout,*)
458 . 'AVAILABLE =',nnodes
459 WRITE(iout,*)' '
460 WRITE(istdo,*)
461 . 'NON HYBRID EXECUTABLE ONLY SUPPORTS ONE SPMD DOMAIN'
462 WRITE(istdo,*)
463 . 'PLEASE, RUN STARTER WITH -nspmd 1 OR USE HMPP EXECUTABLE'
464 WRITE(istdo,*)' '
465 WRITE(iout,*)
466 . ' E R R O R T E R M I N A T I O N'
467 WRITE(istdo,*)
468 . ' E R R O R T E R M I N A T I O N'
469 WRITE(iout,*)
470 . ' TOTAL NUMBER OF CYCLES :', ncycle
471 WRITE(istdo,*)
472 . ' TOTAL NUMBER OF CYCLES :', ncycle
473 icode=2
474 CALL arret(7)
475C
476 ENDIF
477 nbtask(1)=nthread
478 nbtask(2)=nthread
479#if defined(_OPENMP)
480 CALL omp_set_num_threads(nthread)
481 DO i = 1, 2*intseg
482 CALL omp_init_lock(llock(1,i))
483 ENDDO
484#endif
485 ELSE IF(icas==2) THEN
486#if defined(_OPENMP)
487#endif
488 ENDIF
489 RETURN
490 END
491
492#endif
inipar
subroutine inipar(coupling, itid, icas, nnodes, input, got_input, nbtask)
Definition inipar.F:372
mpi_finalize
subroutine mpi_finalize(ierr)
Definition mpi.f:288
mpi_comm_split
subroutine mpi_comm_split(comm, color, key, comm2, ierr)
Definition mpi.f:272
mpi_get_processor_name
subroutine mpi_get_processor_name(name, resultlen, ierror)
Definition mpi.f:196
mpi_barrier
subroutine mpi_barrier(comm, ierr)
Definition mpi.f:188
mpi_comm_size
subroutine mpi_comm_size(comm, size, ierr)
Definition mpi.f:263
mpi_bcast
subroutine mpi_bcast(buffer, cnt, datatype, root, comm, ierr)
Definition mpi.f:205
mpi_init
subroutine mpi_init(ierr)
Definition mpi.f:342
mpi_gather
subroutine mpi_gather(sendbuf, cnt, datatype, recvbuf, reccnt, rectype, root, comm, ierr)
Definition mpi.f:56
mpi_comm_rank
subroutine mpi_comm_rank(comm, rank, ierr)
Definition mpi.f:254
mpi_initialized
subroutine mpi_initialized(flag, ierr)
Definition mpi.f:350
mpi_abort
subroutine mpi_abort(comm, ierrcode, ierr)
Definition mpi.f:153
arret
subroutine arret(nn)
Definition arret.F:86