global_error_r1 Subroutine

subroutine global_error_r1(comm,rms_error,max_error,t_max_error)
!
! Part of rksuite_90 v1.0 (Aug 1994)
!         software for initial value problems in ODEs
!
! Authors: R.W. Brankin (NAG Ltd., Oxford, England)
!          I. Gladwell  (Math Dept., SMU, Dallas, TX, USA)
!          see main doc for contact details
!
type(rk_comm_real_1d), intent(inout) :: comm
real(kind=wp), optional, intent(out) :: max_error
real(kind=wp), optional, intent(out) :: t_max_error                  !indep!
real(kind=wp), dimension(:), optional, intent(out) :: rms_error      !shp-dep!
!
character(len=*), parameter :: srname="GLOBAL_ERROR"
!
integer :: ier, nrec, state
!
intrinsic         sqrt
!
integer, parameter :: not_ready=-1, not_reusable=-3, fatal=911, &
   catastrophe=912, just_fine=1
logical, parameter :: ask=.true.
!
ier = just_fine; nrec = 0
!
body: do 
!
!  Is it permissible to call GLOBAL_ERROR?
!
   state = get_saved_state_r1(srname,comm%save_states)
   if (state==fatal) then
      ier = catastrophe; nrec = 1; write (comm%rec,"(a)") &
" ** A catastrophic error has already been detected elsewhere."
      exit body
   end if
   if (state==not_reusable) then
      ier = fatal; nrec = 2; write (comm%rec,"(a/a)") &
" ** You have already made a call to GLOBAL_ERROR after a hard failure was", &
" ** reported from the integrator. You cannot call GLOBAL_ERROR again."
      exit body
   end if
   state = get_saved_state_r1("STEP_INTEGRATE",comm%save_states)
   if (state==not_ready) then
      ier = fatal; nrec = 1
      if (comm%use_range) then
         write (comm%rec,"(a)") &
" ** You have not yet called RANGE_INTEGRATE, so you cannot call GLOBAL_ERROR."
      else
         write (comm%rec,"(a)") &
" ** You have not yet called STEP_INTEGRATE, so you cannot call GLOBAL_ERROR."
      end if
      exit body
   end if
!
!  Set flag so that the routine can only be called once after a hard 
!  failure from the integrator.
!
   if (state==5 .or. state==6) ier = not_reusable
!
!  Check that ERROR_ASSESS was set properly for error assessment in SETUP.
!
   if (.not.comm%erason) then
      ier = fatal; nrec = 3; write (comm%rec,"(a/a/a)") &
" ** No error assessment is available since you did not ask for it in your",&
" ** call to the routine SETUP. Check your program carefully."
      exit body
   end if
!
! Check size of RMS_ERROR
!
   if (present(rms_error)) then
      if (any(shape(rms_error) /= shape(comm%y))) then
         ier = fatal; nrec = 2; write (comm%rec,"(a,a)") &
" ** The shape of RMS_ERROR is not consistent with the shape of the", &
" ** dependent variables."
         exit body
      end if
   end if
!
!  Check to see if the integrator has not actually taken a step.
!
   if (comm%step_count==0) then
      ier = fatal; nrec = 2; write (comm%rec,"(a/a)") &
" ** The integrator has not actually taken any successful steps. You cannot",&
" ** call GLOBAL_ERROR in this circumstance. Check your program carefully."
       exit body
   end if
!
!  Compute RMS error and set output variables.
!
   if (present(max_error)) max_error = comm%ge_max_contrib
   if (present(t_max_error)) t_max_error = comm%t_ge_max_contrib
   if (present(rms_error)) rms_error = &
      sqrt(comm%ge_assess/real(comm%step_count,kind=wp))
!
   exit body
end do body
!
call rkmsg_r1(ier,srname,nrec,comm)
!
end subroutine global_error_r1