stack_overwrite.F90

Go to the documentation of this file.

MODULE stack_overwrite 
!----------------------------------------------------------------------------------
! This module allows you to check whether an application thread is writing into 
! the stack of its neighbouring thread
!   To use
!     Set N= parthds value in XLSMPOPTS environment variable
!     Set NN= to that area of stack which should not be used
!       <---thread 1----------> <-----thread 2-------> <---...
!       !======|===============|========|==============|====...
!       <--NN-->                <--NN--> 
!       <---------N-----------> <---------N---------->
!     Add "CALL STACK_OWRITE_SET" in first routine
!     Add "CALL STACK_OWRITE_CHK" to any routines called after stack may have been corrupted
!     Add "USE STACK_OVERWRITE" to all modified routines
!   Compile this routine and all modified routines
!   Link and run
!     Get "STACK_OWRITE_CHK: nt,ii,zstk=" if stack overwriten
!----------------------------------------------------------------------------------
  USE parkind1 , ONLY : jpim
  SAVE
  INTEGER*8 :: stack_owrite_beg(16)         ! Change if max threads > 16
  INTEGER(KIND=JPIM) n,nn
  parameter(n=25*1000*1000,nn=5*1000*1000)

  CONTAINS
  SUBROUTINE stack_owrite_set
  IMPLICIT NONE
  INTEGER(KIND=JPIM) N,NN,NT,MT,IER
  INTEGER(KIND=JPIM) OMP_GET_THREAD_NUM,OMP_GET_MAX_THREADS
  parameter(n=25*1000*1000)
  parameter(nn=5*1000*1000)
#ifdef SFX_MPI
  include "mpif.h"
#endif
  INTEGER(KIND=JPIM) ZSTK(n)
  INTEGER(KIND=JPIM) II,ZOFF,NNN
  INTEGER*8 ZTMP
  nt=omp_get_thread_num()
  mt=omp_get_max_threads()
  zstk(1:nn)=9999
  IF(nt>0) THEN
    ztmp=loc(zstk(1))
    stack_owrite_beg(nt)=ztmp
    zoff=(stack_owrite_beg(nt)-ztmp)/4
!   write(0,*) "STACK_OWRITE_SET: nt,stack_owrite_beg,loc(zstk(1)),zoff=",nt,stack_owrite_beg(nt),loc(zstk(1)),zoff
!   do ii=1,2
!     if(zstk(zoff+ii).ne.9999) then
!       write(0,*) "STACK_OWRITE_SET: nt,ii,zstk=",nt,ii,zstk(zoff+ii)
!     endif
!   enddo
!-----deliberate overwrite of neighbouring stack---------
    nnn=n+nn/2
    WRITE(0,*) "mt,nnn=",mt,nnn
    IF(nt<mt-1) zstk(nnn)=0
!-----------------------------------
  ENDIF
  CALL stack_owrite_dum(zstk)
  END SUBROUTINE stack_owrite_set

  SUBROUTINE stack_owrite_chk
  IMPLICIT NONE
  INTEGER(KIND=JPIM) OMP_GET_THREAD_NUM
  INTEGER(KIND=JPIM) N,NN,NT,II
  INTEGER(KIND=JPIM) ZOFF
  parameter(n=25*1000*1000)
  parameter(nn=5*1000*1000)
  INTEGER(KIND=JPIM) ZSTK(n)
  INTEGER*8 ZTMP
  nt=omp_get_thread_num()
  IF(nt>0) THEN
    ztmp=loc(zstk(1))
    zoff=(stack_owrite_beg(nt)-ztmp)/4
!   write(0,*) "STACK_OWRITE_CHK: nt,owrite_beg,loc(zstk(1)),zoff=",nt,stack_owrite_beg(nt),loc(zstk(1)),zoff
!   write(0,*) "STACK_OWRITE_CHK: nt,1,zstk=",nt,1,zstk(zoff+1)
    DO ii=1,nn
      IF(zstk(zoff+ii).NE.9999) THEN
        WRITE(0,*) "STACK_OWRITE_CHK: nt,ii,zstk=",nt,ii,zstk(zoff+ii)
      ENDIF
    ENDDO
!   write(0,*) "STACK_OWRITE_CHK: nt,NN,zstk=",nt,NN,zstk(zoff+NN)
  ENDIF
  END SUBROUTINE stack_owrite_chk
  
  SUBROUTINE stack_owrite_dum(IDUM)
  INTEGER(KIND=JPIM) IDUM(n)
  END SUBROUTINE stack_owrite_dum

END MODULE stack_overwrite