/// <param name="N">
/// DIMENSION OF THE SYSTEM
///</param>
/// <param name="FCN">
/// NAME (EXTERNAL) OF SUBROUTINE COMPUTING THE
/// VALUE OF F(X,Y):
/// SUBROUTINE FCN(N,X,Y,F,RPAR,IPAR)
/// DOUBLE PRECISION X,Y(N),F(N)
/// F(1)=... ETC.
/// RPAR, IPAR (SEE BELOW)
///</param>
/// <param name="X">
/// INITIAL X-VALUE
///</param>
/// <param name="XEND">
/// FINAL X-VALUE (XEND-X MAY BE POSITIVE OR NEGATIVE)
///</param>
/// <param name="H">
/// INITIAL STEP SIZE GUESS;
/// FOR STIFF EQUATIONS WITH INITIAL TRANSIENT,
/// H=1.D0/(NORM OF F'), USUALLY 1.D-3 OR 1.D-5, IS GOOD.
/// THIS CHOICE IS NOT VERY IMPORTANT, THE STEP SIZE IS
/// QUICKLY ADAPTED. (IF H=0.D0, THE CODE PUTS H=1.D-6).
///</param>
/// <param name="ITOL">
/// SWITCH FOR RTOL AND ATOL:
/// ITOL=0: BOTH RTOL AND ATOL ARE SCALARS.
/// THE CODE KEEPS, ROUGHLY, THE LOCAL ERROR OF
/// Y(I) BELOW RTOL*ABS(Y(I))+ATOL
/// ITOL=1: BOTH RTOL AND ATOL ARE VECTORS.
/// THE CODE KEEPS THE LOCAL ERROR OF Y(I) BELOW
/// RTOL(I)*ABS(Y(I))+ATOL(I).
///</param>
/// <param name="JAC">
/// NAME (EXTERNAL) OF THE SUBROUTINE WHICH COMPUTES
/// THE PARTIAL DERIVATIVES OF F(X,Y) WITH RESPECT TO Y
/// (THIS ROUTINE IS ONLY CALLED IF IJAC=1; SUPPLY
/// A DUMMY SUBROUTINE IN THE CASE IJAC=0).
/// FOR IJAC=1, THIS SUBROUTINE MUST HAVE THE FORM
/// SUBROUTINE JAC(N,X,Y,DFY,LDFY,RPAR,IPAR)
/// DOUBLE PRECISION X,Y(N),DFY(LDFY,N)
/// DFY(1,1)= ...
/// LDFY, THE COLUMN-LENGTH OF THE ARRAY, IS
/// FURNISHED BY THE CALLING PROGRAM.
/// IF (MLJAC.EQ.N) THE JACOBIAN IS SUPPOSED TO
/// BE FULL AND THE PARTIAL DERIVATIVES ARE
/// STORED IN DFY AS
/// DFY(I,J) = PARTIAL F(I) / PARTIAL Y(J)
/// ELSE, THE JACOBIAN IS TAKEN AS BANDED AND
/// THE PARTIAL DERIVATIVES ARE STORED
/// DIAGONAL-WISE AS
/// DFY(I-J+MUJAC+1,J) = PARTIAL F(I) / PARTIAL Y(J).
///</param>
/// <param name="IJAC">
/// SWITCH FOR THE COMPUTATION OF THE JACOBIAN:
/// IJAC=0: JACOBIAN IS COMPUTED INTERNALLY BY FINITE
/// DIFFERENCES, SUBROUTINE "JAC" IS NEVER CALLED.
/// IJAC=1: JACOBIAN IS SUPPLIED BY SUBROUTINE JAC.
///</param>
/// <param name="MLJAC">
/// SWITCH FOR THE BANDED STRUCTURE OF THE JACOBIAN:
/// MLJAC=N: JACOBIAN IS A FULL MATRIX. THE LINEAR
/// ALGEBRA IS DONE BY FULL-MATRIX GAUSS-ELIMINATION.
/// 0.LE.MLJAC.LT.N: MLJAC IS THE LOWER BANDWITH OF JACOBIAN
/// MATRIX (.GE. NUMBER OF NON-ZERO DIAGONALS BELOW
/// THE MAIN DIAGONAL).
///</param>
/// <param name="MUJAC">
/// UPPER BANDWITH OF JACOBIAN MATRIX (.GE. NUMBER OF NON-
/// ZERO DIAGONALS ABOVE THE MAIN DIAGONAL).
/// NEED NOT BE DEFINED IF MLJAC=N.
///</param>
/// <param name="MAS">
/// NAME (EXTERNAL) OF SUBROUTINE COMPUTING THE MASS-
/// MATRIX M.
/// IF IMAS=0, THIS MATRIX IS ASSUMED TO BE THE IDENTITY
/// MATRIX AND NEEDS NOT TO BE DEFINED;
/// SUPPLY A DUMMY SUBROUTINE IN THIS CASE.
/// IF IMAS=1, THE SUBROUTINE MAS IS OF THE FORM
/// SUBROUTINE MAS(N,AM,LMAS,RPAR,IPAR)
/// DOUBLE PRECISION AM(LMAS,N)
/// AM(1,1)= ....
/// IF (MLMAS.EQ.N) THE MASS-MATRIX IS STORED
/// AS FULL MATRIX LIKE
/// AM(I,J) = M(I,J)
/// ELSE, THE MATRIX IS TAKEN AS BANDED AND STORED
/// DIAGONAL-WISE AS
/// AM(I-J+MUMAS+1,J) = M(I,J).
///</param>
/// <param name="IMAS">
/// GIVES INFORMATION ON THE MASS-MATRIX:
/// IMAS=0: M IS SUPPOSED TO BE THE IDENTITY
/// MATRIX, MAS IS NEVER CALLED.
/// IMAS=1: MASS-MATRIX IS SUPPLIED.
///</param>
/// <param name="MLMAS">
/// SWITCH FOR THE BANDED STRUCTURE OF THE MASS-MATRIX:
/// MLMAS=N: THE FULL MATRIX CASE. THE LINEAR
/// ALGEBRA IS DONE BY FULL-MATRIX GAUSS-ELIMINATION.
/// 0.LE.MLMAS.LT.N: MLMAS IS THE LOWER BANDWITH OF THE
/// MATRIX (.GE. NUMBER OF NON-ZERO DIAGONALS BELOW
/// THE MAIN DIAGONAL).
/// MLMAS IS SUPPOSED TO BE .LE. MLJAC.
///</param>
/// <param name="MUMAS">
/// UPPER BANDWITH OF MASS-MATRIX (.GE. NUMBER OF NON-
/// ZERO DIAGONALS ABOVE THE MAIN DIAGONAL).
/// NEED NOT BE DEFINED IF MLMAS=N.
/// MUMAS IS SUPPOSED TO BE .LE. MUJAC.
///</param>
/// <param name="SOLOUT">
/// NAME (EXTERNAL) OF SUBROUTINE PROVIDING THE
/// NUMERICAL SOLUTION DURING INTEGRATION.
/// IF IOUT=1, IT IS CALLED AFTER EVERY SUCCESSFUL STEP.
/// SUPPLY A DUMMY SUBROUTINE IF IOUT=0.
/// IT MUST HAVE THE FORM
/// SUBROUTINE SOLOUT (NR,XOLD,X,Y,CONT,LRC,N,
/// RPAR,IPAR,IRTRN)
/// DOUBLE PRECISION X,Y(N),CONT(LRC)
/// ....
/// SOLOUT FURNISHES THE SOLUTION "Y" AT THE NR-TH
/// GRID-POINT "X" (THEREBY THE INITIAL VALUE IS
/// THE FIRST GRID-POINT).
/// "XOLD" IS THE PRECEEDING GRID-POINT.
/// "IRTRN" SERVES TO INTERRUPT THE INTEGRATION. IF IRTRN
/// IS SET .LT.0, RADAU5 RETURNS TO THE CALLING PROGRAM.
///
/// ----- CONTINUOUS OUTPUT: -----
/// DURING CALLS TO "SOLOUT", A CONTINUOUS SOLUTION
/// FOR THE INTERVAL [XOLD,X] IS AVAILABLE THROUGH
/// THE FUNCTION
/// .GT..GT..GT. CONTR5(I,S,CONT,LRC) .LT..LT..LT.
/// WHICH PROVIDES AN APPROXIMATION TO THE I-TH
/// COMPONENT OF THE SOLUTION AT THE POINT S. THE VALUE
/// S SHOULD LIE IN THE INTERVAL [XOLD,X].
/// DO NOT CHANGE THE ENTRIES OF CONT(LRC), IF THE
/// DENSE OUTPUT FUNCTION IS USED.
///</param>
/// <param name="IOUT">
/// SWITCH FOR CALLING THE SUBROUTINE SOLOUT:
/// IOUT=0: SUBROUTINE IS NEVER CALLED
/// IOUT=1: SUBROUTINE IS AVAILABLE FOR OUTPUT.
///</param>
/// <param name="WORK">
/// ARRAY OF WORKING SPACE OF LENGTH "LWORK".
/// WORK(1), WORK(2),.., WORK(20) SERVE AS PARAMETERS
/// FOR THE CODE. FOR STANDARD USE OF THE CODE
/// WORK(1),..,WORK(20) MUST BE SET TO ZERO BEFORE
/// CALLING. SEE BELOW FOR A MORE SOPHISTICATED USE.
/// WORK(21),..,WORK(LWORK) SERVE AS WORKING SPACE
/// FOR ALL VECTORS AND MATRICES.
/// "LWORK" MUST BE AT LEAST
/// N*(LJAC+LMAS+3*LE+12)+20
/// WHERE
/// LJAC=N IF MLJAC=N (FULL JACOBIAN)
/// LJAC=MLJAC+MUJAC+1 IF MLJAC.LT.N (BANDED JAC.)
/// AND
/// LMAS=0 IF IMAS=0
/// LMAS=N IF IMAS=1 AND MLMAS=N (FULL)
/// LMAS=MLMAS+MUMAS+1 IF MLMAS.LT.N (BANDED MASS-M.)
/// AND
/// LE=N IF MLJAC=N (FULL JACOBIAN)
/// LE=2*MLJAC+MUJAC+1 IF MLJAC.LT.N (BANDED JAC.)
///
/// IN THE USUAL CASE WHERE THE JACOBIAN IS FULL AND THE
/// MASS-MATRIX IS THE INDENTITY (IMAS=0), THE MINIMUM
/// STORAGE REQUIREMENT IS
/// LWORK = 4*N*N+12*N+20.
/// IF IWORK(9)=M1.GT.0 THEN "LWORK" MUST BE AT LEAST
/// N*(LJAC+12)+(N-M1)*(LMAS+3*LE)+20
/// WHERE IN THE DEFINITIONS OF LJAC, LMAS AND LE THE
/// NUMBER N CAN BE REPLACED BY N-M1.
///</param>
/// <param name="LWORK">
/// DECLARED LENGTH OF ARRAY "WORK".
///</param>
/// <param name="IWORK">
/// INTEGER WORKING SPACE OF LENGTH "LIWORK".
/// IWORK(1),IWORK(2),...,IWORK(20) SERVE AS PARAMETERS
/// FOR THE CODE. FOR STANDARD USE, SET IWORK(1),..,
/// IWORK(20) TO ZERO BEFORE CALLING.
/// IWORK(21),...,IWORK(LIWORK) SERVE AS WORKING AREA.
/// "LIWORK" MUST BE AT LEAST 3*N+20.
///</param>
/// <param name="LIWORK">
/// DECLARED LENGTH OF ARRAY "IWORK".
///</param>
/// <param name="IDID">
/// REPORTS ON SUCCESSFULNESS UPON RETURN:
/// IDID= 1 COMPUTATION SUCCESSFUL,
/// IDID= 2 COMPUT. SUCCESSFUL (INTERRUPTED BY SOLOUT)
/// IDID=-1 INPUT IS NOT CONSISTENT,
/// IDID=-2 LARGER NMAX IS NEEDED,
/// IDID=-3 STEP SIZE BECOMES TOO SMALL,
/// IDID=-4 MATRIX IS REPEATEDLY SINGULAR.
///</param>
public void Run(int N, IFVPOL FCN, ref double X, ref double[] Y, int offset_y, double XEND, ref double H
, ref double[] RTOL, int offset_rtol, ref double[] ATOL, int offset_atol, int ITOL, IJVPOL JAC, int IJAC, ref int MLJAC
, ref int MUJAC, IBBAMPL MAS, int IMAS, int MLMAS, ref int MUMAS, ISOLOUTR SOLOUT
, int IOUT, ref double[] WORK, int offset_work, int LWORK, ref int[] IWORK, int offset_iwork, int LIWORK, double[] RPAR, int offset_rpar
, int[] IPAR, int offset_ipar, ref int IDID)
{
#region Variables
bool IMPLCT = false; bool JBAND = false; bool ARRET = false; bool STARTN = false; bool PRED = false;
#endregion Variables
#region Implicit Variables
int NFCN = 0; int NJAC = 0; int NSTEP = 0; int NACCPT = 0; int NREJCT = 0; int NDEC = 0; int NSOL = 0;
double UROUND = 0; double EXPM = 0; double QUOT = 0; int I = 0; int NMAX = 0; int NIT = 0; int NIND1 = 0;
int NIND2 = 0; int NIND3 = 0; int M1 = 0; int M2 = 0; int NM1 = 0; double SAFE = 0; double THET = 0; double TOLST = 0;
double FNEWT = 0; double QUOT1 = 0; double QUOT2 = 0; double HMAX = 0; double FACL = 0; double FACR = 0; int LDJAC = 0;
int LDE1 = 0; int LDMAS = 0; int IJOB = 0; int LDMAS2 = 0; int IEZ1 = 0; int IEZ2 = 0; int IEZ3 = 0; int IEY0 = 0;
int IESCAL = 0; int IEF1 = 0; int IEF2 = 0; int IEF3 = 0; int IECON = 0; int IEJAC = 0; int IEMAS = 0; int IEE1 = 0;
int IEE2R = 0; int IEE2I = 0; int ISTORE = 0; int IEIP1 = 0; int IEIP2 = 0; int IEIPH = 0;
#endregion Implicit Variables
#region Array Index Correction
int o_y = -1 + offset_y; int o_rtol = -1 + offset_rtol; int o_atol = -1 + offset_atol;
int o_work = -1 + offset_work; int o_iwork = -1 + offset_iwork; int o_rpar = -1 + offset_rpar;
int o_ipar = -1 + offset_ipar;
#endregion Array Index Correction
#region Prolog
// C ----------------------------------------------------------
// C NUMERICAL SOLUTION OF A STIFF (OR DIFFERENTIAL ALGEBRAIC)
// C SYSTEM OF FIRST 0RDER ORDINARY DIFFERENTIAL EQUATIONS
// C M*Y'=F(X,Y).
// C THE SYSTEM CAN BE (LINEARLY) IMPLICIT (MASS-MATRIX M .NE. I)
// C OR EXPLICIT (M=I).
// C THE METHOD USED IS AN IMPLICIT RUNGE-KUTTA METHOD (RADAU IIA)
// C OF ORDER 5 WITH STEP SIZE CONTROL AND CONTINUOUS OUTPUT.
// C CF. SECTION IV.8
// C
// C AUTHORS: E. HAIRER AND G. WANNER
// C UNIVERSITE DE GENEVE, DEPT. DE MATHEMATIQUES
// C CH-1211 GENEVE 24, SWITZERLAND
// C E-MAIL: [email protected]
// C [email protected]
// C
// C THIS CODE IS PART OF THE BOOK:
// C E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL
// C EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS.
// C SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS 14,
// C SPRINGER-VERLAG 1991, SECOND EDITION 1996.
// C
// C VERSION OF JULY 9, 1996
// C (latest small correction: January 18, 2002)
// C
// C INPUT PARAMETERS
// C ----------------
// C N DIMENSION OF THE SYSTEM
// C
// C FCN NAME (EXTERNAL) OF SUBROUTINE COMPUTING THE
// C VALUE OF F(X,Y):
// C SUBROUTINE FCN(N,X,Y,F,RPAR,IPAR)
// C DOUBLE PRECISION X,Y(N),F(N)
// C F(1)=... ETC.
// C RPAR, IPAR (SEE BELOW)
// C
// C X INITIAL X-VALUE
// C
// C Y(N) INITIAL VALUES FOR Y
// C
// C XEND FINAL X-VALUE (XEND-X MAY BE POSITIVE OR NEGATIVE)
// C
// C H INITIAL STEP SIZE GUESS;
// C FOR STIFF EQUATIONS WITH INITIAL TRANSIENT,
// C H=1.D0/(NORM OF F'), USUALLY 1.D-3 OR 1.D-5, IS GOOD.
// C THIS CHOICE IS NOT VERY IMPORTANT, THE STEP SIZE IS
// C QUICKLY ADAPTED. (IF H=0.D0, THE CODE PUTS H=1.D-6).
// C
// C RTOL,ATOL RELATIVE AND ABSOLUTE ERROR TOLERANCES. THEY
// C CAN BE BOTH SCALARS OR ELSE BOTH VECTORS OF LENGTH N.
// C
// C ITOL SWITCH FOR RTOL AND ATOL:
// C ITOL=0: BOTH RTOL AND ATOL ARE SCALARS.
// C THE CODE KEEPS, ROUGHLY, THE LOCAL ERROR OF
// C Y(I) BELOW RTOL*ABS(Y(I))+ATOL
// C ITOL=1: BOTH RTOL AND ATOL ARE VECTORS.
// C THE CODE KEEPS THE LOCAL ERROR OF Y(I) BELOW
// C RTOL(I)*ABS(Y(I))+ATOL(I).
// C
// C JAC NAME (EXTERNAL) OF THE SUBROUTINE WHICH COMPUTES
// C THE PARTIAL DERIVATIVES OF F(X,Y) WITH RESPECT TO Y
// C (THIS ROUTINE IS ONLY CALLED IF IJAC=1; SUPPLY
// C A DUMMY SUBROUTINE IN THE CASE IJAC=0).
// C FOR IJAC=1, THIS SUBROUTINE MUST HAVE THE FORM
// C SUBROUTINE JAC(N,X,Y,DFY,LDFY,RPAR,IPAR)
// C DOUBLE PRECISION X,Y(N),DFY(LDFY,N)
// C DFY(1,1)= ...
// C LDFY, THE COLUMN-LENGTH OF THE ARRAY, IS
// C FURNISHED BY THE CALLING PROGRAM.
// C IF (MLJAC.EQ.N) THE JACOBIAN IS SUPPOSED TO
// C BE FULL AND THE PARTIAL DERIVATIVES ARE
// C STORED IN DFY AS
// C DFY(I,J) = PARTIAL F(I) / PARTIAL Y(J)
// C ELSE, THE JACOBIAN IS TAKEN AS BANDED AND
// C THE PARTIAL DERIVATIVES ARE STORED
// C DIAGONAL-WISE AS
// C DFY(I-J+MUJAC+1,J) = PARTIAL F(I) / PARTIAL Y(J).
// C
// C IJAC SWITCH FOR THE COMPUTATION OF THE JACOBIAN:
// C IJAC=0: JACOBIAN IS COMPUTED INTERNALLY BY FINITE
// C DIFFERENCES, SUBROUTINE "JAC" IS NEVER CALLED.
// C IJAC=1: JACOBIAN IS SUPPLIED BY SUBROUTINE JAC.
// C
// C MLJAC SWITCH FOR THE BANDED STRUCTURE OF THE JACOBIAN:
// C MLJAC=N: JACOBIAN IS A FULL MATRIX. THE LINEAR
// C ALGEBRA IS DONE BY FULL-MATRIX GAUSS-ELIMINATION.
// C 0<=MLJAC<N: MLJAC IS THE LOWER BANDWITH OF JACOBIAN
// C MATRIX (>= NUMBER OF NON-ZERO DIAGONALS BELOW
// C THE MAIN DIAGONAL).
// C
// C MUJAC UPPER BANDWITH OF JACOBIAN MATRIX (>= NUMBER OF NON-
// C ZERO DIAGONALS ABOVE THE MAIN DIAGONAL).
// C NEED NOT BE DEFINED IF MLJAC=N.
// C
// C ---- MAS,IMAS,MLMAS, AND MUMAS HAVE ANALOG MEANINGS -----
// C ---- FOR THE "MASS MATRIX" (THE MATRIX "M" OF SECTION IV.8): -
// C
// C MAS NAME (EXTERNAL) OF SUBROUTINE COMPUTING THE MASS-
// C MATRIX M.
// C IF IMAS=0, THIS MATRIX IS ASSUMED TO BE THE IDENTITY
// C MATRIX AND NEEDS NOT TO BE DEFINED;
// C SUPPLY A DUMMY SUBROUTINE IN THIS CASE.
// C IF IMAS=1, THE SUBROUTINE MAS IS OF THE FORM
// C SUBROUTINE MAS(N,AM,LMAS,RPAR,IPAR)
// C DOUBLE PRECISION AM(LMAS,N)
// C AM(1,1)= ....
// C IF (MLMAS.EQ.N) THE MASS-MATRIX IS STORED
// C AS FULL MATRIX LIKE
// C AM(I,J) = M(I,J)
// C ELSE, THE MATRIX IS TAKEN AS BANDED AND STORED
// C DIAGONAL-WISE AS
// C AM(I-J+MUMAS+1,J) = M(I,J).
// C
// C IMAS GIVES INFORMATION ON THE MASS-MATRIX:
// C IMAS=0: M IS SUPPOSED TO BE THE IDENTITY
// C MATRIX, MAS IS NEVER CALLED.
// C IMAS=1: MASS-MATRIX IS SUPPLIED.
// C
// C MLMAS SWITCH FOR THE BANDED STRUCTURE OF THE MASS-MATRIX:
// C MLMAS=N: THE FULL MATRIX CASE. THE LINEAR
// C ALGEBRA IS DONE BY FULL-MATRIX GAUSS-ELIMINATION.
// C 0<=MLMAS<N: MLMAS IS THE LOWER BANDWITH OF THE
// C MATRIX (>= NUMBER OF NON-ZERO DIAGONALS BELOW
// C THE MAIN DIAGONAL).
// C MLMAS IS SUPPOSED TO BE .LE. MLJAC.
// C
// C MUMAS UPPER BANDWITH OF MASS-MATRIX (>= NUMBER OF NON-
// C ZERO DIAGONALS ABOVE THE MAIN DIAGONAL).
// C NEED NOT BE DEFINED IF MLMAS=N.
// C MUMAS IS SUPPOSED TO BE .LE. MUJAC.
// C
// C SOLOUT NAME (EXTERNAL) OF SUBROUTINE PROVIDING THE
// C NUMERICAL SOLUTION DURING INTEGRATION.
// C IF IOUT=1, IT IS CALLED AFTER EVERY SUCCESSFUL STEP.
// C SUPPLY A DUMMY SUBROUTINE IF IOUT=0.
// C IT MUST HAVE THE FORM
// C SUBROUTINE SOLOUT (NR,XOLD,X,Y,CONT,LRC,N,
// C RPAR,IPAR,IRTRN)
// C DOUBLE PRECISION X,Y(N),CONT(LRC)
// C ....
// C SOLOUT FURNISHES THE SOLUTION "Y" AT THE NR-TH
// C GRID-POINT "X" (THEREBY THE INITIAL VALUE IS
// C THE FIRST GRID-POINT).
// C "XOLD" IS THE PRECEEDING GRID-POINT.
// C "IRTRN" SERVES TO INTERRUPT THE INTEGRATION. IF IRTRN
// C IS SET <0, RADAU5 RETURNS TO THE CALLING PROGRAM.
// C
// C ----- CONTINUOUS OUTPUT: -----
// C DURING CALLS TO "SOLOUT", A CONTINUOUS SOLUTION
// C FOR THE INTERVAL [XOLD,X] IS AVAILABLE THROUGH
// C THE FUNCTION
// C >>> CONTR5(I,S,CONT,LRC) <<<
// C WHICH PROVIDES AN APPROXIMATION TO THE I-TH
// C COMPONENT OF THE SOLUTION AT THE POINT S. THE VALUE
// C S SHOULD LIE IN THE INTERVAL [XOLD,X].
// C DO NOT CHANGE THE ENTRIES OF CONT(LRC), IF THE
// C DENSE OUTPUT FUNCTION IS USED.
// C
// C IOUT SWITCH FOR CALLING THE SUBROUTINE SOLOUT:
// C IOUT=0: SUBROUTINE IS NEVER CALLED
// C IOUT=1: SUBROUTINE IS AVAILABLE FOR OUTPUT.
// C
// C WORK ARRAY OF WORKING SPACE OF LENGTH "LWORK".
// C WORK(1), WORK(2),.., WORK(20) SERVE AS PARAMETERS
// C FOR THE CODE. FOR STANDARD USE OF THE CODE
// C WORK(1),..,WORK(20) MUST BE SET TO ZERO BEFORE
// C CALLING. SEE BELOW FOR A MORE SOPHISTICATED USE.
// C WORK(21),..,WORK(LWORK) SERVE AS WORKING SPACE
// C FOR ALL VECTORS AND MATRICES.
// C "LWORK" MUST BE AT LEAST
// C N*(LJAC+LMAS+3*LE+12)+20
// C WHERE
// C LJAC=N IF MLJAC=N (FULL JACOBIAN)
// C LJAC=MLJAC+MUJAC+1 IF MLJAC<N (BANDED JAC.)
// C AND
// C LMAS=0 IF IMAS=0
// C LMAS=N IF IMAS=1 AND MLMAS=N (FULL)
// C LMAS=MLMAS+MUMAS+1 IF MLMAS<N (BANDED MASS-M.)
// C AND
// C LE=N IF MLJAC=N (FULL JACOBIAN)
// C LE=2*MLJAC+MUJAC+1 IF MLJAC<N (BANDED JAC.)
// C
// C IN THE USUAL CASE WHERE THE JACOBIAN IS FULL AND THE
// C MASS-MATRIX IS THE INDENTITY (IMAS=0), THE MINIMUM
// C STORAGE REQUIREMENT IS
// C LWORK = 4*N*N+12*N+20.
// C IF IWORK(9)=M1>0 THEN "LWORK" MUST BE AT LEAST
// C N*(LJAC+12)+(N-M1)*(LMAS+3*LE)+20
// C WHERE IN THE DEFINITIONS OF LJAC, LMAS AND LE THE
// C NUMBER N CAN BE REPLACED BY N-M1.
// C
// C LWORK DECLARED LENGTH OF ARRAY "WORK".
// C
// C IWORK INTEGER WORKING SPACE OF LENGTH "LIWORK".
// C IWORK(1),IWORK(2),...,IWORK(20) SERVE AS PARAMETERS
// C FOR THE CODE. FOR STANDARD USE, SET IWORK(1),..,
// C IWORK(20) TO ZERO BEFORE CALLING.
// C IWORK(21),...,IWORK(LIWORK) SERVE AS WORKING AREA.
// C "LIWORK" MUST BE AT LEAST 3*N+20.
// C
// C LIWORK DECLARED LENGTH OF ARRAY "IWORK".
// C
// C RPAR, IPAR REAL AND INTEGER PARAMETERS (OR PARAMETER ARRAYS) WHICH
// C CAN BE USED FOR COMMUNICATION BETWEEN YOUR CALLING
// C PROGRAM AND THE FCN, JAC, MAS, SOLOUT SUBROUTINES.
// C
// C ----------------------------------------------------------------------
// C
// C SOPHISTICATED SETTING OF PARAMETERS
// C -----------------------------------
// C SEVERAL PARAMETERS OF THE CODE ARE TUNED TO MAKE IT WORK
// C WELL. THEY MAY BE DEFINED BY SETTING WORK(1),...
// C AS WELL AS IWORK(1),... DIFFERENT FROM ZERO.
// C FOR ZERO INPUT, THE CODE CHOOSES DEFAULT VALUES:
// C
// C IWORK(1) IF IWORK(1).NE.0, THE CODE TRANSFORMS THE JACOBIAN
// C MATRIX TO HESSENBERG FORM. THIS IS PARTICULARLY
// C ADVANTAGEOUS FOR LARGE SYSTEMS WITH FULL JACOBIAN.
// C IT DOES NOT WORK FOR BANDED JACOBIAN (MLJAC<N)
// C AND NOT FOR IMPLICIT SYSTEMS (IMAS=1).
// C
// C IWORK(2) THIS IS THE MAXIMAL NUMBER OF ALLOWED STEPS.
// C THE DEFAULT VALUE (FOR IWORK(2)=0) IS 100000.
// C
// C IWORK(3) THE MAXIMUM NUMBER OF NEWTON ITERATIONS FOR THE
// C SOLUTION OF THE IMPLICIT SYSTEM IN EACH STEP.
// C THE DEFAULT VALUE (FOR IWORK(3)=0) IS 7.
// C
// C IWORK(4) IF IWORK(4).EQ.0 THE EXTRAPOLATED COLLOCATION SOLUTION
// C IS TAKEN AS STARTING VALUE FOR NEWTON'S METHOD.
// C IF IWORK(4).NE.0 ZERO STARTING VALUES ARE USED.
// C THE LATTER IS RECOMMENDED IF NEWTON'S METHOD HAS
// C DIFFICULTIES WITH CONVERGENCE (THIS IS THE CASE WHEN
// C NSTEP IS LARGER THAN NACCPT + NREJCT; SEE OUTPUT PARAM.).
// C DEFAULT IS IWORK(4)=0.
// C
// C THE FOLLOWING 3 PARAMETERS ARE IMPORTANT FOR
// C DIFFERENTIAL-ALGEBRAIC SYSTEMS OF INDEX > 1.
// C THE FUNCTION-SUBROUTINE SHOULD BE WRITTEN SUCH THAT
// C THE INDEX 1,2,3 VARIABLES APPEAR IN THIS ORDER.
// C IN ESTIMATING THE ERROR THE INDEX 2 VARIABLES ARE
// C MULTIPLIED BY H, THE INDEX 3 VARIABLES BY H**2.
// C
// C IWORK(5) DIMENSION OF THE INDEX 1 VARIABLES (MUST BE > 0). FOR
// C ODE'S THIS EQUALS THE DIMENSION OF THE SYSTEM.
// C DEFAULT IWORK(5)=N.
// C
// C IWORK(6) DIMENSION OF THE INDEX 2 VARIABLES. DEFAULT IWORK(6)=0.
// C
// C IWORK(7) DIMENSION OF THE INDEX 3 VARIABLES. DEFAULT IWORK(7)=0.
// C
// C IWORK(8) SWITCH FOR STEP SIZE STRATEGY
// C IF IWORK(8).EQ.1 MOD. PREDICTIVE CONTROLLER (GUSTAFSSON)
// C IF IWORK(8).EQ.2 CLASSICAL STEP SIZE CONTROL
// C THE DEFAULT VALUE (FOR IWORK(8)=0) IS IWORK(8)=1.
// C THE CHOICE IWORK(8).EQ.1 SEEMS TO PRODUCE SAFER RESULTS;
// C FOR SIMPLE PROBLEMS, THE CHOICE IWORK(8).EQ.2 PRODUCES
// C OFTEN SLIGHTLY FASTER RUNS
// C
// C IF THE DIFFERENTIAL SYSTEM HAS THE SPECIAL STRUCTURE THAT
// C Y(I)' = Y(I+M2) FOR I=1,...,M1,
// C WITH M1 A MULTIPLE OF M2, A SUBSTANTIAL GAIN IN COMPUTERTIME
// C CAN BE ACHIEVED BY SETTING THE PARAMETERS IWORK(9) AND IWORK(10).
// C E.G., FOR SECOND ORDER SYSTEMS P'=V, V'=G(P,V), WHERE P AND V ARE
// C VECTORS OF DIMENSION N/2, ONE HAS TO PUT M1=M2=N/2.
// C FOR M1>0 SOME OF THE INPUT PARAMETERS HAVE DIFFERENT MEANINGS:
// C - JAC: ONLY THE ELEMENTS OF THE NON-TRIVIAL PART OF THE
// C JACOBIAN HAVE TO BE STORED
// C IF (MLJAC.EQ.N-M1) THE JACOBIAN IS SUPPOSED TO BE FULL
// C DFY(I,J) = PARTIAL F(I+M1) / PARTIAL Y(J)
// C FOR I=1,N-M1 AND J=1,N.
// C ELSE, THE JACOBIAN IS BANDED ( M1 = M2 * MM )
// C DFY(I-J+MUJAC+1,J+K*M2) = PARTIAL F(I+M1) / PARTIAL Y(J+K*M2)
// C FOR I=1,MLJAC+MUJAC+1 AND J=1,M2 AND K=0,MM.
// C - MLJAC: MLJAC=N-M1: IF THE NON-TRIVIAL PART OF THE JACOBIAN IS FULL
// C 0<=MLJAC<N-M1: IF THE (MM+1) SUBMATRICES (FOR K=0,MM)
// C PARTIAL F(I+M1) / PARTIAL Y(J+K*M2), I,J=1,M2
// C ARE BANDED, MLJAC IS THE MAXIMAL LOWER BANDWIDTH
// C OF THESE MM+1 SUBMATRICES
// C - MUJAC: MAXIMAL UPPER BANDWIDTH OF THESE MM+1 SUBMATRICES
// C NEED NOT BE DEFINED IF MLJAC=N-M1
// C - MAS: IF IMAS=0 THIS MATRIX IS ASSUMED TO BE THE IDENTITY AND
// C NEED NOT BE DEFINED. SUPPLY A DUMMY SUBROUTINE IN THIS CASE.
// C IT IS ASSUMED THAT ONLY THE ELEMENTS OF RIGHT LOWER BLOCK OF
// C DIMENSION N-M1 DIFFER FROM THAT OF THE IDENTITY MATRIX.
// C IF (MLMAS.EQ.N-M1) THIS SUBMATRIX IS SUPPOSED TO BE FULL
// C AM(I,J) = M(I+M1,J+M1) FOR I=1,N-M1 AND J=1,N-M1.
// C ELSE, THE MASS MATRIX IS BANDED
// C AM(I-J+MUMAS+1,J) = M(I+M1,J+M1)
// C - MLMAS: MLMAS=N-M1: IF THE NON-TRIVIAL PART OF M IS FULL
// C 0<=MLMAS<N-M1: LOWER BANDWIDTH OF THE MASS MATRIX
// C - MUMAS: UPPER BANDWIDTH OF THE MASS MATRIX
// C NEED NOT BE DEFINED IF MLMAS=N-M1
// C
// C IWORK(9) THE VALUE OF M1. DEFAULT M1=0.
// C
// C IWORK(10) THE VALUE OF M2. DEFAULT M2=M1.
// C
// C ----------
// C
// C WORK(1) UROUND, THE ROUNDING UNIT, DEFAULT 1.D-16.
// C
// C WORK(2) THE SAFETY FACTOR IN STEP SIZE PREDICTION,
// C DEFAULT 0.9D0.
// C
// C WORK(3) DECIDES WHETHER THE JACOBIAN SHOULD BE RECOMPUTED;
// C INCREASE WORK(3), TO 0.1 SAY, WHEN JACOBIAN EVALUATIONS
// C ARE COSTLY. FOR SMALL SYSTEMS WORK(3) SHOULD BE SMALLER
// C (0.001D0, SAY). NEGATIV WORK(3) FORCES THE CODE TO
// C COMPUTE THE JACOBIAN AFTER EVERY ACCEPTED STEP.
// C DEFAULT 0.001D0.
// C
// C WORK(4) STOPPING CRITERION FOR NEWTON'S METHOD, USUALLY CHOSEN <1.
// C SMALLER VALUES OF WORK(4) MAKE THE CODE SLOWER, BUT SAFER.
// C DEFAULT MIN(0.03D0,RTOL(1)**0.5D0)
// C
// C WORK(5) AND WORK(6) : IF WORK(5) < HNEW/HOLD < WORK(6), THEN THE
// C STEP SIZE IS NOT CHANGED. THIS SAVES, TOGETHER WITH A
// C LARGE WORK(3), LU-DECOMPOSITIONS AND COMPUTING TIME FOR
// C LARGE SYSTEMS. FOR SMALL SYSTEMS ONE MAY HAVE
// C WORK(5)=1.D0, WORK(6)=1.2D0, FOR LARGE FULL SYSTEMS
// C WORK(5)=0.99D0, WORK(6)=2.D0 MIGHT BE GOOD.
// C DEFAULTS WORK(5)=1.D0, WORK(6)=1.2D0 .
// C
// C WORK(7) MAXIMAL STEP SIZE, DEFAULT XEND-X.
// C
// C WORK(8), WORK(9) PARAMETERS FOR STEP SIZE SELECTION
// C THE NEW STEP SIZE IS CHOSEN SUBJECT TO THE RESTRICTION
// C WORK(8) <= HNEW/HOLD <= WORK(9)
// C DEFAULT VALUES: WORK(8)=0.2D0, WORK(9)=8.D0
// C
// C-----------------------------------------------------------------------
// C
// C OUTPUT PARAMETERS
// C -----------------
// C X X-VALUE FOR WHICH THE SOLUTION HAS BEEN COMPUTED
// C (AFTER SUCCESSFUL RETURN X=XEND).
// C
// C Y(N) NUMERICAL SOLUTION AT X
// C
// C H PREDICTED STEP SIZE OF THE LAST ACCEPTED STEP
// C
// C IDID REPORTS ON SUCCESSFULNESS UPON RETURN:
// C IDID= 1 COMPUTATION SUCCESSFUL,
// C IDID= 2 COMPUT. SUCCESSFUL (INTERRUPTED BY SOLOUT)
// C IDID=-1 INPUT IS NOT CONSISTENT,
// C IDID=-2 LARGER NMAX IS NEEDED,
// C IDID=-3 STEP SIZE BECOMES TOO SMALL,
// C IDID=-4 MATRIX IS REPEATEDLY SINGULAR.
// C
// C IWORK(14) NFCN NUMBER OF FUNCTION EVALUATIONS (THOSE FOR NUMERICAL
// C EVALUATION OF THE JACOBIAN ARE NOT COUNTED)
// C IWORK(15) NJAC NUMBER OF JACOBIAN EVALUATIONS (EITHER ANALYTICALLY
// C OR NUMERICALLY)
// C IWORK(16) NSTEP NUMBER OF COMPUTED STEPS
// C IWORK(17) NACCPT NUMBER OF ACCEPTED STEPS
// C IWORK(18) NREJCT NUMBER OF REJECTED STEPS (DUE TO ERROR TEST),
// C (STEP REJECTIONS IN THE FIRST STEP ARE NOT COUNTED)
// C IWORK(19) NDEC NUMBER OF LU-DECOMPOSITIONS OF BOTH MATRICES
// C IWORK(20) NSOL NUMBER OF FORWARD-BACKWARD SUBSTITUTIONS, OF BOTH
// C SYSTEMS; THE NSTEP FORWARD-BACKWARD SUBSTITUTIONS,
// C NEEDED FOR STEP SIZE SELECTION, ARE NOT COUNTED
// C-----------------------------------------------------------------------
// C *** *** *** *** *** *** *** *** *** *** *** *** ***
// C DECLARATIONS
// C *** *** *** *** *** *** *** *** *** *** *** *** ***
// C *** *** *** *** *** *** ***
// C SETTING THE PARAMETERS
// C *** *** *** *** *** *** ***
#endregion Prolog
#region Body
NFCN = 0;
NJAC = 0;
NSTEP = 0;
NACCPT = 0;
NREJCT = 0;
NDEC = 0;
NSOL = 0;
ARRET = false;
// C -------- UROUND SMALLEST NUMBER SATISFYING 1.0D0+UROUND>1.0D0
if (WORK[1 + o_work] == 0.0E0)
{
UROUND = 1.0E-16;
}
else
{
UROUND = WORK[1 + o_work];
if (UROUND <= 1.0E-19 || UROUND >= 1.0E0)
{
//ERROR-ERROR WRITE(6,*)' COEFFICIENTS HAVE 20 DIGITS, UROUND=',WORK(1);
ARRET = true;
}
}
// C -------- CHECK AND CHANGE THE TOLERANCES
EXPM = 2.0E0 / 3.0E0;
if (ITOL == 0)
{
if (ATOL[1 + o_atol] <= 0.0E0 || RTOL[1 + o_rtol] <= 10.0E0 * UROUND)
{
//ERROR-ERROR WRITE (6,*) ' TOLERANCES ARE TOO SMALL';
ARRET = true;
}
else
{
QUOT = ATOL[1 + o_atol] / RTOL[1 + o_rtol];
RTOL[1 + o_rtol] = 0.1E0 * Math.Pow(RTOL[1 + o_rtol], EXPM);
ATOL[1 + o_atol] = RTOL[1 + o_rtol] * QUOT;
}
}
else
{
for (I = 1; I <= N; I++)
{
if (ATOL[I + o_atol] <= 0.0E0 || RTOL[I + o_rtol] <= 10.0E0 * UROUND)
{
//ERROR-ERROR WRITE (6,*) ' TOLERANCES(',I,') ARE TOO SMALL';
ARRET = true;
}
else
{
QUOT = ATOL[I + o_atol] / RTOL[I + o_rtol];
RTOL[I + o_rtol] = 0.1E0 * Math.Pow(RTOL[I + o_rtol], EXPM);
ATOL[I + o_atol] = RTOL[I + o_rtol] * QUOT;
}
}
}
// C -------- NMAX , THE MAXIMAL NUMBER OF STEPS -----
if (IWORK[2 + o_iwork] == 0)
{
NMAX = 100000;
}
else
{
NMAX = IWORK[2 + o_iwork];
if (NMAX <= 0)
{
//ERROR-ERROR WRITE(6,*)' WRONG INPUT IWORK(2)=',IWORK(2);
ARRET = true;
}
}
// C -------- NIT MAXIMAL NUMBER OF NEWTON ITERATIONS
if (IWORK[3 + o_iwork] == 0)
{
NIT = 7;
}
else
{
NIT = IWORK[3 + o_iwork];
if (NIT <= 0)
{
//ERROR-ERROR WRITE(6,*)' CURIOUS INPUT IWORK(3)=',IWORK(3);
ARRET = true;
}
}
// C -------- STARTN SWITCH FOR STARTING VALUES OF NEWTON ITERATIONS
if (IWORK[4 + o_iwork] == 0)
{
STARTN = false;
}
else
{
STARTN = true;
}
// C -------- PARAMETER FOR DIFFERENTIAL-ALGEBRAIC COMPONENTS
NIND1 = IWORK[5 + o_iwork];
NIND2 = IWORK[6 + o_iwork];
NIND3 = IWORK[7 + o_iwork];
if (NIND1 == 0) NIND1 = N;
if (NIND1 + NIND2 + NIND3 != N)
{
//ERROR-ERROR WRITE(6,*)' CURIOUS INPUT FOR IWORK(5,6,7)=',NIND1,NIND2,NIND3;
ARRET = true;
}
// C -------- PRED STEP SIZE CONTROL
if (IWORK[8 + o_iwork] <= 1)
{
PRED = true;
}
else
{
PRED = false;
}
// C -------- PARAMETER FOR SECOND ORDER EQUATIONS
M1 = IWORK[9 + o_iwork];
M2 = IWORK[10 + o_iwork];
NM1 = N - M1;
if (M1 == 0) M2 = N;
if (M2 == 0) M2 = M1;
if (M1 < 0 || M2 < 0 || M1 + M2 > N)
{
//ERROR-ERROR WRITE(6,*)' CURIOUS INPUT FOR IWORK(9,10)=',M1,M2;
ARRET = true;
}
// C --------- SAFE SAFETY FACTOR IN STEP SIZE PREDICTION
if (WORK[2 + o_work] == 0.0E0)
{
SAFE = 0.9E0;
}
else
{
SAFE = WORK[2 + o_work];
if (SAFE <= 0.001E0 || SAFE >= 1.0E0)
{
//ERROR-ERROR WRITE(6,*)' CURIOUS INPUT FOR WORK(2)=',WORK(2);
ARRET = true;
}
}
// C ------ THET DECIDES WHETHER THE JACOBIAN SHOULD BE RECOMPUTED;
if (WORK[3 + o_work] == 0.0E0)
{
THET = 0.001E0;
}
else
{
THET = WORK[3 + o_work];
if (THET >= 1.0E0)
{
//ERROR-ERROR WRITE(6,*)' CURIOUS INPUT FOR WORK(3)=',WORK(3);
ARRET = true;
}
}
// C --- FNEWT STOPPING CRITERION FOR NEWTON'S METHOD, USUALLY CHOSEN <1.
TOLST = RTOL[1 + o_rtol];
if (WORK[4 + o_work] == 0.0E0)
{
FNEWT = Math.Max(10 * UROUND / TOLST, Math.Min(0.03E0, Math.Pow(TOLST, 0.5E0)));
}
else
{
FNEWT = WORK[4 + o_work];
if (FNEWT <= UROUND / TOLST)
{
//ERROR-ERROR WRITE(6,*)' CURIOUS INPUT FOR WORK(4)=',WORK(4);
ARRET = true;
}
}
// C --- QUOT1 AND QUOT2: IF QUOT1 < HNEW/HOLD < QUOT2, STEP SIZE = CONST.
if (WORK[5 + o_work] == 0.0E0)
{
QUOT1 = 1.0E0;
}
else
{
QUOT1 = WORK[5 + o_work];
}
if (WORK[6 + o_work] == 0.0E0)
{
QUOT2 = 1.2E0;
}
else
{
QUOT2 = WORK[6 + o_work];
}
if (QUOT1 > 1.0E0 || QUOT2 < 1.0E0)
{
//ERROR-ERROR WRITE(6,*)' CURIOUS INPUT FOR WORK(5,6)=',QUOT1,QUOT2;
ARRET = true;
}
// C -------- MAXIMAL STEP SIZE
if (WORK[7 + o_work] == 0.0E0)
{
HMAX = XEND - X;
}
else
{
HMAX = WORK[7 + o_work];
}
// C ------- FACL,FACR PARAMETERS FOR STEP SIZE SELECTION
if (WORK[8 + o_work] == 0.0E0)
{
FACL = 5.0E0;
}
else
{
FACL = 1.0E0 / WORK[8 + o_work];
}
if (WORK[9 + o_work] == 0.0E0)
{
FACR = 1.0E0 / 8.0E0;
}
else
{
FACR = 1.0E0 / WORK[9 + o_work];
}
if (FACL < 1.0E0 || FACR > 1.0E0)
{
//ERROR-ERROR WRITE(6,*)' CURIOUS INPUT WORK(8,9)=',WORK(8),WORK(9);
ARRET = true;
}
// C *** *** *** *** *** *** *** *** *** *** *** *** ***
// C COMPUTATION OF ARRAY ENTRIES
// C *** *** *** *** *** *** *** *** *** *** *** *** ***
// C ---- IMPLICIT, BANDED OR NOT ?
IMPLCT = IMAS != 0;
JBAND = MLJAC < NM1;
// C -------- COMPUTATION OF THE ROW-DIMENSIONS OF THE 2-ARRAYS ---
// C -- JACOBIAN AND MATRICES E1, E2
if (JBAND)
{
LDJAC = MLJAC + MUJAC + 1;
LDE1 = MLJAC + LDJAC;
}
else
{
MLJAC = NM1;
MUJAC = NM1;
LDJAC = NM1;
LDE1 = NM1;
}
// C -- MASS MATRIX
if (IMPLCT)
{
if (MLMAS != NM1)
{
LDMAS = MLMAS + MUMAS + 1;
if (JBAND)
{
IJOB = 4;
}
else
{
IJOB = 3;
}
}
else
{
MUMAS = NM1;
LDMAS = NM1;
IJOB = 5;
}
// C ------ BANDWITH OF "MAS" NOT SMALLER THAN BANDWITH OF "JAC"
if (MLMAS > MLJAC || MUMAS > MUJAC)
{
//ERROR-ERROR WRITE (6,*) 'BANDWITH OF "MAS" NOT SMALLER THAN BANDWITH OF"JAC"';
ARRET = true;
}
}
else
{
LDMAS = 0;
if (JBAND)
{
IJOB = 2;
}
else
{
IJOB = 1;
if (N > 2 && IWORK[1 + o_iwork] != 0) IJOB = 7;
}
}
LDMAS2 = Math.Max(1, LDMAS);
// C ------ HESSENBERG OPTION ONLY FOR EXPLICIT EQU. WITH FULL JACOBIAN
if ((IMPLCT || JBAND) && IJOB == 7)
{
//ERROR-ERROR WRITE(6,*)' HESSENBERG OPTION ONLY FOR EXPLICIT EQUATIONS WITH FULL JACOBIAN';
ARRET = true;
}
// C ------- PREPARE THE ENTRY-POINTS FOR THE ARRAYS IN WORK -----
IEZ1 = 21;
IEZ2 = IEZ1 + N;
IEZ3 = IEZ2 + N;
IEY0 = IEZ3 + N;
IESCAL = IEY0 + N;
IEF1 = IESCAL + N;
IEF2 = IEF1 + N;
IEF3 = IEF2 + N;
IECON = IEF3 + N;
IEJAC = IECON + 4 * N;
IEMAS = IEJAC + N * LDJAC;
IEE1 = IEMAS + NM1 * LDMAS;
IEE2R = IEE1 + NM1 * LDE1;
IEE2I = IEE2R + NM1 * LDE1;
// C ------ TOTAL STORAGE REQUIREMENT -----------
ISTORE = IEE2I + NM1 * LDE1 - 1;
if (ISTORE > LWORK)
{
//ERROR-ERROR WRITE(6,*)' INSUFFICIENT STORAGE FOR WORK, MIN. LWORK=',ISTORE;
ARRET = true;
}
// C ------- ENTRY POINTS FOR INTEGER WORKSPACE -----
IEIP1 = 21;
IEIP2 = IEIP1 + NM1;
IEIPH = IEIP2 + NM1;
// C --------- TOTAL REQUIREMENT ---------------
ISTORE = IEIPH + NM1 - 1;
if (ISTORE > LIWORK)
{
//ERROR-ERROR WRITE(6,*)' INSUFF. STORAGE FOR IWORK, MIN. LIWORK=',ISTORE;
ARRET = true;
}
// C ------ WHEN A FAIL HAS OCCURED, WE RETURN WITH IDID=-1
if (ARRET)
{
IDID = -1;
return;
}
// C -------- CALL TO CORE INTEGRATOR ------------
this._radcor.Run(N, FCN, ref X, ref Y, offset_y, XEND, HMAX
, ref H, RTOL, offset_rtol, ATOL, offset_atol, ITOL, JAC, IJAC
, MLJAC, MUJAC, MAS, MLMAS, MUMAS, SOLOUT
, IOUT, ref IDID, NMAX, UROUND, SAFE, THET
, FNEWT, QUOT1, QUOT2, NIT, ref IJOB, STARTN
, NIND1, NIND2, NIND3, PRED, FACL, FACR
, M1, M2, NM1, IMPLCT, JBAND, LDJAC
, LDE1, LDMAS2, ref WORK, IEZ1 + o_work, ref WORK, IEZ2 + o_work, ref WORK, IEZ3 + o_work, ref WORK, IEY0 + o_work
, ref WORK, IESCAL + o_work, ref WORK, IEF1 + o_work, ref WORK, IEF2 + o_work, ref WORK, IEF3 + o_work, ref WORK, IEJAC + o_work, ref WORK, IEE1 + o_work
, ref WORK, IEE2R + o_work, ref WORK, IEE2I + o_work, ref WORK, IEMAS + o_work, ref IWORK, IEIP1 + o_iwork, ref IWORK, IEIP2 + o_iwork, ref IWORK, IEIPH + o_iwork
, ref WORK, IECON + o_work, ref NFCN, ref NJAC, ref NSTEP, ref NACCPT, ref NREJCT
, ref NDEC, ref NSOL, RPAR, offset_rpar, IPAR, offset_ipar);
IWORK[14 + o_iwork] = NFCN;
IWORK[15 + o_iwork] = NJAC;
IWORK[16 + o_iwork] = NSTEP;
IWORK[17 + o_iwork] = NACCPT;
IWORK[18 + o_iwork] = NREJCT;
IWORK[19 + o_iwork] = NDEC;
IWORK[20 + o_iwork] = NSOL;
// C -------- RESTORE TOLERANCES
EXPM = 1.0E0 / EXPM;
if (ITOL == 0)
{
QUOT = ATOL[1 + o_atol] / RTOL[1 + o_rtol];
RTOL[1 + o_rtol] = Math.Pow(10.0E0 * RTOL[1 + o_rtol], EXPM);
ATOL[1 + o_atol] = RTOL[1 + o_rtol] * QUOT;
}
else
{
for (I = 1; I <= N; I++)
{
QUOT = ATOL[I + o_atol] / RTOL[I + o_rtol];
RTOL[I + o_rtol] = Math.Pow(10.0E0 * RTOL[I + o_rtol], EXPM);
ATOL[I + o_atol] = RTOL[I + o_rtol] * QUOT;
}
}
// C ----------- RETURN -----------
return;
#endregion Body
}
public void Run(int N, IFVPOL FCN, ref double X, ref double[] Y, int offset_y, double XEND, double HMAX
, ref double H, double[] RTOL, int offset_rtol, double[] ATOL, int offset_atol, int ITOL, IJVPOL JAC, int IJAC
, int MLJAC, int MUJAC, IBBAMPL MAS, int MLMAS, int MUMAS, ISOLOUTR SOLOUT
, int IOUT, ref int IDID, int NMAX, double UROUND, double SAFE, double THET
, double FNEWT, double QUOT1, double QUOT2, int NIT, ref int IJOB, bool STARTN
, int NIND1, int NIND2, int NIND3, bool PRED, double FACL, double FACR
, int M1, int M2, int NM1, bool IMPLCT, bool BANDED, int LDJAC
, int LDE1, int LDMAS, ref double[] Z1, int offset_z1, ref double[] Z2, int offset_z2, ref double[] Z3, int offset_z3, ref double[] Y0, int offset_y0
, ref double[] SCAL, int offset_scal, ref double[] F1, int offset_f1, ref double[] F2, int offset_f2, ref double[] F3, int offset_f3, ref double[] FJAC, int offset_fjac, ref double[] E1, int offset_e1
, ref double[] E2R, int offset_e2r, ref double[] E2I, int offset_e2i, ref double[] FMAS, int offset_fmas, ref int[] IP1, int offset_ip1, ref int[] IP2, int offset_ip2, ref int[] IPHES, int offset_iphes
, ref double[] CONT, int offset_cont, ref int NFCN, ref int NJAC, ref int NSTEP, ref int NACCPT, ref int NREJCT
, ref int NDEC, ref int NSOL, double[] RPAR, int offset_rpar, int[] IPAR, int offset_ipar)
{
#region Variables
bool REJECT = false; bool FIRST = false; bool CALJAC = false; bool CALHES = false; bool INDEX1 = false;
bool INDEX2 = false; bool INDEX3 = false; bool LAST = false;
#endregion Variables
#region Implicit Variables
int LRC = 0; double SQ6 = 0; double C1 = 0; double C2 = 0; double C1MC2 = 0; double DD1 = 0; double DD2 = 0;
double DD3 = 0; double U1 = 0; double ALPH = 0; double BETA = 0; double CNO = 0; double T11 = 0; double T12 = 0;
double T13 = 0; double T21 = 0; double T22 = 0; double T23 = 0; double T31 = 0; double TI11 = 0; double TI12 = 0;
double TI13 = 0; double TI21 = 0; double TI22 = 0; double TI23 = 0; double TI31 = 0; double TI32 = 0; double TI33 = 0;
double POSNEG = 0; double HMAXN = 0; double HOLD = 0; double HOPT = 0; double FACCON = 0; double CFAC = 0;
int NSING = 0; double XOLD = 0; int IRTRN = 0; int NRSOL = 0; double XOSOL = 0; int I = 0; int NSOLU = 0; int N2 = 0;
int N3 = 0; double HHFAC = 0; int MUJACP = 0; int MD = 0; int J = 0; int K = 0; int MM = 0; int J1 = 0; int LBEG = 0;
int LEND = 0; int MUJACJ = 0; int L = 0; int FJAC_J = 0; double YSAFE = 0; double DELT = 0; int FJAC_I = 0;
double FAC1 = 0; double ALPHN = 0; double BETAN = 0; int IER = 0; double XPH = 0; double C3Q = 0; double C1Q = 0;
double C2Q = 0; double AK1 = 0; double AK2 = 0; double AK3 = 0; double Z1I = 0; double Z2I = 0; double Z3I = 0;
int NEWT = 0; double THETA = 0; double A1 = 0; double A2 = 0; double A3 = 0; double DYNO = 0; double DENOM = 0;
double THQ = 0; double DYNOLD = 0; double THQOLD = 0; double DYTH = 0; double QNEWT = 0; double F1I = 0;
double F2I = 0; double F3I = 0; double FAC = 0; double QUOT = 0; double ERR = 0; double HNEW = 0; double FACGUS = 0;
double HACC = 0; double ERRACC = 0; double AK = 0; double ACONT3 = 0; double QT = 0;
#endregion Implicit Variables
#region Array Index Correction
int o_y = -1 + offset_y; int o_rtol = -1 + offset_rtol; int o_atol = -1 + offset_atol; int o_z1 = -1 + offset_z1;
int o_z2 = -1 + offset_z2; int o_z3 = -1 + offset_z3; int o_y0 = -1 + offset_y0; int o_scal = -1 + offset_scal;
int o_f1 = -1 + offset_f1; int o_f2 = -1 + offset_f2; int o_f3 = -1 + offset_f3;
int o_fjac = -1 - LDJAC + offset_fjac; int o_e1 = -1 - LDE1 + offset_e1; int o_e2r = -1 - LDE1 + offset_e2r;
int o_e2i = -1 - LDE1 + offset_e2i; int o_fmas = -1 - LDMAS + offset_fmas; int o_ip1 = -1 + offset_ip1;
int o_ip2 = -1 + offset_ip2; int o_iphes = -1 + offset_iphes; int o_cont = -1 + offset_cont;
int o_rpar = -1 + offset_rpar; int o_ipar = -1 + offset_ipar;
#endregion Array Index Correction
// C ----------------------------------------------------------
// C CORE INTEGRATOR FOR RADAU5
// C PARAMETERS SAME AS IN RADAU5 WITH WORKSPACE ADDED
// C ----------------------------------------------------------
// C DECLARATIONS
// C ----------------------------------------------------------
// C *** *** *** *** *** *** ***
// C INITIALISATIONS
// C *** *** *** *** *** *** ***
// C --------- DUPLIFY N FOR COMMON BLOCK CONT -----
#region Body
NN.v = N;
NN2.v = 2 * N;
NN3.v = 3 * N;
LRC = 4 * N;
// C -------- CHECK THE INDEX OF THE PROBLEM -----
INDEX1 = NIND1 != 0;
INDEX2 = NIND2 != 0;
INDEX3 = NIND3 != 0;
// C ------- COMPUTE MASS MATRIX FOR IMPLICIT CASE ----------
if (IMPLCT) MAS.Run(NM1, ref FMAS, offset_fmas, LDMAS, RPAR, offset_rpar, IPAR[1 + o_ipar]);
// C ---------- CONSTANTS ---------
SQ6 = Math.Sqrt(6.0E0);
C1 = (4.0E0 - SQ6) / 10.0E0;
C2 = (4.0E0 + SQ6) / 10.0E0;
C1M1.v = C1 - 1.0E0;
C2M1.v = C2 - 1.0E0;
C1MC2 = C1 - C2;
DD1 = -(13.0E0 + 7.0E0 * SQ6) / 3.0E0;
DD2 = (-13.0E0 + 7.0E0 * SQ6) / 3.0E0;
DD3 = -1.0E0 / 3.0E0;
U1 = (6.0E0 + Math.Pow(81.0E0, 1.0E0 / 3.0E0) - Math.Pow(9.0E0, 1.0E0 / 3.0E0)) / 30.0E0;
ALPH = (12.0E0 - Math.Pow(81.0E0, 1.0E0 / 3.0E0) + Math.Pow(9.0E0, 1.0E0 / 3.0E0)) / 60.0E0;
BETA = (Math.Pow(81.0E0, 1.0E0 / 3.0E0) + Math.Pow(9.0E0, 1.0E0 / 3.0E0)) * Math.Sqrt(3.0E0) / 60.0E0;
CNO = Math.Pow(ALPH, 2) + Math.Pow(BETA, 2);
U1 = 1.0E0 / U1;
ALPH /= CNO;
BETA /= CNO;
T11 = 9.1232394870892942792E-02;
T12 = -0.14125529502095420843E0;
T13 = -3.0029194105147424492E-02;
T21 = 0.24171793270710701896E0;
T22 = 0.20412935229379993199E0;
T23 = 0.38294211275726193779E0;
T31 = 0.96604818261509293619E0;
TI11 = 4.3255798900631553510E0;
TI12 = 0.33919925181580986954E0;
TI13 = 0.54177053993587487119E0;
TI21 = -4.1787185915519047273E0;
TI22 = -0.32768282076106238708E0;
TI23 = 0.47662355450055045196E0;
TI31 = -0.50287263494578687595E0;
TI32 = 2.5719269498556054292E0;
TI33 = -0.59603920482822492497E0;
if (M1 > 0) IJOB += 10;
POSNEG = FortranLib.Sign(1.0E0, XEND - X);
HMAXN = Math.Min(Math.Abs(HMAX), Math.Abs(XEND - X));
if (Math.Abs(H) <= 10.0E0 * UROUND) H = 1.0E-6;
H = Math.Min(Math.Abs(H), HMAXN);
H = FortranLib.Sign(H, POSNEG);
HOLD = H;
REJECT = false;
FIRST = true;
LAST = false;
if ((X + H * 1.0001E0 - XEND) * POSNEG >= 0.0E0)
{
H = XEND - X;
LAST = true;
}
HOPT = H;
FACCON = 1.0E0;
CFAC = SAFE * (1 + 2 * NIT);
NSING = 0;
XOLD = X;
if (IOUT != 0)
{
IRTRN = 1;
NRSOL = 1;
XOSOL = XOLD;
XSOL.v = X;
for (I = 1; I <= N; I++)
{
CONT[I + o_cont] = Y[I + o_y];
}
NSOLU = N;
HSOL.v = HOLD;
SOLOUT.Run(NRSOL, XOSOL, XSOL.v, Y, offset_y, CONT, offset_cont, LRC
, NSOLU, RPAR[1 + o_rpar], IPAR[1 + o_ipar], IRTRN);
if (IRTRN < 0) goto LABEL179;
}
MLE.v = MLJAC;
MUE.v = MUJAC;
MBJAC.v = MLJAC + MUJAC + 1;
MBB.v = MLMAS + MUMAS + 1;
MDIAG.v = MLE.v + MUE.v + 1;
MDIFF.v = MLE.v + MUE.v - MUMAS;
MBDIAG.v = MUMAS + 1;
N2 = 2 * N;
N3 = 3 * N;
if (ITOL == 0)
{
for (I = 1; I <= N; I++)
{
SCAL[I + o_scal] = ATOL[1 + o_atol] + RTOL[1 + o_rtol] * Math.Abs(Y[I + o_y]);
}
}
else
{
for (I = 1; I <= N; I++)
{
SCAL[I + o_scal] = ATOL[I + o_atol] + RTOL[I + o_rtol] * Math.Abs(Y[I + o_y]);
}
}
HHFAC = H;
FCN.Run(N, X, Y, offset_y, ref Y0, offset_y0, RPAR[1 + o_rpar], IPAR[1 + o_ipar]);
NFCN += 1;
// C --- BASIC INTEGRATION STEP
LABEL10:;
// C *** *** *** *** *** *** ***
// C COMPUTATION OF THE JACOBIAN
// C *** *** *** *** *** *** ***
NJAC += 1;
if (IJAC == 0)
{
// C --- COMPUTE JACOBIAN MATRIX NUMERICALLY
if (BANDED)
{
// C --- JACOBIAN IS BANDED
MUJACP = MUJAC + 1;
MD = Math.Min(MBJAC.v, M2);
for (MM = 1; MM <= M1 / M2 + 1; MM++)
{
for (K = 1; K <= MD; K++)
{
J = K + (MM - 1) * M2;
LABEL12: F1[J + o_f1] = Y[J + o_y];
F2[J + o_f2] = Math.Sqrt(UROUND * Math.Max(1.0E-5, Math.Abs(Y[J + o_y])));
Y[J + o_y] += F2[J + o_f2];
J += MD;
if (J <= MM * M2) goto LABEL12;
FCN.Run(N, X, Y, offset_y, ref CONT, offset_cont, RPAR[1 + o_rpar], IPAR[1 + o_ipar]);
J = K + (MM - 1) * M2;
J1 = K;
LBEG = Math.Max(1, J1 - MUJAC) + M1;
LABEL14: LEND = Math.Min(M2, J1 + MLJAC) + M1;
Y[J + o_y] = F1[J + o_f1];
MUJACJ = MUJACP - J1 - M1;
FJAC_J = J * LDJAC + o_fjac;
for (L = LBEG; L <= LEND; L++)
{
FJAC[L + MUJACJ + FJAC_J] = (CONT[L + o_cont] - Y0[L + o_y0]) / F2[J + o_f2];
}
J += MD;
J1 += MD;
LBEG = LEND + 1;
if (J <= MM * M2) goto LABEL14;
}
}
}
else
{
// C --- JACOBIAN IS FULL
for (I = 1; I <= N; I++)
{
YSAFE = Y[I + o_y];
DELT = Math.Sqrt(UROUND * Math.Max(1.0E-5, Math.Abs(YSAFE)));
Y[I + o_y] = YSAFE + DELT;
FCN.Run(N, X, Y, offset_y, ref CONT, offset_cont, RPAR[1 + o_rpar], IPAR[1 + o_ipar]);
FJAC_I = I * LDJAC + o_fjac;
for (J = M1 + 1; J <= N; J++)
{
FJAC[J - M1 + FJAC_I] = (CONT[J + o_cont] - Y0[J + o_y0]) / DELT;
}
Y[I + o_y] = YSAFE;
}
}
}
else
{
// C --- COMPUTE JACOBIAN MATRIX ANALYTICALLY
JAC.Run(N, X, Y, offset_y, ref FJAC, offset_fjac, LDJAC, RPAR[1 + o_rpar]
, IPAR[1 + o_ipar]);
}
CALJAC = true;
CALHES = true;
LABEL20:;
// C --- COMPUTE THE MATRICES E1 AND E2 AND THEIR DECOMPOSITIONS
FAC1 = U1 / H;
ALPHN = ALPH / H;
BETAN = BETA / H;
this._decomr.Run(N, ref FJAC, offset_fjac, LDJAC, FMAS, offset_fmas, LDMAS, MLMAS
, MUMAS, M1, M2, NM1, FAC1, ref E1, offset_e1
, LDE1, ref IP1, offset_ip1, ref IER, IJOB, ref CALHES, ref IPHES, offset_iphes);
if (IER != 0) goto LABEL78;
this._decomc.Run(N, FJAC, offset_fjac, LDJAC, FMAS, offset_fmas, LDMAS, MLMAS
, MUMAS, M1, M2, NM1, ALPHN, BETAN
, ref E2R, offset_e2r, ref E2I, offset_e2i, LDE1, ref IP2, offset_ip2, ref IER, IJOB);
if (IER != 0) goto LABEL78;
NDEC += 1;
LABEL30:;
NSTEP += 1;
if (NSTEP > NMAX) goto LABEL178;
if (0.1E0 * Math.Abs(H) <= Math.Abs(X) * UROUND) goto LABEL177;
if (INDEX2)
{
for (I = NIND1 + 1; I <= NIND1 + NIND2; I++)
{
SCAL[I + o_scal] /= HHFAC;
}
}
if (INDEX3)
{
for (I = NIND1 + NIND2 + 1; I <= NIND1 + NIND2 + NIND3; I++)
{
SCAL[I + o_scal] = SCAL[I + o_scal] / (HHFAC * HHFAC);
}
}
XPH = X + H;
// C *** *** *** *** *** *** ***
// C STARTING VALUES FOR NEWTON ITERATION
// C *** *** *** *** *** *** ***
if (FIRST || STARTN)
{
for (I = 1; I <= N; I++)
{
Z1[I + o_z1] = 0.0E0;
Z2[I + o_z2] = 0.0E0;
Z3[I + o_z3] = 0.0E0;
F1[I + o_f1] = 0.0E0;
F2[I + o_f2] = 0.0E0;
F3[I + o_f3] = 0.0E0;
}
}
else
{
C3Q = H / HOLD;
C1Q = C1 * C3Q;
C2Q = C2 * C3Q;
for (I = 1; I <= N; I++)
{
AK1 = CONT[I + N + o_cont];
AK2 = CONT[I + N2 + o_cont];
AK3 = CONT[I + N3 + o_cont];
Z1I = C1Q * (AK1 + (C1Q - C2M1.v) * (AK2 + (C1Q - C1M1.v) * AK3));
Z2I = C2Q * (AK1 + (C2Q - C2M1.v) * (AK2 + (C2Q - C1M1.v) * AK3));
Z3I = C3Q * (AK1 + (C3Q - C2M1.v) * (AK2 + (C3Q - C1M1.v) * AK3));
Z1[I + o_z1] = Z1I;
Z2[I + o_z2] = Z2I;
Z3[I + o_z3] = Z3I;
F1[I + o_f1] = TI11 * Z1I + TI12 * Z2I + TI13 * Z3I;
F2[I + o_f2] = TI21 * Z1I + TI22 * Z2I + TI23 * Z3I;
F3[I + o_f3] = TI31 * Z1I + TI32 * Z2I + TI33 * Z3I;
}
}
// C *** *** *** *** *** *** ***
// C LOOP FOR THE SIMPLIFIED NEWTON ITERATION
// C *** *** *** *** *** *** ***
NEWT = 0;
FACCON = Math.Pow(Math.Max(FACCON, UROUND), 0.8E0);
THETA = Math.Abs(THET);
LABEL40:;
if (NEWT >= NIT) goto LABEL78;
// C --- COMPUTE THE RIGHT-HAND SIDE
for (I = 1; I <= N; I++)
{
CONT[I + o_cont] = Y[I + o_y] + Z1[I + o_z1];
}
FCN.Run(N, X + C1 * H, CONT, offset_cont, ref Z1, offset_z1, RPAR[1 + o_rpar], IPAR[1 + o_ipar]);
for (I = 1; I <= N; I++)
{
CONT[I + o_cont] = Y[I + o_y] + Z2[I + o_z2];
}
FCN.Run(N, X + C2 * H, CONT, offset_cont, ref Z2, offset_z2, RPAR[1 + o_rpar], IPAR[1 + o_ipar]);
for (I = 1; I <= N; I++)
{
CONT[I + o_cont] = Y[I + o_y] + Z3[I + o_z3];
}
FCN.Run(N, XPH, CONT, offset_cont, ref Z3, offset_z3, RPAR[1 + o_rpar], IPAR[1 + o_ipar]);
NFCN += 3;
// C --- SOLVE THE LINEAR SYSTEMS
for (I = 1; I <= N; I++)
{
A1 = Z1[I + o_z1];
A2 = Z2[I + o_z2];
A3 = Z3[I + o_z3];
Z1[I + o_z1] = TI11 * A1 + TI12 * A2 + TI13 * A3;
Z2[I + o_z2] = TI21 * A1 + TI22 * A2 + TI23 * A3;
Z3[I + o_z3] = TI31 * A1 + TI32 * A2 + TI33 * A3;
}
this._slvrad.Run(N, FJAC, offset_fjac, LDJAC, MLJAC, MUJAC, FMAS, offset_fmas
, LDMAS, MLMAS, MUMAS, M1, M2, NM1
, FAC1, ALPHN, BETAN, E1, offset_e1, E2R, offset_e2r, E2I, offset_e2i
, LDE1, ref Z1, offset_z1, ref Z2, offset_z2, ref Z3, offset_z3, F1, offset_f1, F2, offset_f2
, F3, offset_f3, CONT[1 + o_cont], IP1, offset_ip1, IP2, offset_ip2, IPHES, offset_iphes, IER
, IJOB);
NSOL += 1;
NEWT += 1;
DYNO = 0.0E0;
for (I = 1; I <= N; I++)
{
DENOM = SCAL[I + o_scal];
DYNO += Math.Pow(Z1[I + o_z1] / DENOM, 2) + Math.Pow(Z2[I + o_z2] / DENOM, 2) + Math.Pow(Z3[I + o_z3] / DENOM, 2);
}
DYNO = Math.Sqrt(DYNO / N3);
// C --- BAD CONVERGENCE OR NUMBER OF ITERATIONS TO LARGE
if (NEWT > 1 && NEWT < NIT)
{
THQ = DYNO / DYNOLD;
if (NEWT == 2)
{
THETA = THQ;
}
else
{
THETA = Math.Sqrt(THQ * THQOLD);
}
THQOLD = THQ;
if (THETA < 0.99E0)
{
FACCON = THETA / (1.0E0 - THETA);
DYTH = FACCON * DYNO * Math.Pow(THETA, NIT - 1 - NEWT) / FNEWT;
if (DYTH >= 1.0E0)
{
QNEWT = Math.Max(1.0E-4, Math.Min(20.0E0, DYTH));
HHFAC = .8E0 * Math.Pow(QNEWT, -1.0E0 / (4.0E0 + NIT - 1 - NEWT));
H *= HHFAC;
REJECT = true;
LAST = false;
if (CALJAC) goto LABEL20;
goto LABEL10;
}
}
else
{
goto LABEL78;
}
}
DYNOLD = Math.Max(DYNO, UROUND);
for (I = 1; I <= N; I++)
{
F1I = F1[I + o_f1] + Z1[I + o_z1];
F2I = F2[I + o_f2] + Z2[I + o_z2];
F3I = F3[I + o_f3] + Z3[I + o_z3];
F1[I + o_f1] = F1I;
F2[I + o_f2] = F2I;
F3[I + o_f3] = F3I;
Z1[I + o_z1] = T11 * F1I + T12 * F2I + T13 * F3I;
Z2[I + o_z2] = T21 * F1I + T22 * F2I + T23 * F3I;
Z3[I + o_z3] = T31 * F1I + F2I;
}
if (FACCON * DYNO > FNEWT) goto LABEL40;
// C --- ERROR ESTIMATION
this._estrad.Run(N, FJAC, offset_fjac, LDJAC, MLJAC, MUJAC, FMAS, offset_fmas
, LDMAS, MLMAS, MUMAS, H, DD1, DD2
, DD3, FCN, ref NFCN, Y0, offset_y0, Y, offset_y, IJOB
, X, M1, M2, NM1, E1, offset_e1, LDE1
, Z1, offset_z1, Z2, offset_z2, Z3, offset_z3, ref CONT, offset_cont, ref F1, offset_f1, ref F2, offset_f2
, IP1, offset_ip1, IPHES, offset_iphes, SCAL, offset_scal, ref ERR, FIRST, REJECT
, FAC1, RPAR, offset_rpar, IPAR, offset_ipar);
// C --- COMPUTATION OF HNEW
// C --- WE REQUIRE .2<=HNEW/H<=8.
FAC = Math.Min(SAFE, CFAC / (NEWT + 2 * NIT));
QUOT = Math.Max(FACR, Math.Min(FACL, Math.Pow(ERR, .25E0) / FAC));
HNEW = H / QUOT;
// C *** *** *** *** *** *** ***
// C IS THE ERROR SMALL ENOUGH ?
// C *** *** *** *** *** *** ***
if (ERR < 1.0E0)
{
// C --- STEP IS ACCEPTED
FIRST = false;
NACCPT += 1;
if (PRED)
{
// C --- PREDICTIVE CONTROLLER OF GUSTAFSSON
if (NACCPT > 1)
{
FACGUS = (HACC / H) * Math.Pow(Math.Pow(ERR, 2) / ERRACC, 0.25E0) / SAFE;
FACGUS = Math.Max(FACR, Math.Min(FACL, FACGUS));
QUOT = Math.Max(QUOT, FACGUS);
HNEW = H / QUOT;
}
HACC = H;
ERRACC = Math.Max(1.0E-2, ERR);
}
XOLD = X;
HOLD = H;
X = XPH;
for (I = 1; I <= N; I++)
{
Y[I + o_y] += Z3[I + o_z3];
Z2I = Z2[I + o_z2];
Z1I = Z1[I + o_z1];
CONT[I + N + o_cont] = (Z2I - Z3[I + o_z3]) / C2M1.v;
AK = (Z1I - Z2I) / C1MC2;
ACONT3 = Z1I / C1;
ACONT3 = (AK - ACONT3) / C2;
CONT[I + N2 + o_cont] = (AK - CONT[I + N + o_cont]) / C1M1.v;
CONT[I + N3 + o_cont] = CONT[I + N2 + o_cont] - ACONT3;
}
if (ITOL == 0)
{
for (I = 1; I <= N; I++)
{
SCAL[I + o_scal] = ATOL[1 + o_atol] + RTOL[1 + o_rtol] * Math.Abs(Y[I + o_y]);
}
}
else
{
for (I = 1; I <= N; I++)
{
SCAL[I + o_scal] = ATOL[I + o_atol] + RTOL[I + o_rtol] * Math.Abs(Y[I + o_y]);
}
}
if (IOUT != 0)
{
NRSOL = NACCPT + 1;
XSOL.v = X;
XOSOL = XOLD;
for (I = 1; I <= N; I++)
{
CONT[I + o_cont] = Y[I + o_y];
}
NSOLU = N;
HSOL.v = HOLD;
SOLOUT.Run(NRSOL, XOSOL, XSOL.v, Y, offset_y, CONT, offset_cont, LRC
, NSOLU, RPAR[1 + o_rpar], IPAR[1 + o_ipar], IRTRN);
if (IRTRN < 0) goto LABEL179;
}
CALJAC = false;
if (LAST)
{
H = HOPT;
IDID = 1;
return;
}
FCN.Run(N, X, Y, offset_y, ref Y0, offset_y0, RPAR[1 + o_rpar], IPAR[1 + o_ipar]);
NFCN += 1;
HNEW = POSNEG * Math.Min(Math.Abs(HNEW), HMAXN);
HOPT = HNEW;
HOPT = Math.Min(H, HNEW);
if (REJECT) HNEW = POSNEG * Math.Min(Math.Abs(HNEW), Math.Abs(H));
REJECT = false;
if ((X + HNEW / QUOT1 - XEND) * POSNEG >= 0.0E0)
{
H = XEND - X;
LAST = true;
}
else
{
QT = HNEW / H;
HHFAC = H;
if (THETA <= THET && QT >= QUOT1 && QT <= QUOT2) goto LABEL30;
H = HNEW;
}
HHFAC = H;
if (THETA <= THET) goto LABEL20;
goto LABEL10;
}
else
{
// C --- STEP IS REJECTED
REJECT = true;
LAST = false;
if (FIRST)
{
H *= 0.1E0;
HHFAC = 0.1E0;
}
else
{
HHFAC = HNEW / H;
H = HNEW;
}
if (NACCPT >= 1) NREJCT += 1;
if (CALJAC) goto LABEL20;
goto LABEL10;
}
// C --- UNEXPECTED STEP-REJECTION
LABEL78:;
if (IER != 0)
{
NSING += 1;
if (NSING >= 5) goto LABEL176;
}
H *= 0.5E0;
HHFAC = 0.5E0;
REJECT = true;
LAST = false;
if (CALJAC) goto LABEL20;
goto LABEL10;
// C --- FAIL EXIT
LABEL176:;
//ERROR-ERROR WRITE(6,979)X ;
//ERROR-ERROR WRITE(6,*) ' MATRIX IS REPEATEDLY SINGULAR, IER=',IER;
IDID = -4;
return;
LABEL177:;
//ERROR-ERROR WRITE(6,979)X ;
//ERROR-ERROR WRITE(6,*) ' STEP SIZE T0O SMALL, H=',H;
IDID = -3;
return;
LABEL178:;
//ERROR-ERROR WRITE(6,979)X ;
//ERROR-ERROR WRITE(6,*) ' MORE THAN NMAX =',NMAX,'STEPS ARE NEEDED' ;
IDID = -2;
return;
// C --- EXIT CAUSED BY SOLOUT
LABEL179:;
//ERROR-ERROR WRITE(6,979)X;
IDID = 2;
return;
#endregion Body
}