inipar.F

Go to the documentation of this file.

Copyright>        OpenRadioss
Copyright>        Copyright (C) 1986-2025 Altair Engineering Inc.
Copyright>
Copyright>        This program is free software: you can redistribute it and/or modify
Copyright>        it under the terms of the GNU Affero General Public License as published by
Copyright>        the Free Software Foundation, either version 3 of the License, or
Copyright>        (at your option) any later version.
Copyright>
Copyright>        This program is distributed in the hope that it will be useful,
Copyright>        but WITHOUT ANY WARRANTY; without even the implied warranty of
Copyright>        MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
Copyright>        GNU Affero General Public License for more details.
Copyright>
Copyright>        You should have received a copy of the GNU Affero General Public License
Copyright>        along with this program.  If not, see <https://www.gnu.org/licenses/>.
Copyright>
Copyright>
Copyright>        Commercial Alternative: Altair Radioss Software
Copyright>
Copyright>        As an alternative to this open-source version, Altair also offers Altair Radioss
Copyright>        software under a commercial license.  Contact Altair to discuss further if the
Copyright>        commercial version may interest you: https://www.altair.com/radioss/.
#ifdef MPI
!||====================================================================
!||    inipar                 ../engine/source/mpi/init/inipar.F
!||--- called by ------------------------------------------------------
!||    radioss2               ../engine/source/engine/radioss2.F
!||--- calls      -----------------------------------------------------
!||    arret                  ../engine/source/system/arret.F
!||    omp_get_max_threads    ../engine/source/engine/openmp_stub.F90
!||    omp_set_num_threads    ../engine/source/engine/openmp_stub.F90
!||--- uses       -----------------------------------------------------
!||    coupling_adapter_mod   ../engine/source/coupling/coupling_adapter.F90
!||    spmd_comm_world_mod    ../engine/source/mpi/spmd_comm_world.F90
!||====================================================================
      SUBROUTINE inipar(coupling,ITID,ICAS,NNODES,INPUT,GOT_INPUT,NBTASK)
C-----------------------------------------------------------------
        USE coupling_adapter_mod
        USE spmd_comm_world_mod, ONLY : spmd_comm_world
#include      "implicit_f.inc"
#include      "comlock.inc"
#include      "r4r8_p.inc"
C-----------------------------------------------------------------
C   M e s s a g e   P a s s i n g
C-----------------------------------------------
#include "spmd.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER ITID(*),ICAS, NNODES,GOT_INPUT,NBTASK(*)
      CHARACTER*100 INPUT
      type(coupling_type), intent(inout) :: coupling
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include  "com01_c.inc"
#include  "task_c.inc"
#include  "scr05_c.inc"
#include  "units_c.inc"
#include  "commandline.inc"
      INTEGER KEY, IERR
C-----------------------------------------------
C   L o c a l  V a r i a b l e s
C-----------------------------------------------
      INTEGER STATUS(MPI_STATUS_SIZE),IERROR,ICODE
      INTEGER MYRANK, JRANK, I, J, NTHREAD1, LOCAL, RLEN
      CHARACTER (LEN=255) :: STR      
      CHARACTER (LEN=MPI_MAX_PROCESSOR_NAME) :: HSTNAM,HOST
      character(len=MPI_MAX_PROCESSOR_NAME), dimension(:), allocatable :: hostname
      integer, dimension(:), allocatable :: perm,host_numbers,buffer
      INTEGER HOST_NUMBER
      INTEGER NSPMDx2
      INTEGER :: COLOUR
      INTEGER (kind=MPI_ADDRESS_KIND) :: COLOUR_ADDR
      INTEGER :: VALID
      CHARACTER FILNAM*100
#if defined(_OPENMP)
      INTEGER OMP_GET_MAX_THREADS
#endif
C--------------------------------------------------
C     CONVENTIONS:
C                  ispmd 0...NSPMD-1
C--------------------------------------------------
      IF(icas==1) THEN
        REAL = mpi_real
        IF(ir4r8==2) real = mpi_double_precision
C
        key = 0
        CALL mpi_initialized(key, ierr)
        valid = 0
        colour_addr = 0
 
        CALL mpi_init(ierror)
 
        CALL mpi_comm_get_attr(mpi_comm_world, mpi_appnum,
     *                            colour_addr, valid, ierror)
 
        IF (ierror == mpi_success) THEN
           colour = int(colour_addr)
        ELSE
           colour = 0  ! Default color if attribute not found
        ENDIF
        call coupling_configure(coupling, trim(coupling%FILNAM))  
 
#ifndef WITH_CWIPI 
        CALL mpi_comm_split(mpi_comm_world,colour,key,
     *                      spmd_comm_world,ierror)
#else
        spmd_comm_world = coupling_get_communicator(coupling%adapter_ptr)
#endif
        CALL mpi_comm_size(spmd_comm_world, nnodes, ierror)
        CALL mpi_comm_rank(spmd_comm_world, myrank, ierror)
C
        DO jrank=1,nnodes
          it_spmd(jrank) = jrank-1
        END DO
C
        IF (myrank==0) THEN
C         I AM THE FIRST ONE
          ispmd = 0
C
C Calcul du nombre de threads  { Calculating the number of threads }
C
#if defined(_OPENMP)
          str = ' '
          CALL  getenv('omp_num_threads',STR)
          NTHREAD1=0
C nthread1 : nombre de threads fixe par la variable environnememt
C {nthread1: number of threads fixed by the environment variable }
          READ(STR,'(i10)',ERR=999)NTHREAD1
          GOTO 1000
 999      CONTINUE
          NTHREAD1 = -1
 1000     CONTINUE
          IF(NTHREAD1>0)THEN
            NTHREAD=NTHREAD1
          ELSE
            NTHREAD=NTHREAD0 ! defaut run precedent
          END IF
          IF (GOT_NTH == 1) THEN
.AND..OR..AND.            IF (NTHREAD>1  (NTH/= NTHREAD  (NTH==NTHREAD 
.AND..AND.     +          NTHREAD1>0NTHREAD0>1NTHREAD1/=NTHREAD0)))THEN
              WRITE(IOUT,*)
     +      '** warning : -nthread option used, default setting ignored'
              WRITE(IOUT,*)' '
            END IF
            NTHREAD = NTH
          ELSE
.AND..AND.            IF(NTHREAD1>0NTHREAD0>1NTHREAD1/=NTHREAD0)THEN
                WRITE(IOUT,*)
     +      '** warning : omp_num_threads set, default setting ignored'
                WRITE(IOUT,*)' '
            END IF
          ENDIF
          IF(NTHREAD<=0)  NTHREAD=1
          IF(NTHREAD>NTHMAX) NTHREAD=NTHMAX
#elif 1
          NTHREAD = 1
#endif
        ELSE
          CALL MPI_BCAST(
     1      NSPMD,1,MPI_INTEGER,IT_SPMD(1),SPMD_COMM_WORLD,
     2      IERROR )
C recuperation de NTHREAD depuis process 0   { recovery of NTHREAD from process 0 }
          CALL MPI_BCAST(
     1      NTHREAD,1,MPI_INTEGER,IT_SPMD(1),SPMD_COMM_WORLD,
     2      IERROR )
C
          IF (GOT_INPUT == 0)THEN
            CALL MPI_BCAST(INPUT,100,MPI_CHARACTER,IT_SPMD(1),
     .                     SPMD_COMM_WORLD,IERROR)
          ENDIF
C
          DO J=2,NSPMD
            IF(MYRANK==IT_SPMD(J))THEN
               ISPMD = J-1
            END IF
          END DO
cccc
C code special pour MIC
#if defined(__MIC__)
          STR = ' '
          CALL  GETENV('omp_num_threads',STR)
          NTHREAD1=0
C nthread1 : nombre de threads fixe par la variable environnement sur le MIC
          READ(STR,'(i10)',ERR=1999)NTHREAD1
          GOTO 2000
 1999     CONTINUE
          NTHREAD1 = -1
 2000     CONTINUE
.AND.          IF(NTHREAD1>0  NTHREAD1 /= NTHREAD)THEN
            NTHREAD=NTHREAD1
            WRITE(ISTDO,'(a,i4,a,i4)')
     .        '** warning: reset omp_num_threads to:',
     .        NTHREAD,' for mpi process',ISPMD+1 
          ENDIF
#endif
C control of nthread per MPI process
          CALL MPI_GATHER(NTHREAD,1,MPI_INTEGER,NBTASK,1,MPI_INTEGER,
     .                    IT_SPMD(1),SPMD_COMM_WORLD,IERROR)            
           
            END IF
      ELSE IF(ICAS==3) THEN
        IF(ISPMD == 0) THEN
C
C test cooherence NSPMD et nombre de proccesses MPI demandes (-np)
C { NSPMD coherence test and number of MPI processes requested (-np) }
C
          IF (NSPMD /= NNODES) THEN
            WRITE(IOUT,*)
     .      'the required number of mpi processes does not match mpirun'
            WRITE(IOUT,*)
     .      'please, run with the proper number of mpi processes'
            WRITE(IOUT,*)
     .      'required(number of .rst files) nspmd =',NSPMD
            WRITE(IOUT,*)
     .      'available(-np argument of mpirun)    =',NNODES
            WRITE(IOUT,*)' '
            WRITE(ISTDO,*)
     .      'the required number of mpi processes does not match mpirun'
            WRITE(ISTDO,*)
     .      'please, run with the proper number of mpi processes'
            WRITE(ISTDO,*)' '
            WRITE(IOUT,*)
     .             ' e r r o r     t e r m i n a t i o n'
            WRITE(ISTDO,*)
     .             ' e r r o r     t e r m i n a t i o n'
            WRITE(IOUT,*)
     .             ' total number of cycles  :', NCYCLE
            WRITE(ISTDO,*)
     .             ' total number of cycles  :', NCYCLE
            ICODE=2
            CALL MPI_ABORT(SPMD_COMM_WORLD,ICODE,ierror)
            CALL ARRET(7)
          END IF
          IF(NSPMD > 1) THEN
C envoi NSPMD de process0 vers les autres processes
C { sending NSPMD from process0 to other processes }
            CALL MPI_BCAST(NSPMD,1,MPI_INTEGER,IT_SPMD(1),
     .                     SPMD_COMM_WORLD,IERROR)
C envoi de NTHREAD de process0 vers les autres processes
C { sending NTHREAD from process0 to other processes }
            CALL MPI_BCAST(NTHREAD,1,MPI_INTEGER,IT_SPMD(1),
     .                     SPMD_COMM_WORLD,IERROR)
C
            IF (GOT_INPUT == 0)THEN
              CALL MPI_BCAST(INPUT,100,MPI_CHARACTER,IT_SPMD(1),
     .                       SPMD_COMM_WORLD,IERROR)
            ENDIF
            
C control of nthread per MPI process
            CALL MPI_GATHER(NTHREAD,1,MPI_INTEGER,NBTASK,1,MPI_INTEGER,
     .                      IT_SPMD(1),SPMD_COMM_WORLD,IERROR)            
            IF(ISPMD==0)THEN
              NBTASK(NSPMD+1)=0
              DO I=1,NSPMD
                NBTASK(NSPMD+1)=NBTASK(NSPMD+1)+NBTASK(I)
              END DO
          END IF
          ELSE
            NBTASK(1)=NTHREAD
            NBTASK(2)=NTHREAD
          END IF
C
        END IF
C------------------------------------------------------------
C     Starting from now, ALL TASK ARE EQUAL ===> SPMD program
C------------------------------------------------------------
C
C Init OpenMP
C
#if defined(_OPENMP)
        CALL OMP_SET_NUM_THREADS(NTHREAD)
        DO I = 1, 2*INTSEG
          CALL OMP_INIT_LOCK(LLOCK(1,I))
        ENDDO
#endif
C
C Init local SPMD numbering on a node (L_SPMD)
C
        allocate(hostname(nspmd))
        CALL MPI_GET_PROCESSOR_NAME(HSTNAM,RLEN,IERROR)
        CALL MPI_GATHER(
     .     HSTNAM,MPI_MAX_PROCESSOR_NAME,MPI_CHARACTER,
     .     HOSTNAME   ,MPI_MAX_PROCESSOR_NAME,MPI_CHARACTER,
     .     IT_SPMD(1),SPMD_COMM_WORLD,IERROR)
        
        allocate(perm(nspmd))
        allocate(host_numbers(nspmd))
        allocate(buffer(2*nspmd))     
        IF(ISPMD==0)THEN
C permutations during sort are saved
          DO I = 1,NSPMD
            PERM(I) = I
          END DO
C tri bulle basic
          DO I = 1, NSPMD-1
            DO J = I, NSPMD
              IF(HOSTNAME(I) > HOSTNAME(J))THEN
                HOST = HOSTNAME(I)
                HOSTNAME(I) = HOSTNAME(J)
                PERM(I) = J
                HOSTNAME(J) = HOST
                PERM(J) = I
              END IF
            END DO
          END DO
          HOST = ' '
          LOCAL=0
          HOST_NUMBER = 0
          DO I = 1, NSPMD
            IF(HOST /= HOSTNAME(I))THEN
              HOST = HOSTNAME(I)
              LOCAL = 1
              HOST_NUMBER = HOST_NUMBER + 1
            ELSE
              LOCAL = LOCAL + 1
            ENDIF
            L_SPMD(PERM(I))=LOCAL-1
            HOST_NUMBERS(PERM(I))=HOST_NUMBER
          ENDDO
C         preparing MPI buffer 
C         Local rank in the node
          BUFFER(1:NSPMD) = L_SPMD(1:NSPMD) 
C         host numbers
          BUFFER(NSPMD+1:2*NSPMD) = HOST_NUMBERS(1:NSPMD)
          deallocate(perm)
        ENDIF
        NSPMDx2 = NSPMD*2
        CALL MPI_BCAST(BUFFER,NSPMDx2,MPI_INTEGER,IT_SPMD(1),
     .                 SPMD_COMM_WORLD,IERROR)
 
        L_SPMD(1:NSPMD) = BUFFER(1:NSPMD)         
        HOST_NUMBERS(1:NSPMD) = BUFFER(NSPMD+1:2*NSPMD)
    
        NSPMD_PER_NODE=0 
C       Count the number of SPMD on the local host
        DO I = 1,NSPMD
          IF(HOST_NUMBERS(I) == HOST_NUMBERS(ISPMD+1)) THEN
            NSPMD_PER_NODE = NSPMD_PER_NODE + 1 
          ENDIF
        END DO  
 
        deallocate(hostname)
        deallocate(host_numbers)
        deallocate(buffer)
 
      ELSE IF(ICAS==2) THEN
C
        CALL MPI_BARRIER(SPMD_COMM_WORLD,IERROR)
C
        CALL MPI_FINALIZE(IERROR)
      ENDIF
C
      RETURN
      END
C MPI
 
#elif 1
C
C routines simplifiees non mpi
C
!||====================================================================
!||    inipar                 ../engine/source/mpi/init/inipar.F
!||--- called by ------------------------------------------------------
!||    radioss2               ../engine/source/engine/radioss2.F
!||--- calls      -----------------------------------------------------
!||    arret                  ../engine/source/system/arret.F
!||    omp_get_max_threads    ../engine/source/engine/openmp_stub.F90
!||    omp_set_num_threads    ../engine/source/engine/openmp_stub.F90
!||--- uses       -----------------------------------------------------
!||    coupling_adapter_mod   ../engine/source/coupling/coupling_adapter.F90
!||    spmd_comm_world_mod    ../engine/source/mpi/spmd_comm_world.F90
!||====================================================================
      SUBROUTINE INIPAR(coupling, ITID,ICAS,NNODES,INPUT,GOT_INPUT,NBTASK)
C-----------------------------------------------------------------
        USE SPMD_COMM_WORLD_MOD, ONLY : SPMD_COMM_WORLD
        USE COUPLING_ADAPTER_MOD
#include      "implicit_f.inc"
#include      "comlock.inc"
#include      "r4r8_p.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER ITID(*),ICAS, NNODES,GOT_INPUT,NBTASK(*)
      CHARACTER*100 INPUT
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include "spmd.inc"
#include  "com01_c.inc"
#include  "task_c.inc"
#include  "scr05_c.inc"
#include  "units_c.inc"
#include  "commandline.inc"
C-----------------------------------------------
C   L o c a l  V a r i a b l e s
C-----------------------------------------------
      type(coupling_type), intent(inout) :: coupling
      INTEGER ICODE, I, NTHREAD1
#if defined(_OPENMP)
      INTEGER OMP_GET_MAX_THREADS
#endif
      CHARACTER (LEN=255) :: STR
C--------------------------------------------------
C     CONVENTIONS:
C                  ispmd 0...NSPMD-1
C--------------------------------------------------
      IF(ICAS==1) THEN
C
        REAL = 4
        IF(IR4R8==2) REAL = 8
C
        NNODES= 1
        ISPMD = 0
#if defined(_OPENMP)
        STR = ' '
        CALL  GETENV('omp_num_threads',STR)
        NTHREAD1=0
C nthread1 : nombre de threads fixe par la variable environnememt
        READ(STR,'(i10)',ERR=999)NTHREAD1
        GOTO 1000
 999    CONTINUE
        NTHREAD1 = -1
 1000   CONTINUE
        IF(NTHREAD1>0)THEN
          NTHREAD=NTHREAD1
        ELSE
          NTHREAD=NTHREAD0 ! defaut run precedent
        END IF
        IF (GOT_NTH == 1) THEN
.AND..OR..AND.          IF (NTHREAD>1  (NTH/= NTHREAD  (NTH==NTHREAD 
.AND..AND.     +        NTHREAD1>0NTHREAD0>1NTHREAD1/=NTHREAD0)))THEN
            WRITE(IOUT,*)
     +    '** warning : -nthread option used, default setting ignored'
            WRITE(IOUT,*)' '
          END IF
          NTHREAD = NTH
        ELSE
.AND..AND.          IF(NTHREAD1>0NTHREAD0>1NTHREAD1/=NTHREAD0)THEN
              WRITE(IOUT,*)
     +    '** warning : omp_num_threads set, default setting ignored'
              WRITE(IOUT,*)' '
          END IF
        ENDIF
        IF(NTHREAD<=0)  NTHREAD=1
        IF(NTHREAD>NTHMAX) NTHREAD=NTHMAX
C
#elif 1
        NTHREAD = 1
#endif
      ELSE IF(ICAS==3) THEN
C
        IF (NSPMD /= NNODES) THEN
          WRITE(IOUT,*)
     .    'non hybrid executable only supports one spmd domain'
          WRITE(IOUT,*)
     .    'please, run starter with -nspmd 1 or USE hmpp executable'
          WRITE(IOUT,*)
     .        'required (number of .rst files) nspmd =',NSPMD
          WRITE(IOUT,*)
     .        'available                             =',NNODES
          WRITE(IOUT,*)' '
          WRITE(ISTDO,*)
     .    'non hybrid executable ONLY supports one spmd domain'
          WRITE(ISTDO,*)
     .    'please, run starter with -nspmd 1 or use hmpp executable'
          WRITE(ISTDO,*)' '
          WRITE(iout,*)
     .             ' E R R O R     T E R M I N A T I O N'
          WRITE(istdo,*)
     .             ' E R R O R     T E R M I N A T I O N'
          WRITE(iout,*)
     .             ' TOTAL NUMBER OF CYCLES  :', ncycle
          WRITE(istdo,*)
     .             ' TOTAL NUMBER OF CYCLES  :', ncycle
          icode=2
          CALL arret(7)
C
        ENDIF
        nbtask(1)=nthread
        nbtask(2)=nthread
#if defined(_OPENMP)
        CALL omp_set_num_threads(nthread)
        DO i = 1, 2*intseg
          CALL omp_init_lock(llock(1,i))
        ENDDO
#endif
      ELSE IF(icas==2) THEN
#if defined(_OPENMP)
#endif
      ENDIF
      RETURN
      END
 
#endif