Merge branch 'hotfix_times' into 'master'

Hotfix times and gather

See merge request futility/Futility!356

src/ParallelEnv.f90

@@ -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

src/Times.f90

@@ -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

unit_tests/testTimes/testTimes.f90

@@ -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()')