reset_t_end_r1 Subroutine

  1. rksuite_90.f90
  2. rksuite_90
  3. reset_t_end_r1

private subroutine reset_t_end_r1(comm, t_end_new)

Arguments

Type IntentOptional AttributesName
type(rk_comm_real_1d), intent(inout) :: comm
real(kind=wp), intent(in) :: t_end_new

Calls

proc~~reset_t_end_r1~~CallsGraph proc~reset_t_end_r1 reset_t_end_r1 proc~rkmsg_r1 rkmsg_r1 proc~reset_t_end_r1->proc~rkmsg_r1 proc~get_saved_state_r1 get_saved_state_r1 proc~reset_t_end_r1->proc~get_saved_state_r1 proc~get_stop_on_fatal_r1 get_stop_on_fatal_r1 proc~rkmsg_r1->proc~get_stop_on_fatal_r1 proc~set_saved_state_r1 set_saved_state_r1 proc~rkmsg_r1->proc~set_saved_state_r1

Called by

proc~~reset_t_end_r1~~CalledByGraph proc~reset_t_end_r1 reset_t_end_r1 interface~reset_t_end reset_t_end interface~reset_t_end->proc~reset_t_end_r1 proc~range_integrate_r1 range_integrate_r1 proc~range_integrate_r1->interface~reset_t_end interface~range_integrate range_integrate interface~range_integrate->proc~range_integrate_r1 proc~upstream_calculate upstream_calculate proc~upstream_calculate->interface~range_integrate

Contents

Source Code

reset_t_end_r1

Source Code

subroutine reset_t_end_r1(comm,t_end_new)
!
! 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
!
real(kind=wp), intent(in) :: t_end_new                               !indep!
type(rk_comm_real_1d), intent(inout) :: comm
!
character(len=*), parameter :: srname="RESET_T_END"
!
real(kind=wp) :: hmin, tdiff                                         !indep!
integer ::           ier, nrec, state
!
integer, parameter :: not_ready=-1, usable=-2, fatal=911, catastrophe=912, &
   just_fine=1
logical, parameter :: ask=.true.
real(kind=wp), parameter :: zero=0.0_wp
!
ier = just_fine; nrec = 0
!
!  Is it permissible to call RESET_T_END?
!
body: do
!
   state = get_saved_state_r1("STEP_INTEGRATE",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 (comm%use_range) then
      if (get_saved_state_r1("RANGE_INTEGRATE",comm%save_states)/=usable) then
         ier = fatal; nrec = 2; write (comm%rec,"(a/a)") &
" ** You have called RESET_T_END after you specified to SETUP that you were",&
" ** going to use RANGE_INTEGRATE. This is not permitted."
         exit body
      end if
   end if
   if (state==not_ready) then
      ier = fatal; nrec = 1; write (comm%rec,"(a)") &
" ** You have not called STEP_INTEGRATE, so you cannot use RESET_T_END."
      exit body
   end if
   if (state==5 .or. state==6) then
      ier = fatal; nrec = 2; write (comm%rec,"(a,i1,a/a)") &
" ** STEP_INTEGRATE has returned with FLAG =  ",STATE," You cannot call",&
" ** RESET_T_END inthis circumstance."
      exit body
   end if
!
!  Check value of T_END_NEW
!
   if (comm%dir>zero .and. t_end_new<=comm%t) then
      ier = fatal; nrec = 3; write (comm%rec,"(a/a,e13.5/a,e13.5,a)") &
" ** Integration is proceeding in the positive direction. The current value",&
" ** for the independent variable is ",comm%T," and you have set T_END_NEW =",&
" ** ",T_END_NEW,".  T_END_NEW must be greater than T."
      exit body
   else if (comm%dir<zero .and. t_end_new>=comm%t) then
      ier = fatal; nrec = 3; write (comm%rec,"(a/a,e13.5/a,e13.5,a)") &
" ** Integration is proceeding in the negative direction. The current value",&
" ** for the independent variable is ",comm%T," and you have set T_END_NEW =",&
" ** ",T_END_NEW,".  T_END_NEW must be less than T."
      exit body
   else
      hmin = max(comm%sqtiny,comm%toosml*max(abs(comm%t),abs(t_end_new)))
      tdiff = abs(t_end_new-comm%t)
      if (tdiff<hmin) then
         ier = fatal; nrec = 4 
         write (comm%rec,"(a,e13.5,a/a,e13.5,a/a/a,e13.5,a)")&
" ** The current value of the independent variable T is ",comm%T,". The",&
" ** T_END_NEW you supplied has ABS(T_END_NEW-T) = ",TDIFF,". For the METHOD",&
" ** and the precision of the computer being used, this difference must be",&
" ** at least ",HMIN,"."
         exit body
      end if
   end if
!
   comm%t_end = t_end_new; comm%at_t_end = .false.
!
   exit body
end do body
!
call rkmsg_r1(ier,srname,nrec,comm)
!
end subroutine reset_t_end_r1