diprep Subroutine

subroutine diprep(Neq, Y, Rwork, Ia, Ja, Ipflag, f, jac)

This routine serves as an interface between the driver and Subroutine DPREP. It is called only if MITER is 1 or 2. Tasks performed here are:

  • call DPREP,
  • reset the required WM segment length LENWK,
  • move YH back to its final location (following WM in RWORK),
  • reset pointers for YH, SAVF, EWT, and ACOR, and
  • move EWT to its new position if ISTATE = 1.

IPFLAG is an output error indication flag. IPFLAG = 0 if there was no trouble, and IPFLAG is the value of the DPREP error flag IPPER if there was trouble in Subroutine DPREP.

Arguments

Type IntentOptional Attributes Name
integer :: Neq(*)
real(kind=dp) :: Y(*)
real(kind=dp), intent(inout) :: Rwork(*)
integer :: Ia(*)
integer :: Ja(*)
integer, intent(inout) :: Ipflag
real :: f
integer :: jac

Calls

proc~~diprep~~CallsGraph proc~diprep diprep.inc::diprep dprep dprep proc~diprep->dprep

Variables

Type Visibility Attributes Name Initial
integer, public :: i
integer, public :: imax
integer, public :: lewtn
integer, public :: lyhd
integer, public :: lyhn

Source Code

subroutine diprep(Neq,Y,Rwork,Ia,Ja,Ipflag,f,jac)

integer                     :: Neq(*)
real(kind=dp)               :: Y(*)
real(kind=dp),intent(inout) :: Rwork(*)
integer                     :: Ia(*)
integer                     :: Ja(*)
integer,intent(inout)       :: Ipflag
external                    :: f
external                    :: jac

integer :: i, imax, lewtn, lyhd, lyhn

!integer :: Iwork2(size(Rwork)*2) !SCRATCH SPACE

   Ipflag = 0
   ! ===============================================
   ! subroutine dprep (neq, y, yh, savf, ewt, ftem, ia, ja, wk, iwk, ipper, f, jac)
   ! integer          :: neq(*)
   ! double precision :: y(*)
   ! double precision :: yh(*)
   ! double precision :: savf(*)
   ! double precision :: ewt(*)
   ! double precision :: ftem(*)
   ! integer          :: ia(*)
   ! integer          :: ja(*)
   ! double precision :: wk(*)
   ! integer          :: iwk(*)
   ! integer          :: ipper
   ! external         :: f
   ! external         :: jac
   ! ===============================================
   !  Call DPREP to do matrix preprocessing operations. --------------------
   call dprep(Neq,Y, &
   & Rwork(dls1%lyh),Rwork(dls1%lsavf),Rwork(dls1%lewt), Rwork(dls1%lacor), &
   & Ia,Ja, &
   & Rwork(dls1%lwm), &
   & Rwork(dls1%lwm), &
   & Ipflag, &
   & f,jac)

   dlss%lenwk = max(dlss%lreq,dlss%lwmin)
   if ( Ipflag<0 ) return
   !  If DPREP was successful, move YH to end of required space for WM. ----
   lyhn = dls1%lwm + dlss%lenwk
   if ( lyhn>dls1%lyh ) return
   lyhd = dls1%lyh - lyhn
   if ( lyhd/=0 ) then
      imax = lyhn - 1 + dlss%lenyhm
      do i = lyhn , imax
         Rwork(i) = Rwork(i+lyhd)
      enddo
      dls1%lyh = lyhn
   endif
   !  Reset pointers for SAVF, EWT, and ACOR. ------------------------------
   dls1%lsavf = dls1%lyh + dlss%lenyh
   lewtn = dls1%lsavf + dls1%n
   dls1%lacor = lewtn + dls1%n
   if ( dlss%istatc/=3 ) then
   !  If ISTATE = 1, move EWT (left) to its new position. ------------------
      if ( lewtn>dls1%lewt ) return
      do i = 1 , dls1%n
         Rwork(i+lewtn-1) = Rwork(i+dls1%lewt-1)
      enddo
   endif
   dls1%lewt = lewtn
end subroutine diprep