Commit ae415ee4 authored by Graham, Aaron's avatar Graham, Aaron
Browse files

Merge branch 'hotfix_times' into 'master'

Hotfix times and gather

See merge request futility/Futility!356
parents e545722f e4713d13
Pipeline #184159 passed with stage
in 14 minutes and 41 seconds
......@@ -196,6 +196,18 @@ TYPE,EXTENDS(ParEnvType) :: MPI_EnvType
!> @copybrief ParallelEnv::gather_SLK1_MPI_Env_type
!> @copydetails ParallelEnv::gather_SLK1_MPI_Env_type
PROCEDURE,PASS,PRIVATE :: gather_SLK1_MPI_Env_type
!> @copybrief ParallelEnv::gather_SSK0_MPI_Env_type
!> @copydetails ParallelEnv::gather_SSK0_MPI_Env_type
PROCEDURE,PASS,PRIVATE :: gather_SSK0_MPI_Env_type
!> @copybrief ParallelEnv::gather_SSK1_MPI_Env_type
!> @copydetails ParallelEnv::gather_SSK1_MPI_Env_type
PROCEDURE,PASS,PRIVATE :: gather_SSK1_MPI_Env_type
!> @copybrief ParallelEnv::gather_SDK0_MPI_Env_type
!> @copydetails ParallelEnv::gather_SDK0_MPI_Env_type
PROCEDURE,PASS,PRIVATE :: gather_SDK0_MPI_Env_type
!> @copybrief ParallelEnv::gather_SDK1_MPI_Env_type
!> @copydetails ParallelEnv::gather_SDK1_MPI_Env_type
PROCEDURE,PASS,PRIVATE :: gather_SDK1_MPI_Env_type
!> @copybrief ParallelEnv::gather_str1D_MPI_ENV_type
!> @copydetails ParallelEnv::gather_str1D_MPI_ENV_type
PROCEDURE,PASS,PRIVATE :: gather_str1D_MPI_ENV_type
......@@ -203,10 +215,10 @@ TYPE,EXTENDS(ParEnvType) :: MPI_EnvType
!> @copydetails ParallelEnv::gather_str2D_MPI_ENV_type
PROCEDURE,PASS,PRIVATE :: gather_str2D_MPI_ENV_type
!>
GENERIC :: gather => gather_SNK0_MPI_Env_type, &
gather_SNK1_MPI_Env_type, &
gather_SLK0_MPI_Env_type, &
gather_SLK1_MPI_Env_type, &
GENERIC :: gather => gather_SNK0_MPI_Env_type,gather_SNK1_MPI_Env_type, &
gather_SLK0_MPI_Env_type,gather_SLK1_MPI_Env_type, &
gather_SSK0_MPI_Env_type,gather_SSK1_MPI_Env_type, &
gather_SDK0_MPI_Env_type,gather_SDK1_MPI_Env_type, &
gather_str1D_MPI_ENV_type, &
gather_str2D_MPI_ENV_type
!> @copybrief ParallelEnv::gatherv_SNK1_MPI_Env_type
......@@ -1009,7 +1021,7 @@ ENDSUBROUTINE recv_INT1_MPI_Env_type
!> @brief Wrapper routine calls MPI_Gather for integers
!> @param myPE parallel environment where the communication originates
!> @param sendbuf the data which is to be sent
!> @param recvbuf the data which is to be sent
!> @param recvbuf the data which is to be received
!> @param root the rank of the root process
!>
SUBROUTINE gather_SNK0_MPI_Env_type(myPE,sendbuf,recvbuf,root)
......@@ -1035,7 +1047,7 @@ ENDSUBROUTINE gather_SNK0_MPI_Env_type
!> @brief Wrapper routine calls MPI_Gather for an SNK array
!> @param myPE parallel environment where the communication originates
!> @param sendbuf the data which is to be sent
!> @param recvbuf the data which is to be sent
!> @param recvbuf the data which is to be received
!> @param root the rank of the root process
!>
SUBROUTINE gather_SNK1_MPI_Env_type(myPE,sendbuf,recvbuf,root)
......@@ -1070,7 +1082,7 @@ ENDSUBROUTINE gather_SNK1_MPI_Env_type
!> @brief Wrapper routine calls MPI_Gather
!> @param myPE parallel environment where the communication originates
!> @param sendbuf the data which is to be sent
!> @param recvbuf the data which is to be sent
!> @param recvbuf the data which is to be received
!> @param root the rank of the root process
!>
SUBROUTINE gather_SLK0_MPI_Env_type(myPE,sendbuf,recvbuf,root)
......@@ -1096,7 +1108,7 @@ ENDSUBROUTINE gather_SLK0_MPI_Env_type
!> @brief Wrapper routine calls MPI_Gather
!> @param myPE parallel environment where the communication originates
!> @param sendbuf the data which is to be sent
!> @param recvbuf the data which is to be sent
!> @param recvbuf the data which is to be received
!> @param root the rank of the root process
!>
SUBROUTINE gather_SLK1_MPI_Env_type(myPE,sendbuf,recvbuf,root)
......@@ -1127,6 +1139,127 @@ SUBROUTINE gather_SLK1_MPI_Env_type(myPE,sendbuf,recvbuf,root)
ENDSUBROUTINE gather_SLK1_MPI_Env_type
!
!-------------------------------------------------------------------------------
!> @brief Wrapper routine calls MPI_Gather for integers
!> @param myPE parallel environment where the communication originates
!> @param sendbuf the data which is to be sent
!> @param recvbuf the data which is to be received
!> @param root the rank of the root process
!>
SUBROUTINE gather_SSK0_MPI_Env_type(myPE,sendbuf,recvbuf,root)
CLASS(MPI_EnvType),INTENT(IN) :: myPE
REAL(SSK),INTENT(IN) :: sendbuf
REAL(SSK),INTENT(INOUT) :: recvbuf(:)
INTEGER(SIK),INTENT(IN),OPTIONAL :: root
INTEGER(SIK) :: rank
rank=0
IF(PRESENT(root)) rank=root
REQUIRE(0 <= rank)
REQUIRE(rank < myPE%nproc)
REQUIRE(SIZE(recvbuf) == myPE%nproc)
#ifdef HAVE_MPI
CALL MPI_Gather(sendbuf,1,MPI_REAL,recvbuf,1,MPI_REAL, &
rank,myPE%comm,mpierr)
#else
recvbuf(1)=sendbuf
#endif
ENDSUBROUTINE gather_SSK0_MPI_Env_type
!
!-------------------------------------------------------------------------------
!> @brief Wrapper routine calls MPI_Gather for an SSK array
!> @param myPE parallel environment where the communication originates
!> @param sendbuf the data which is to be sent
!> @param recvbuf the data which is to be received
!> @param root the rank of the root process
!>
SUBROUTINE gather_SSK1_MPI_Env_type(myPE,sendbuf,recvbuf,root)
CLASS(MPI_EnvType),INTENT(IN) :: myPE
REAL(SSK),INTENT(IN) :: sendbuf(:)
REAL(SSK),INTENT(INOUT) :: recvbuf(:,:)
INTEGER(SIK),INTENT(IN),OPTIONAL :: root
INTEGER(SIK) :: rank,count
#ifndef HAVE_MPI
INTEGER(SIK)::i,j,n
#endif
rank=0
IF(PRESENT(root)) rank=root
REQUIRE(0 <= rank)
REQUIRE(rank < myPE%nproc)
count=SIZE(sendbuf)
REQUIRE(SIZE(recvbuf) == myPE%nproc*count)
#ifdef HAVE_MPI
!32 Bit integer
CALL MPI_Gather(sendbuf,count,MPI_REAL,recvbuf,count, &
MPI_REAL,rank,myPE%comm,mpierr)
#else
DO n=1,count
i=MOD(n-1,SIZE(recvbuf,DIM=1))+1
j=(n-1)/SIZE(recvbuf,DIM=1)+1
recvbuf(i,j)=sendbuf(n)
ENDDO
#endif
ENDSUBROUTINE gather_SSK1_MPI_Env_type
!
!-------------------------------------------------------------------------------
!> @brief Wrapper routine calls MPI_Gather
!> @param myPE parallel environment where the communication originates
!> @param sendbuf the data which is to be sent
!> @param recvbuf the data which is to be received
!> @param root the rank of the root process
!>
SUBROUTINE gather_SDK0_MPI_Env_type(myPE,sendbuf,recvbuf,root)
CLASS(MPI_EnvType),INTENT(IN) :: myPE
REAL(SDK),INTENT(IN) :: sendbuf
REAL(SDK),INTENT(INOUT) :: recvbuf(:)
INTEGER(SIK),INTENT(IN),OPTIONAL :: root
INTEGER(SIK) :: rank
rank=0
IF(PRESENT(root)) rank=root
REQUIRE(0 <= rank)
REQUIRE(rank < myPE%nproc)
REQUIRE(SIZE(recvbuf) == myPE%nproc)
#ifdef HAVE_MPI
CALL MPI_Gather(sendbuf,1,MPI_DOUBLE_PRECISION,recvbuf,1,MPI_DOUBLE_PRECISION, &
rank,myPE%comm,mpierr)
#else
recvbuf(1)=sendbuf
#endif
ENDSUBROUTINE gather_SDK0_MPI_Env_type
!
!-------------------------------------------------------------------------------
!> @brief Wrapper routine calls MPI_Gather
!> @param myPE parallel environment where the communication originates
!> @param sendbuf the data which is to be sent
!> @param recvbuf the data which is to be received
!> @param root the rank of the root process
!>
SUBROUTINE gather_SDK1_MPI_Env_type(myPE,sendbuf,recvbuf,root)
CLASS(MPI_EnvType),INTENT(IN) :: myPE
REAL(SDK),INTENT(IN) :: sendbuf(:)
REAL(SDK),INTENT(INOUT) :: recvbuf(:,:)
INTEGER(SIK),INTENT(IN),OPTIONAL :: root
INTEGER(SIK) :: rank,count
#ifndef HAVE_MPI
INTEGER(SIK)::i,j,n
#endif
rank=0
IF(PRESENT(root)) rank=root
REQUIRE(0 <= rank)
REQUIRE(rank < myPE%nproc)
count=SIZE(sendbuf)
REQUIRE(SIZE(recvbuf) == myPE%nproc*count)
#ifdef HAVE_MPI
CALL MPI_Gather(sendbuf,count,MPI_DOUBLE_PRECISION,recvbuf,count, &
MPI_DOUBLE_PRECISION,rank,myPE%comm,mpierr)
#else
DO n=1,count
i=MOD(n-1,SIZE(recvbuf,DIM=1))+1
j=(n-1)/SIZE(recvbuf,DIM=1)+1
recvbuf(i,j)=sendbuf(n)
ENDDO
#endif
ENDSUBROUTINE gather_SDK1_MPI_Env_type
!
!-------------------------------------------------------------------------------
!> @brief Wrapper that emulates MPI_Gather for non-contiguous array of Strings
!> @param myPE parallel environment where the communication originates
!> @param sendbuf the data which is to be sent
......
......@@ -442,8 +442,17 @@ ENDFUNCTION getTimeChar
!> @brief Function returns the value of @ref Times::TimerType::elapsedtime
!> "%elapsedtime" as a string in HHMMSS format.
!> @param this input argument, a @ref Times::TimerType "TimerType" variable
!> @param tsec the time to format; optional, defaults to @c this%elapsedtime
!> @param force_hour logical to force writing hours even if @c tsec is less than 1 hour
!> @returns hh_mm_ss, the elapsed time as a string (hhh:mm:ss or mmm:ss.ss)
FUNCTION getTimeHHMMSS(this,tsec,force_hour) RESULT(hh_mm_ss)
!>
!> For times under 1 hour, the string will be formatted MM:SS.dd if @c force_hour is
!> false, or HH:MM:SS.dd if it is true. For times greater than or equal to one hour
!> but less than 100 hours, the time will be formatted HH:MM:SS.dd. For times greater
!> than or equal to 100 hours, the time will be formatted HHH:MM:SS.d. Times of
!> 1000 hours and greater are not supported.
!>
IMPURE ELEMENTAL FUNCTION getTimeHHMMSS(this,tsec,force_hour) RESULT(hh_mm_ss)
CLASS(TimerType),INTENT(IN) :: this
REAL(SRK),INTENT(IN),OPTIONAL :: tsec
LOGICAL(SBK),INTENT(IN),OPTIONAL :: force_hour
......@@ -464,8 +473,22 @@ FUNCTION getTimeHHMMSS(this,tsec,force_hour) RESULT(hh_mm_ss)
hrs=it/3600_SIK ! Total number of hours
mins=(it-hrs*3600_SIK)/60_SIK ! Total number of minutes
secs=t-REAL(hrs*3600+mins*60_SIK,SRK)
IF(secs > 59.995_SRK) THEN
mins=mins+1_SIK
secs=0.000_SRK
ENDIF
IF(mins == 60_SIK) THEN
hrs=hrs+1_SIK
mins=0_SIK
ENDIF
IF(hrs > 0_SIK .OR. force_hours) THEN
IF(hrs >= 100_SIK) THEN
IF(secs < 9.95_SRK) THEN
WRITE(hh_mm_ss,'(a,":",a,":0",f3.1)') str(hrs,3),str(mins,2),secs
ELSE
WRITE(hh_mm_ss,'(a,":",a,":",f4.1)') str(hrs,3),str(mins,2),secs
ENDIF
ELSEIF(hrs > 0_SIK .OR. force_hours) THEN
IF(secs < 9.995_SRK) THEN
WRITE(hh_mm_ss,'(a,":",a,":0",f4.2)') str(hrs,2),str(mins,2),secs
ELSE
......@@ -911,9 +934,18 @@ ENDFUNCTION getTimeReal_Parent
!-------------------------------------------------------------------------------
!> @brief Function returns the value of @ref Times::TimerType::elapsedtime
!> "%elapsedtime" as a string in HHMMSS format.
!> @param this input argument, a @ref Times::TimerType "TimerType" variable
!> @returns hh_mm_ss, the elapsed time as a string (hhh:mm:ss or mmm:ss.ss)
FUNCTION getTimeHHMMSS_Parent(this,tsec,force_hour) RESULT(hh_mm_ss)
!> @param this input argument, a @ref Times::ParentTimerType "ParentTimerType" variable
!> @param tsec the time to format; optional, defaults to @c this%elapsedtime
!> @param force_hour logical to force writing hours even if @c tsec is less than 1 hour
!> @returns hh_mm_ss, the elapsed time as a string
!>
!> For times under 1 hour, the string will be formatted MM:SS.dd if @c force_hour is
!> false, or HH:MM:SS.dd if it is true. For times greater than or equal to one hour
!> but less than 100 hours, the time will be formatted HH:MM:SS.dd. For times greater
!> than or equal to 100 hours, the time will be formatted HHH:MM:SS.d. Times of
!> 1000 hours and greater are not supported.
!>
IMPURE ELEMENTAL FUNCTION getTimeHHMMSS_Parent(this,tsec,force_hour) RESULT(hh_mm_ss)
CLASS(ParentTimerType),INTENT(IN) :: this
REAL(SRK),INTENT(IN),OPTIONAL :: tsec
LOGICAL(SBK),INTENT(IN),OPTIONAL :: force_hour
......
......@@ -120,6 +120,24 @@ SUBROUTINE testTimers()
ASSERT_EQ(testTimer%getTimeHHMMSS(),'27:46:40.60','%getTimeHHMMSS() (hr)')
testTimer%elapsedtime=3719.6_SRK
ASSERT_EQ(testTimer%getTimeHHMMSS(),'01:01:59.60','%getTimeHHMMSS() (round)')
testTimer%elapsedtime=33179.995099046479
ASSERT_EQ(testTimer%getTimeHHMMSS(),'09:13:00.00','%getTimeHHMMSS() (round)')
testTimer%elapsedtime=360000.0_SRK
ASSERT_EQ(testTimer%getTimeHHMMSS(),'100:00:00.0','%getTimeHHMMSS() (long)')
testTimer%elapsedtime=360000.94_SRK
ASSERT_EQ(testTimer%getTimeHHMMSS(),'100:00:00.9','%getTimeHHMMSS() (long)')
testTimer%elapsedtime=360000.96_SRK
ASSERT_EQ(testTimer%getTimeHHMMSS(),'100:00:01.0','%getTimeHHMMSS() (long)')
testTimer%elapsedtime=360009.4_SRK
ASSERT_EQ(testTimer%getTimeHHMMSS(),'100:00:09.4','%getTimeHHMMSS() (long)')
testTimer%elapsedtime=360009.94_SRK
ASSERT_EQ(testTimer%getTimeHHMMSS(),'100:00:09.9','%getTimeHHMMSS() (long)')
testTimer%elapsedtime=360009.96_SRK
ASSERT_EQ(testTimer%getTimeHHMMSS(),'100:00:10.0','%getTimeHHMMSS() (long)')
testTimer%elapsedtime=360069.96_SRK
ASSERT_EQ(testTimer%getTimeHHMMSS(),'100:01:10.0','%getTimeHHMMSS() (long)')
testTimer%elapsedtime=363669.96_SRK
ASSERT_EQ(testTimer%getTimeHHMMSS(),'101:01:10.0','%getTimeHHMMSS() (long)')
CALL testTimer%ResetTimer()
ASSERT_EQ(LEN_TRIM(testTimer%getTimername()),0,'name')
ASSERT_EQ(testTimer%elapsedtime,0._SRK,'elapsedtime')
......@@ -142,6 +160,15 @@ SUBROUTINE testTimers()
ASSERT_LT(totalElapsed,60.0_SRK,'tic/toc too slow')
ASSERT(testTimer%getTimerHiResMode(),'%getTimerHiResMode()')
!Issue occurred after 09:12:22.91 for Bob, so start at 09:12:22.25
!Jordan also hit issue after 09:19:03.63
testTimer%elapsedtime=33142.25_SRK
DO idum1=1,40000000
WRITE(900,*) idum1,testTimer%elapsedtime
WRITE(900,*) testTimer%getTimeHHMMSS(FORCE_HOUR=.TRUE.)
testTimer%elapsedtime=testTimer%elapsedtime+0.0001_SRK
ENDDO !i
COMPONENT_TEST('LO-RES TIMER')
CALL testTimer%setTimerHiResMode(.FALSE.)
ASSERT(.NOT.testTimer%getTimerHiResMode(),'%getTimerHiResMode()')
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment