@@ -87,38 +87,66 @@ pure subroutine assert(assertion, description)
8787
8888 end subroutine
8989
90- pure subroutine assert_always (assertion , description )
90+ pure subroutine assert_always (assertion , description , file , line )
9191 ! ! Same as above but always enforces the assertion (regardless of ASSERTIONS)
9292 implicit none
9393 logical , intent (in ) :: assertion
9494 character (len=* ), intent (in ) :: description
95+ character (len=* ), intent (in ), optional :: file
96+ integer , intent (in ), optional :: line
9597 character (len= :), allocatable :: message
98+ character (len= :), allocatable :: location
9699 integer me
97100
98101 check_assertion: &
99102 if (.not. assertion) then
103+ ! Avoid harmless warnings from Cray Fortran:
104+ allocate (character (len= 0 ):: message)
105+ allocate (character (len= 0 ):: location)
106+
107+ ! format source location, if known
108+ location = ' '
109+ if (present (file)) then
110+ location = ' at ' // file // ' :'
111+ if (present (line)) then ! only print line number if file is also known
112+ block
113+ character (len= 128 ) line_str
114+ write (line_str, ' (i0)' ) line
115+ location = location // trim (adjustl (line_str))
116+ end block
117+ else
118+ location = location // ' <unknown>'
119+ endif
120+ endif
100121
101122#if ASSERT_MULTI_IMAGE
102123# if ASSERT_PARALLEL_CALLBACKS
103- me = assert_this_image()
124+ if (associated (assert_this_image)) then
125+ me = assert_this_image()
126+ else
127+ me = 0
128+ endif
104129# else
105130 me = this_image()
106131# endif
107132 block
108133 character (len= 128 ) image_number
109134 write (image_number, * ) me
110- message = ' Assertion failure on image ' // trim (adjustl (image_number)) // ' : ' // description
135+ message = ' Assertion failure on image ' // trim (adjustl (image_number)) // location // ' : ' // description
111136 end block
112137#else
113- message = ' Assertion failure: ' // description
138+ message = ' Assertion failure' // location // ' : ' // description
114139 me = 0 ! avoid a harmless warning
115140#endif
116141
117142#if ASSERT_PARALLEL_CALLBACKS
118- call assert_error_stop(message)
119- #else
120- error stop message, QUIET= .false.
143+ if (associated (assert_this_image)) then
144+ call assert_error_stop(message)
145+ else
146+ ; ! deliberate fall-thru
147+ endif
121148#endif
149+ error stop message, QUIET= .false.
122150
123151 end if check_assertion
124152
0 commit comments