jfh_bind.F90

Go to the documentation of this file.

 SUBROUTINE jfh_bind()
#ifndef RS6K
 WRITE(0,*) "JFH_BIND compiled without -DRS6K so not binding"
 RETURN
 END SUBROUTINE jfh_bind
#else
!     PURPOSE.
!     --------
!       Binds task and threads to CPUs for LL submitted jobs 
!       (not for interactive jobs)

!     INTERFACE.
!     ----------
!       CALL JFH_BIND() 

!     METHOD.
!     -------
!       The first call to JFH_BIND routine binds CPUs according to 
!       the env vars 
!         JFH_BIND=map
!         JFH_BMAP="N 0 1 2 ..."  where N is number of entries
!       and prints out the binding
!         e.g. for 4 threads: CPUs = 0 32 1 33

!       Subsequent calls, and calls without env vars set, will not bind, 
!       but will print out the binding

!       JFH_BIND may be called before or after mpi_init

!       Note that IFS may also call EC_BIND, which binds differently to 
!       jfh_bind, but it will not be called (in CY37R3) if:
!         mpi_init is called before mpl_init
!         the job is not run on whole nodes

!       Serial (non MPI) version can be created by compiling with -DSERIAL

!     EXTERNALS.   
!     ----------   
!       SYSTEM             Get host name
!       MPI_INITIALIZED    Check if mpi iniitalised
!       MPI_COMM_RANK      Get rank of mpi tasK
!       GETENV             Get environment variable
!       OMP_GET_THREAD_NUM Get thread num
!       --- following in jfhc.c-----
!       AFF                Get cpu num & CPUs per node
!       SMTCTL             Get CPU ids for SMT id
!       IS_SMT_ON          Check for SMT 
!       JBIND              Bind thread to processor

!     AUTHOR.
!     -------
!        J.Hague,  IBM,  Aug 2011  
!     ------------------------------------------------------------------

 IMPLICIT NONE
 INTEGER omp_get_max_threads
 INTEGER omp_get_thread_num
 INTEGER, ALLOCATABLE :: ita(:), map(:)
 INTEGER, ALLOCATABLE :: jcpu(:), id0(:), id1(:)
 INTEGER ip,it,nt,mp,iproc,nmap
 INTEGER icpu,ier
 INTEGER i,ii,mdum
 INTEGER ismt, is_smt_on  
 INTEGER ifirst, iprt, ira
 LOGICAL lflg
 CHARACTER*120 c,c1,c2
 CHARACTER*3 cb, cc
 CHARACTER*1000 cbm
 SAVE        cb,cbm
 DATA ifirst/0/
#ifndef SERIAL
#ifdef SFX_MPI
include "mpif.h"
#endif
#endif

 CALL system("hostname")

#ifndef SERIAL
 CALL mpi_initialized(lflg,ier)
 IF(lflg) THEN
   CALL mpi_comm_rank(mpi_comm_world,ip,ier)
 ELSE
#ifdef RS6K
  CALL get_environment_variable("MP_CHILD",VALUE=c)
#endif
  READ(c,*) ip
 ENDIF
!write(0,*) "LFLG,ip=",LFLG,ip
#else
 ip=0
#endif

 CALL aff(mdum,mp)
 ALLOCATE(map(mp+1))
 ALLOCATE(jcpu(mp))
 ALLOCATE(id0(mp/2))
 ALLOCATE(id1(mp/2))
 nt=omp_get_max_threads()
 ALLOCATE(ita(nt))

 CALL get_environment_variable("JFH_BIND",cb)
 IF(ifirst.EQ.0) THEN
   ifirst=1
   IF(cb.EQ."yes".OR.cb.EQ."YES".OR.cb.EQ."map".OR.cb.EQ."MAP") THEN
     DO i=1,mp
       jcpu(i)=i-1
     ENDDO

!---------Must reset jcpu if SMT ON-----------------------------
     ismt=is_smt_on()
!    write(0,*) "ismt=",ismt
     IF(ismt .NE. -99) THEN
       CALL smtctl(mp/2, id0, id1)
       DO i=1,mp/2
        jcpu(2*i-1)=id0(i)
        jcpu(2*i  )=id1(i)
       ENDDO
     ENDIF
!---------------------------------------------------------------
!    write(0,*) "jcpu=",jcpu

     map(1)=-1
     nmap=mp
     IF(cb.EQ."map".OR.cb.EQ."MAP") THEN
        CALL get_environment_variable("JFH_BMAP",cbm)
      READ(cbm,*) nmap,(map(i),i=1,min(mp,nmap))
!       write(6,*) "NMAP,Map=",NMAP,(MAP(I),I=1,NMAP)
     ENDIF

     ira=0
     CALL get_environment_variable("JFH_RA_DET",cc)
     IF(cc.EQ."yes".OR.cc.EQ."YES") ira=1
!    write(0,*) "CC,ira=",CC,ira
     iprt=0
     CALL get_environment_variable("JFH_RA_PRT",cc)
     IF(cc.EQ."yes".OR.cc.EQ."YES") iprt=1

!$OMP PARALLEL 
     IF(ira==1) THEN
!      write(0,*) "Calling ra_det"
       CALL ra_det(2,iprt)
     ENDIF
!$OMP END PARALLEL 

!$OMP PARALLEL PRIVATE(IT,IPROC)
     it=omp_get_thread_num()
     IF(ira==1) CALL ra_check(2,iprt)
     iproc=nt*ip+it
     iproc=mod(iproc,nmap)
!    write(0,*) "i,it,IPROC=",i,it,IPROC
!    write(0,*) "it,IPROC,MAP,jcpu,MAP",it,IPROC,MAP(IPROC+1),jcpu(MAP(IPROC+1)+1)
     IF(map(1).EQ.-1) CALL jbind(jcpu(iproc+1))
     IF(map(1).NE.-1) CALL jbind(jcpu(map(iproc+1)+1))
!$OMP END PARALLEL 

   ENDIF
 ENDIF

!$OMP PARALLEL PRIVATE(it,icpu,mdum)
   it=omp_get_thread_num()
   CALL aff(icpu,mdum)
   ita(it+1)=icpu
!$OMP END PARALLEL
 WRITE(0,*) "CPUs = ",(ita(i),i=1,nt)
 DEALLOCATE(ita,map,jcpu,id0,id1)
 END SUBROUTINE jfh_bind
#endif