MODULE KPP_ROOT_Integrator USE KPP_ROOT_Precision USE KPP_ROOT_Global, ONLY: FIX, RCONST, TIME, ATOL, RTOL USE KPP_ROOT_Parameters, ONLY: NVAR, NSPEC, NFIX, LU_NONZERO USE KPP_ROOT_JacobianSP, ONLY: LU_DIAG USE KPP_ROOT_LinearAlgebra, ONLY: KppDecomp, KppSolve, & Set2zero, WLAMCH IMPLICIT NONE PUBLIC SAVE !~~~> Statistics on the work performed by the VODE method INTEGER :: Nfun,Njac,Nstp,Nacc,Nrej,Ndec,Nsol,Nsng INTEGER, PARAMETER :: ifun=1, ijac=2, istp=3, iacc=4, & irej=5, idec=6, isol=7, isng=8, itexit=1, ihexit=2 CHARACTER(LEN=50), PARAMETER, DIMENSION(-8:1) :: IERR_NAMES = (/ & 'Matrix is repeatedly singular ', & ! -8 'Step size too small ', & ! -7 'No of steps exceeds maximum bound ', & ! -6 'Improper tolerance values ', & ! -5 'FacMin/FacMax/FacRej must be positive ', & ! -4 'Hmin/Hmax/Hstart must be positive ', & ! -3 'Improper value for maximal no of Newton iterations', & ! -2 'Improper value for maximal no of steps ', & ! -1 ' ', & ! 0 (not used) 'Success ' /) ! 1 CONTAINS SUBROUTINE INTEGRATE( TIN, TOUT, & ICNTRL_U, RCNTRL_U, ISTATUS_U, RSTATUS_U, IERR_U ) USE KPP_ROOT_Parameters USE KPP_ROOT_Global IMPLICIT NONE KPP_REAL, INTENT(IN) :: TIN ! Start Time KPP_REAL, INTENT(IN) :: TOUT ! End Time ! Optional input parameters and statistics INTEGER, INTENT(IN), OPTIONAL :: ICNTRL_U(20) KPP_REAL, INTENT(IN), OPTIONAL :: RCNTRL_U(20) INTEGER, INTENT(OUT), OPTIONAL :: ISTATUS_U(20) KPP_REAL, INTENT(OUT), OPTIONAL :: RSTATUS_U(20) INTEGER, INTENT(OUT), OPTIONAL :: IERR_U KPP_REAL :: RCNTRL(20), RSTATUS(20) INTEGER :: ICNTRL(20), ISTATUS(20), IERR !!$ INTEGER, SAVE :: Ntotal = 0 TYPE(VODE_OPTS) :: OPTIONS ICNTRL(:) = 0 RCNTRL(:) = 0.0_dp ISTATUS(:) = 0 RSTATUS(:) = 0.0_dp ICNTRL(5) = 2 ! maximal order ! If optional parameters are given, and if they are >0, ! then they overwrite default settings. IF (PRESENT(ICNTRL_U)) THEN WHERE(ICNTRL_U(:) > 0) ICNTRL(:) = ICNTRL_U(:) END IF IF (PRESENT(RCNTRL_U)) THEN WHERE(RCNTRL_U(:) > 0) RCNTRL(:) = RCNTRL_U(:) END IF OPTIONS = SET_OPTS(SPARSE_J=SPARSE, & ABSERR_VECTOR=ATOL, RELERR=RTOL, MXSTEP=100000, & NZSWAG=LU_NONZERO, HMAX=MAXH, LOWER_BANDWIDTH=ML, UPPER_BANDWIDTH=MU,& MA28_ELBOW_ROOM=10, MC19_SCALING=.TRUE., MA28_MESSAGES=.FALSE., & MA28_EPS=1.0D-4, MA28_RPS=.TRUE., & USER_SUPPLIED_SPARSITY=SUPPLY_STRUCTURE) ISTATE = 1 NG = 0 ITASK = 1 CALL DVODE_F90(FUN_CHEM,NVAR,VAR,TIN,TOUT,ITASK,ISTATE,OPTIONS,J_FCN=JAC_CHEM) STEPMIN = RSTATUS(ihexit) ! Save last step ! if optional parameters are given for output they to return information IF (PRESENT(ISTATUS_U)) ISTATUS_U(:) = ISTATUS(1:20) IF (PRESENT(RSTATUS_U)) RSTATUS_U(:) = RSTATUS(1:20) IF (PRESENT(IERR_U)) THEN IF (IERR==2) THEN ! DLSODE returns "2" after successful completion IERR_U = 1 ! IERR_U will return "1" for successful completion ELSE IERR_U = IERR ENDIF ENDIF END SUBROUTINE INTEGRATE !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ SUBROUTINE FUN_CHEM(N, T, V, FCT) !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ USE KPP_ROOT_Parameters USE KPP_ROOT_Global USE KPP_ROOT_Function, ONLY: Fun USE KPP_ROOT_Rates IMPLICIT NONE INTEGER :: N KPP_REAL :: V(NVAR), FCT(NVAR), T ! TOLD = TIME ! TIME = T ! CALL Update_SUN() ! CALL Update_RCONST() ! CALL Update_PHOTO() ! TIME = TOLD CALL Fun(V, FIX, RCONST, FCT) !Nfun=Nfun+1 END SUBROUTINE FUN_CHEM !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ SUBROUTINE JAC_CHEM (N,T,V,IA,JA,NNZ,JF) !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ USE KPP_ROOT_Parameters USE KPP_ROOT_Global USE KPP_ROOT_JacobianSP USE KPP_ROOT_Jacobian, ONLY: Jac_SP USE KPP_ROOT_Rates IMPLICIT NONE KPP_REAL :: V(NVAR), T INTEGER, INTENT(IN) :: N INTEGER, INTENT(OUT) :: NNZ #ifdef FULL_ALGEBRA INTEGER :: I, J KPP_REAL :: JV(LU_NONZERO), JF(NVAR,NVAR) #else KPP_REAL :: JF(LU_NONZERO) INTEGER :: IA(LU_NONZERO), JA(LU_NONZERO) #endif ! TOLD = TIME ! TIME = T ! CALL Update_SUN() ! CALL Update_RCONST() ! CALL Update_PHOTO() ! TIME = TOLD #ifdef FULL_ALGEBRA CALL Jac_SP(V, FIX, RCONST, JV) DO j=1,NVAR DO i=1,NVAR JF(i,j) = 0.0d0 END DO END DO DO i=1,LU_NONZERO JF(LU_IROW(i),LU_ICOL(i)) = JV(i) END DO #else CALL Jac_SP(V, FIX, RCONST, JF) NNZ = LU_NONZERO IA = LU_IROW JA = LU_ICOL #endif !Njac=Njac+1 END SUBROUTINE JAC_CHEM (N,T,V,IA,JA,NNZ,JF) MODULE DVODE ! This version is the December 2005 release. ! Last change: 01/01/08 ! _____________________________________________________________________ ! Working Precision ! IMPLICIT NONE ! Define the working precision for DVODE_F90. Change D0 to E0 in the ! next statement to convert to single precision. ! INTEGER, PARAMETER, PRIVATE :: WP = KIND(1.0D0) ! ______________________________________________________________________ ! Overview ! The f77 ordinary differential equation solver VODE.f is applicable to ! nonstiff systems of odes and to stiff systems having dense or banded ! Jacobians. DVODE_F90 is a Fortran 90 extension of VODE.f. While ! retaining all of the features available in VODE.f, we have ! incorporated several new options in DVODE_F90 including: ! 1. the ability to solve stiff systems with sparse Jacobians ! 2. internal management of storage and work arrays ! 3. specification of options via optional keywords ! 4. the ability to perform root finding or "event detection" ! 5. various new diagnostic and warning messages ! 6. the ability to impose solution bounds ! 7. several specialized options for dealing with sparsity ! ______________________________________________________________________ ! Version Information ! This is DVODE_F90, the double precision FORTRAN 90 extension of the ! f77 DVODE.f ordinary differential equation solver. This version uses ! MA28 for sparse Jacobians. This file and related information can be ! obtained at the following support page: ! ! http://www.radford.edu/~thompson/vodef90web/ ! ! We are indebted to Richard Cox (ORNL) for providing us with his ! implementation of MA28 in LSOD28.f (a variant of Alan Hindmarsh's ! lsodes.f). We are indebted to Alan Hindmarsh for numerous contributions. ! In particular, we borrowed liberally from the f77 solvers VODE.f, ! LSODAR.f, and LSODES.f while developing DVODE_F90. We are indebted ! to Doug Salane for providing us with his JACSP Jacobian routines. ! ! If you find a bug or encounter a problem with DVODE_F90, please ! contact one of us: ! G.D. Byrne (gbyrne@wi.rr.com) ! S. Thompson (thompson@radford.edu) ! A set of quick start instructions is provided below. ! ______________________________________________________________________ ! Note on F90/F95 Compilers ! To date we have used DVODE_F90 successfully with all F90/F95 compilers ! to which we have access. In particular, we have used it with the Lahey ! F90 and Lahey-Fujitsu F95 compilers, the Compaq Visual F90 compiler, ! the g90 compiler, and the INTEL, Portland, Salford, and SUN compilers. ! It should be noted that compilers such as Salford's FTN95 complain ! about uninitialized arrays passed as subroutine arguments and the use of ! slices of two dimensional arrays as one dimensional vectors, and will ! not run using the strictest compiler options. It is perfectly safe to ! use the /-CHECK compiler option to avoid these FTN95 runtime checks. ! DVODE_F90 does not use any variable for numerical purposes until it ! has been assigned an appropriate value. ! ______________________________________________________________________ ! Quick Start Instructions ! (1) Compile this file. Then compile, link, and execute the program ! example1.f90. The output is written to the file example1.dat. ! Verify that the last line of the output is the string ! 'No errors occurred.' ! (2) Repeat this process for the program example2.f90. ! ! Other test programs you may wish to run to verify your installation ! of DVODE_F90 are: ! ! (3) Run the test programs nonstiffoptions.f90 and stiffoptions.f90 ! and verify that the last line in the output files produced is ! 'No errors occurred.' They solve the problems in the Toronto ! test suites using several different error tolerances and various ! solution options. Note that stiffoptions.f90 takes several ! minutes to run because it performs several thousand separate ! integrations. ! (4) Locate the file robertson.f90 in the demo programs and look at ! how options are set using SET_OPTS, how DVODE_F90 is called to ! obtain the solution at desired output times, and how the ! derivative and Jacobian routines are supplied. Note too the ! manner in which the solution is constrained to be nonnegative. ! (5) Locate demoharmonic.f90 and look at how root finding options ! are set and how the event residual routine is supplied to ! DVODE_F90. ! (6) The other demo programs available from the DVODE_F90 support ! page illustrate various other solution options available in ! DVODE_F90. The demo programs may be obtained from ! ! http://www.radford.edu/~thompson/vodef90web/index.html ! ______________________________________________________________________ ! DVODE_F90 Full Documentation Prologue ! Section 1. Setting Options in DVODE_F90 ! Section 2. Calling DVODE_F90 ! Section 3. Choosing Error Tolerances ! Section 4. Choosing the Method of Integration ! Section 5. Interpolation of the Solution and Derivatives ! Section 6. Handling Events (Root Finding) ! Section 7. Gathering Integration Statistics ! Section 8. Determining Jacobian Sparsity Structure Arrays ! Section 9. Original DVODE Documentation Prologue ! Section 10. Example Usage ! Note: Search on the string 'Section' to locate these sections. You ! may wish to refer to the support page which has the sections broken ! into smaller pieces. ! ______________________________________________________________________ ! Section 1. Setting Options in DVODE_F90 ! ! You can use any of three options routines: ! ! SET_NORMAL_OPTS ! SET_INTERMEDIATE_OPTS ! SET_OPTS ! OPTIONS = SET_NORMAL_OPTS(DENSE_J, BANDED_J, SPARSE_J, & ! USER_SUPPLIED_JACOBIAN, LOWER_BANDWIDTH, UPPER_BANDWIDTH, & ! RELERR, ABSERR, ABSERR_VECTOR, NEVENTS) ! OPTIONS = SET_INTERMEDIATE_OPTS(DENSE_J, BANDED_J, SPARSE_J, & ! USER_SUPPLIED_JACOBIAN,LOWER_BANDWIDTH, UPPER_BANDWIDTH, & ! RELERR, ABSERR, ABSERR_VECTOR,TCRIT, H0, HMAX, HMIN, MAXORD, & ! MXSTEP, MXHNIL, NZSWAG, USER_SUPPLIED_SPARSITY, MA28_RPS, & ! NEVENTS, CONSTRAINED, CLOWER, CUPPER, CHANGE_ONLY_f77_OPTIONS) & ! OPTIONS = SET_OPTS(METHOD_FLAG, DENSE_J, BANDED_J, SPARSE_J, & ! USER_SUPPLIED_JACOBIAN, SAVE_JACOBIAN, CONSTANT_JACOBIAN, & ! LOWER_BANDWIDTH, UPPER_BANDWIDTH, SUB_DIAGONALS, SUP_DIAGONALS, & ! RELERR, RELERR_VECTOR, ABSERR, ABSERR_VECTOR, TCRIT, H0, HMAX, & ! HMIN, MAXORD, MXSTEP, MXHNIL, YMAGWARN, SETH, UPIVOT, NZSWAG, & ! USER_SUPPLIED_SPARSITY, NEVENTS, CONSTRAINED, CLOWER, CUPPER, & ! MA28_ELBOW_ROOM, MC19_SCALING, MA28_MESSAGES, MA28_EPS, & ! MA28_RPS, CHANGE_ONLY_f77_OPTIONS, JACOBIAN_BY_JACSP) ! Please refer to the documentation prologue for each of these functions ! to see what options may be used with each. Note that input to each is ! via keyword and all variables except error tolerances are optional. ! Defaults are used for unspecified options. If an option is available ! in SET_NORMAL OPTS, it is available and has the same meaning in ! SET_INTERMEDIATE_OPTS and SET_OPTS. Similarly, if an option is available ! in SET_INTERMEDIATE_OPTS, it is available and has the same meaning in ! SET_OPTS. ! The first two functions are provided merely for convenience. ! SET_NORMAL_OPTS is available simply to relieve you of reading the ! documentation for SET_OPTS and to use default values for all but ! the most common options. SET_INTERMEDIATE_OPTS is available to allow ! you more control of the integration while still using default values ! for less commonly used options. SET_OPTS allows you to specify any ! of the options available in DVODE_F90. ! Roughly, SET_NORMAL_OPTS is intended to provide for dense, banded, ! and numerical sparse Jacobians without the need to specify other ! specialized options. SET_INTERMEDIATE_OPTIONS is intended to allow ! more general sparse Jacobian options. SET_OPTS is intended to provide ! access to all options in DVODE_F90. ! Please note that SET_INTERMEDIATE_OPTS can be invoked using the same ! arguments as SET_NORMAL_OPTS; and SET_OPTS can be invoked using the ! same arguments as either SET_NORMAL_OPTS or SET_INTERMEDIATE_OPTS. ! If you wish you can simply delete SET_NORMAL_OPTS as well as ! SET_INTERMEDIATE_OPTS and use only SET_OPTS for all problems. If you ! do so, you need only include the options that you wish to use when ! you invoke SET_OPTIONS. ! In the following description any reference to SET_OPTS applies equally ! to SET_NORMAL_OPTS and SET_INTERMEDIATE OPTS. ! Before calling DVODE_F90 for the first time, SET_OPTS must be invoked. ! Typically, SET_OPTS is called once to set the desired integration ! options and parameters. DVODE_F90 is then called in an output loop to ! obtain the solution for the desired times. A detailed description of ! the DVODE_F90 arguments is given in a section below. Detailed descriptions ! of the options available via SET_OPTS are given in the documentation prologue. ! Although each option available in the f77 version of DVODE as well as ! several additional ones are available in DVODE_F90 via SET_OPTS, ! several of the available options are not relevant for most problems ! and need not be specified. Refer to the accompanying demonstration ! programs for specific examples of each usage. Note that after any call ! to DVODE_F90, you may call GET_STATS to gather relevant integration ! statistics. After your problem has completed, you may call ! RELEASE_ARRAYS to deallocate any internal arrays allocated by ! DVODE_F90 and to determine how much storage was used by DVODE_F90. ! ! To communicate with DVODE_F90 you will need to include the following ! statement in your calling program: ! USE DVODE_F90_M ! and include the following statement in your type declarations section: ! TYPE(VODE_OPTS) :: OPTIONS ! Below are brief summaries of typical uses of SET_OPTS. ! Nonstiff Problems: ! OPTIONS = SET_OPTS(RELERR=RTOL,ABSERR=ATOL) ! The above use of SET_OPTS will integrate your system of odes ! using the nonstiff Adams methods while using a relative error ! tolerance of RTOL and an absolute error tolerance of ATOL. ! Your subsequent call to DVODE_F90 might look like: ! CALL DVODE_F90(F,NEQ,Y,T,TOUT,ITASK,ISTATE,OPTIONS) ! OPTIONS = SET_OPTS(RELERR=RTOL,ABSERR=ATOL,NEVENTS=NG) ! If you wish to do root finding, SET_OPTS can be used as above. ! Here, NEVENTS is the desired number of root finding functions. ! Your subsequent call to DVODE_F90 might look like: ! CALL DVODE_F90(F,NEQ,Y,T,TOUT,ITASK,ISTATE,OPTIONS,G_FCN=G) ! Here F is the name of your derivative subroutine and G is the ! name of your subroutine to evaluate residuals of the root ! finding functions. ! OPTIONS = SET_OPTS(RELERR=RTOL,ABSERR_VECTOR=ATOL) ! This use of SET_OPTS indicates that a scalar relative error ! tolerance and a vector of absolute error tolerances will be ! used. ! Stiff Problems, internally generated dense Jacobian: ! OPTIONS = SET_OPTS(DENSE_J=.TRUE.,RELERR=RTOL,ABSERR=ATOL) ! This use of DENSE_J=.TRUE. indicates that DVODE_F90 will ! use the stiffly stable BDF methods and will approximate ! the Jacobian, considered to be a dense matrix, using ! finite differences. Your subsequent call to DVODE_F90 ! might look like: ! CALL DVODE_F90(F,NEQ,Y,T,TOUT,ITASK,ISTATE,OPTIONS) ! OPTIONS = SET_OPTS(DENSE_J=.TRUE.,ABSERR=ATOL,RELERR=RTOL, & ! USER_SUPPLIED_JACOBIAN=.TRUE.) ! If you know the Jacobian and wish to supply subroutine JAC ! as described in the documentation for DVODE_F90, the options ! call could look like the above. ! Your subsequent call to DVODE_F90 might look like: ! CALL DVODE_F90(F1,NEQ,Y,T,TOUT,ITASK,ISTATE,OPTIONS,J_FCN=JAC) ! Here, JAC is the name of the subroutine that you provide to ! evaluate the known Jacobian. ! Stiff Problems, internally generated banded Jacobian: ! OPTIONS = SET_OPTS(BANDED_J=.TRUE.,RELERR=RTOL,ABSERR=ATOL, & ! LOWER_BANDWIDTH=ML,UPPER_BANDWIDTH=MU) ! This use of BANDED_J=.TRUE. indicates that DVODE_F90 will ! use the stiffly stable BDF methods and will approximate the ! Jacobian, considered to be a banded matrix, using finite ! differences. Here ML is the lower bandwidth of the Jacobian ! and ML is the upper bandwidth of the Jacobian. ! Stiff Problems, internally generated sparse Jacobian: ! OPTIONS = SET_OPTS(SPARSE_J=.TRUE.,ABSERR=ATOL,RELERR=RTOL) ! This use of SET_OPTS indicates that the Jacobian is a sparse ! matrix. Its structure will be approximated internally by ! making calls to your derivative routine. If you know the ! structure before hand, you may provide it directly in a ! variety of ways as described in the documentation prologue ! for SET_OPTS. In addition, several other options related ! to sparsity are available. ! More complicated common usage: ! Suppose you need to solve a stiff problem with a sparse Jacobian. ! After some time, the structure of the Jacobian changes and you ! wish to have DVODE_F90 recalculate the structure before continuing ! the integration. Suppose that initially you want to use an absolute ! error tolerance of 1.0D-5 and that when the Jacobian structure is ! changed you wish to reduce the error tolerance 1.0D-7. Your calls ! might look like this. ! RTOL = ... ! ATOL = 1.0D-5 ! OPTIONS = SET_OPTS(SPARSE_J=.TRUE.,ABSERR=ATOL,RELERR=RTOL) ! Output loop: ! CALL DVODE_F90(FCN,NEQ,Y,T,TOUT,ITASK,ISTATE,OPTIONS) ! At desired time: ! ISTATE = 3 ! ATOL = 1.0D-7 ! OPTIONS = SET_OPTS(SPARSE_J=.TRUE.,ABSERR=ATOL,RELERR=RTOL) ! End of output loop ! In the following we have summarized and described how some of the demonstration ! programs set options and call DVODE_F90. In each case the necessary parameters ! are defined before invoking SET_OPTS. The call to DVODE_F90 is in a loop in ! which the output time is successively updated. The actual programs are available ! from the web support page ! ! http://www.radford. edu/~thompson/vodef90web/index.html/ ! ! Problem Summary ! ! Problem NEQ Jacobian Features Illustrated ! ! Prologue Example 1 3 Dense Basic ! ! Prologue Example 2 3 Dense Root finding ! ! Robertson 3 Dense Solution bounds ! ! Harmonic Oscillator 4 Nonstiff Root finding ! ! Flow Equations 5-1800 Sparse Automatic determination ! of sparsity arrays ! ! Diurnal Kinetics 50-5000 Sparse or banded Sparsity options ! ! Options Used and DVODE_F90 Call ! ! Prologue Example 1 ! ! OPTIONS = SET_NORMAL_OPTS(DENSE_J=.TRUE., ABSERR_VECTOR=ATOL, RELERR=RTOL, & ! USER_SUPPLIED_JACOBIAN=.TRUE.) ! CALL DVODE_F90(FEX,NEQ,Y,T,TOUT,ITASK,ISTATE,OPTIONS,J_FCN=JEX) ! ! The problem consists of a stiff system of NEQ=3 equations. The dense ! Jacobian option (DENSE_J) is used. A vector ATOL(*) of error tolerances ! is used. A scalar relative error tolerance RTOL is used. Subroutine JEX ! is provided to evaluate the analytical Jacobian. If the last argument ! J_FCN=JEX is omitted (as in Example 2), a numerical Jacobian will ! be used. ! ! Prologue Example 2 ! ! OPTIONS = SET_NORMAL_OPTS(DENSE_J=.TRUE., RELERR=RTOL, ABSERR_VECTOR=ATOL, & ! NEVENTS=NG) ! CALL DVODE_F90(FEX,NEQ,Y,T,TOUT,ITASK,ISTATE,OPTIONS,G_FCN=GEX) ! ! The system in Example 1 is used to illustrate root finding. It is ! desired to locate the times at which two of the solution components ! attain prescribed values. NEVENTS=2 informs the solver that two such ! functions are used. Subroutine GEX is used to calculate the residuals ! for these two functions. A dense numerical Jacobian is used. ! ! Robertson Problem ! ! OPTIONS = SET_INTERMEDIATE_OPTS(DENSE_J=.TRUE., RELERR_VECTOR=RTOL, & ! ABSERR_VECTOR=ABSERR_TOLERANCES, CONSTRAINED=BOUNDED_COMPONENTS, & ! CLOWER=LOWER_BOUNDS, CUPPER=UPPER_BOUNDS) ! ! CALL DVODE_F90(DERIVS,NEQ,Y,T,TOUT,ITASK,ISTATE,OPTIONS,J_FCN=JACD) ! The system used in Examples 1 and 2 is solved over a much larger ! time interval. The solution is constrained to be nonegative. This ! is done by prescribing the components to be constrained (BOUNDED_COMPONENTS). ! Artificially large values are used to impose upper bounds (UPPER_BOUNDS) ! and lower bounds of zero are used to force a nonnegative solution. ! ! Harmonic Oscillator Problem ! ! OPTIONS = SET_NORMAL_OPTS(RELERR=RTOL, ABSERR=ATOL, NEVENTS=NG) ! CALL DVODE_F90(DERIVS,NEQ,Y,T,TOUT,ITASK,ISTATE,OPTIONS,G_FCN=GEVENTS) ! ! A nonstiff system of NEQ=4 equations is solved. The nonstiff option is ! used because neither DENSE_ nor BANDED_J nor SPARSE_J is present. It is ! desired to find the times at which Y(2) or Y(3) is equal to 0. Residuals ! for the two corresponding event functions are calculated in subroutine ! GEVENTS. ! ! Flow Equations Problem ! ! OPTIONS = SET_OPTS(SPARSE_J=SPARSE, ABSERR=ATOL(1), RELERR=RTOL(1), & ! MXSTEP=100000, NZSWAG=20000) ! CALL DVODE_F90(FCN,NEQ,Y,T,TOUT,ITASK,ISTATE,OPTIONS) ! ! This is a stiff system of equations resulting a method of lines ! discretization. The Jacobian is sparse. Scalar absolute and relative ! error tolerances are used. The Jacobian structure and a numerical ! Jacobian are used. The solver is limited to a maximum of MXSTEP steps. ! NZSWAG is the amount by which allocated array sizes will be increased. ! The accompanying test program may be used to illutrate several other ! solution options. ! ! Diurnal Kinetics Problem ! ! OPTIONS = SET_OPTS(SPARSE_J=SPARSE, BANDED_J=BANDED, DENSE_J=DENSE, & ! ABSERR_VECTOR=ATOL(1:NEQ), RELERR=RTOL(1), MXSTEP=100000, & ! NZSWAG=50000, HMAX=MAXH, LOWER_BANDWIDTH=ML, UPPER_BANDWIDTH=MU, & ! MA28_ELBOW_ROOM=10, MC19_SCALING=.TRUE., MA28_MESSAGES=.FALSE., & ! MA28_EPS=1.0D-4, MA28_RPS=.TRUE., & ! USER_SUPPLIED_SPARSITY=SUPPLY_STRUCTURE) ! CALL USERSETS_IAJA(IA, IADIM, JA, JADIM) ! CALL DVODE_F90(FCN, NEQ, Y, T, TOUT, ITASK, ISTATE, OPTIONS) ! ! This problem can be used to illustrate most solution options. Here, dense, ! banded, or sparse Jacobians are used depending on the values of the first ! three parameters. A vector error tolerance is used and a scalar relative ! error tolerance is used. If a banded solution is desired, it is necessary ! to supply the bandwidths ML and MU. If a sparse solution is desired, ! several special options are used. The most important one is MA28_RPS to ! force the solver to update the partial pivoting sequence when singular ! iteration matrices are encountered. The sparsity pattern is determined ! numerically if SUPPLY_STRUCTURE is FALSE. Otherwise the user will supply ! the pattern by calling subroutine USERSETS_IAJA. ! ______________________________________________________________________ ! Section 2. Calling DVODE_F90 ! ! DVODE_F90 solves the initial value problem for stiff or nonstiff ! systems of first order ODEs, ! dy/dt = f(t,y), or, in component form, ! dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(NEQ)) (i = 1,...,NEQ). ! DVODE_F90 is a package based on the EPISODE and EPISODEB packages, ! and on the ODEPACK user interface standard. It was developed from ! the f77 solver DVODE developed by Brown, Byrne, and Hindmarsh. ! DVODE_F90 also provides for the solution of sparse systems in a ! fashion similar to LSODES and LSOD28. Currently, MA28 is used ! to perform the necessary sparse linear algebra. DVODE_F90 also ! contains the provision to do root finding in a fashion similar ! to the LSODAR solver from ODEPACK. ! Communication between the user and the DVODE_F90 package, for normal ! situations, is summarized here. This summary describes only a subset ! of the full set of options available. See the full description for ! details, including optional communication, nonstandard options, and ! instructions for special situations. ! CALL DVODE_F90(F,NEQ,Y,T,TOUT,ITASK,ISTATE,OPTIONS,J_FCN=JAC,G_FCN=GEX) ! The arguments in the call list to DVODE_F90 have the following ! meanings. ! F = The name of the user-supplied subroutine defining the ! ODE system. The system must be put in the first-order ! form dy/dt = f(t,y), where f is a vector-valued function ! of the scalar t and the vector y. Subroutine F is to ! compute the function f. It is to have the form ! SUBROUTINE F(NEQ,T,Y,YDOT) ! DOUBLE PRECISION T,Y(NEQ),YDOT(NEQ) ! where NEQ, T, and Y are input, and the array YDOT = f(t,y) ! is output. Y and YDOT are arrays of length NEQ. ! Subroutine F should not alter Y(1),...,Y(NEQ). ! If F (and JAC) are not contained in a module available to ! your calling program, you must declare F to be EXTERNAL ! in the calling program. ! NEQ = The size of the ODE system (number of first order ! ordinary differential equations). ! Y = A double precision array for the vector of dependent variables, ! of length NEQ or more. Used for both input and output on the ! first call (ISTATE = 1), and only for output on other calls. ! On the first call, Y must contain the vector of initial ! values. In the output, Y contains the computed solution ! evaluated at T. ! T = The independent variable. In the input, T is used only on ! the first call, as the initial point of the integration. ! In the output, after each call, T is the value at which a ! computed solution Y is evaluated (usually the same as TOUT). ! On an error return, T is the farthest point reached. ! TOUT = The next value of t at which a computed solution is desired. ! TOUT is Used only for input. When starting the problem ! (ISTATE = 1), TOUT may be equal to T for one call, then ! should not equal T for the next call. For the initial T, ! an input value of TOUT unequal to T is used in order to ! determine the direction of the integration (i.e. the ! algebraic sign of the step sizes) and the rough scale ! of the problem. Integration in either direction (forward ! or backward in t) is permitted. If ITASK = 2 or 5 (one-step ! modes), TOUT is ignored after the first call (i.e. the ! first call with TOUT \= T). Otherwise, TOUT is required ! on every call. If ITASK = 1, 3, or 4, the values of TOUT ! need not be monotone, but a value of TOUT which backs up ! is limited to the current internal t interval, whose ! endpoints are TCUR - HU and TCUR. (Refer to the description ! of GET_STATS for a description of TCUR and HU.) ! ITASK = An index specifying the task to be performed. ! Input only. ITASK has the following values and meanings. ! 1 means normal computation of output values of y(t) at ! t = TOUT (by overshooting and interpolating). ! 2 means take one step only and return. ! 3 means stop at the first internal mesh point at or ! beyond t = TOUT and return. ! 4 means normal computation of output values of y(t) at ! t = TOUT but without overshooting t = TCRIT. ! TCRIT must be specified in your SET_OPTS call. TCRIT ! may be equal to or beyond TOUT, but not behind it in ! the direction of integration. This option is useful ! if the problem has a singularity at or beyond t = TCRIT. ! 5 means take one step, without passing TCRIT, and return. ! TCRIT must be specified in your SET_OPTS call. ! If ITASK = 4 or 5 and the solver reaches TCRIT (within ! roundoff), it will return T = TCRIT(exactly) to indicate ! this (unless ITASK = 4 and TOUT comes before TCRIT, in ! which case answers at T = TOUT are returned first). ! ISTATE = an index used for input and output to specify the ! the state of the calculation. ! In the input, the values of ISTATE are as follows. ! 1 means this is the first call for the problem ! (initializations will be done). See note below. ! 2 means this is not the first call, and the calculation ! is to continue normally, with no change in any input ! parameters except possibly TOUT and ITASK. ! 3 means this is not the first call, and the ! calculation is to continue normally, but with ! a change in input parameters other than ! TOUT and ITASK. Desired changes require SET_OPTS ! be called prior to calling DVODE_F90 again. ! A preliminary call with TOUT = T is not counted as a ! first call here, as no initialization or checking of ! input is done. (Such a call is sometimes useful to ! include the initial conditions in the output.) ! Thus the first call for which TOUT is unequal to T ! requires ISTATE = 1 in the input. ! In the output, ISTATE has the following values and meanings. ! 1 means nothing was done, as TOUT was equal to T with ! ISTATE = 1 in the input. ! 2 means the integration was performed successfully. ! 3 means a root of one of your root finding functions ! has been located. ! A negative value of ISTATE indicates that DVODE_F90 ! encountered an error as described in the printed error ! message. Since the normal output value of ISTATE is 2, ! it does not need to be reset for normal continuation. ! Also, since a negative input value of ISTATE will be ! regarded as illegal, a negative output value requires ! the user to change it, and possibly other input, before ! calling the solver again. ! OPTIONS = The options structure produced by your call to SET_OPTS. ! JAC = The name of the user-supplied routine (MITER = 1 or 4 or 6) ! If you do not specify that a stiff method is to be used ! in your call to SET_OPTS, you need not include JAC in ! your call to DVODE_F90. If you specify a stiff method and ! that a user supplied Jacobian will be supplied, JAC must ! compute the Jacobian matrix, df/dy, as a function of the ! scalar t and the vector y. It is to have the form: ! SUBROUTINE JAC(NEQ, T, Y, ML, MU, PD, NROWPD) ! DOUBLE PRECISION T, Y(NEQ), PD(NROWPD,NEQ) ! where NEQ, T, Y, ML, MU, and NROWPD are input and the array ! PD is to be loaded with partial derivatives (elements of the ! Jacobian matrix) in the output. PD must be given a first ! dimension of NROWPD. T and Y have the same meaning as in ! Subroutine F. ! In the full matrix case (MITER = 1), ML and MU are ! ignored, and the Jacobian is to be loaded into PD in ! columnwise manner, with df(i)/dy(j) loaded into PD(i,j). ! In the band matrix case (MITER = 4), the elements ! within the band are to be loaded into PD in columnwise ! manner, with diagonal lines of df/dy loaded into the rows ! of PD. Thus df(i)/dy(j) is to be loaded into PD(i-j+MU+1,j). ! ML and MU are the half-bandwidth parameters. (See IUSER). ! The locations in PD in the two triangular areas which ! correspond to nonexistent matrix elements can be ignored ! or loaded arbitrarily, as they are overwritten by DVODE_F90. ! In the sparse matrix case the elements of the matrix ! are determined by the sparsity structure given by the ! IA and JA pointer arrays. Refer to the documentation ! prologue for SET_OPTS for a description of the arguments ! for JAC since they differ from the dense and banded cases. ! JAC need not provide df/dy exactly. A crude ! approximation (possibly with a smaller bandwidth) will do. ! In either case, PD is preset to zero by the solver, ! so that only the nonzero elements need be loaded by JAC. ! In the sparse matrix case, JAC has a different form: ! SUBROUTINE JAC (N, T, Y, IA, JA, NZ, PD) ! Given the number of odes N, the current time T, and the ! current solution vector Y, JAC must do the following: ! If NZ = 0 on input: ! Replace NZ by the number of nonzero elements in the ! Jacobian. The diagonal of the Jacobian must be included. ! Do NOT define the arrays IA, JA, PD at this time. ! Once JAC has been called with NZ = 0 and you have ! defined the value of NZ, future calls to JAC will use ! this value of NZ. ! When a call is made with NZ unequal to 0, you must ! define the sparsity structure arrays IA and JA, and ! the sparse Jacobian PD. ! IA defines the number of nonzeros including the ! diagonal in each column of the Jacobian. Define ! IA(1) = 1 and for J = 1,..., N, ! IA(J+1) = IA(J) + number of nonzeros in column J. ! Diagonal elements must be included even if they are ! zero. You should check to ensure that IA(N+1)-1 = NZ. ! JA defines the rows in which the nonzeros occur. ! For I = 1,...,NZ, JA(I) is the row in which the Ith ! element of the Jacobian occurs. JA must also include ! the diagonal elements of the Jacobian. ! PD defines the numerical value of the Jacobian ! elements. For I = 1,...,NZ, PD(I) is the numerical ! value of the Ith element in the Jacobian. PD must ! also include the diagonal elements of the Jacobian. ! GFUN = the name of the subroutine to evaluate the residuals for ! event functions. If you do not specify that events are ! present (by specifying NEVENTS > 0 in SET_OPTS), you ! need not include GFUN in your call list for DVODE_F90. ! If GFUN is not contained in a module available to your ! calling program, you must declare GFUN to be EXTERNAL ! in your calling program. ! To continue the integration after a successful return, simply ! reset TOUT and call DVODE_F90 again. No other parameters need ! be reset unless ISTATE=3 in which case, reset it to 2 before ! calling DVODE_F90 again. ! ______________________________________________________________________ ! Section 3. Choosing Error Tolerances ! ! This is the most important aspect of solving odes numerically. ! You may supply any of four keywords and values. If you wish to ! use scalar error tolerances, you should supply ABSERR and RELERR. ! For a good many problems, it is advisable to supply a vector of ! absolute error tolerances ABSERR_VECTOR = desired vector. This ! allows you to use different tolerances for each component of ! the solution. If ABSERR_VECTOR is supplied, it must be a vector ! of length NEQ where NEQ is the number of odes in your system. ! Similarly, you may supply a vector of relative error tolerances, ! RELERR_VECTOR. If no tolerances are specified, DVODE_F90 will use ! default error tolerances ABSERR=1D-6 and RELERR=1D-4; but it is ! strongly recommended that you supply values that are appropriate ! for your problem. In the event you do not supply error tolerances, ! DVODE_F90 will print a reminder that the default error tolerances ! are not appropriate for all problems. ! ! RELERR can be set to a scalar value as follows. ! Determine the number of significant digits of accuracy desired, ! which will be a positive integer, say, N. ! Then set RELERR = 10**-(N+1). ! The authors recommend that RELERR be no larger than 10**-4. ! The authors recommend a vector valued absolute error tolerance, ! which can be set as follows. ! For the I-th component of the solution vector, Y(I), determine ! the positive number FLOOR(I) at which ABS(Y(I)) becomes ! negligible for the problem at hand. FLOOR(I) is sometimes called ! the problem zero or the floor value for the I-th component and is ! problem dependent. For a given problem that is not scaled, these ! floor values may well vary by up to 9 orders of magnitude. ! Set ABSERR(I) = FLOOR(I) or to be conservative ! ABSERR_VECTOR(I) = 0.1*FLOOR(I). There is no variable FLOOR in ! DVODE_F90. If it is difficult to divine the components of ABSERR, ! (or FLOOR) make a reasonable guess, run the problem, then set that ! ABSERR_VECTOR so for I = 1, 2,...NEQ, ! ABSERR_VECTOR(I) = 1D-6*RELERR*MAX{ABS(Y(I,TOUT): for all TOUT}. ! The correct choices for RELERR and ABSERR can and do have ! significant impact on both the quality of the solution and run ! time. Counter intuitively, error tolerances that are too loose ! can and do increase run time significantly and the quality of ! the solution may be seriously compromised. ! Examples: ! 1. OPTIONS = SET_OPTS(DENSE_J=.TRUE., ABSERR=1D-8,RELERR=1D-8) ! This will yield MF = 22. Both the relative error tolerance ! and the absolute error tolerance will equal 1D-8. ! 2. OPTIONS = SET_OPTS(DENSE_J=.TRUE.,RELERR=1D-5, & ! ABSERR_VECTOR=(/1D-6,1D-8/)) ! For a system with NEQ=2 odes, this will yield MF = 22. A scalar ! relative error tolerance equal to 1D-5 will be used. Component 1 ! of the solution will use an absolute error tolerance of 1D-6 ! while component 2 will use an absolute error tolerance of 1D-8. ! ______________________________________________________________________ ! Section 4. Choosing the Method of Integration ! ! If you wish to specify a numerical value for METHOD_FLAG, it can equal ! any of the legal values of MF for DVODE or LSODES. (See below.) If ! you do not wish to specify a numerical value for METHOD_FLAG, you ! may specify any combination of the five logical keywords DENSE_J, ! BANDED_J, SPARSE_J, USER_SUPPLIED_JACOBIAN, SAVE_JACOBIAN that you ! wish. Appropriate values will be used in DVODE_F90 for any variables ! that are not present. The first three flags indicate the type of ! Jacobian, dense, banded, or sparse. If USER_SUPPLIED_JACOBIAN=.TRUE., ! the Jacobian will be determined using the subroutine JAC you supply ! in your call to DVODE_F90. Otherwise, an internal Jacobian will be ! generated using finite differences. ! Examples: ! 1. OPTIONS = SET_OPTS(METHOD_FLAG=22,...) ! DVODE will use the value MF=22 as described in the documentation ! prologue. In this case, the stiff BDF methods will be used with ! a dense, internally generated Jacobian. ! 2. OPTIONS = SET_OPTS(METHOD_FLAG=21,...) ! This is the same an Example 1 except that a user supplied dense ! Jacobian will be used and DVODE will use MF=21. ! 3. OPTIONS = SET_OPTS(DENSE_J=.TRUE.,...) ! This will yield MF = 22 as in Example 1, provided ! USER_SUPPLIED_JACOBIAN and SAVE_JACOBIAN are not present, or if ! present are set to their default ! values of .FALSE. and .TRUE., respectively. ! 4. OPTIONS = SET_OPTS(DENSE_J=.TRUE.,& ! USER_SUPPLIED_JACOBIAN=.TRUE.,...) ! This will yield MF = 21 as in Example 2, provided SAVE_JACOBIAN ! is not present, or if present is set to its default value .FALSE. ! Notes: ! 1. If you specify more than one of DENSE_J, BANDED_J, and SPARSE_J, ! DENSE_J takes precedence over BANDED_J which in turn takes ! precedence over SPARSE_J. ! 2. By default, DVODE_F90 saves a copy of the Jacobian and reuses the ! copy when necessary. For problems in which storage requirements ! are acute, you may wish to override this default and have ! DVODE_F90 recalculate the Jacobian rather than use a saved copy. ! You can do this by specifying SAVE_JACOBIAN=.FALSE. It is ! recommended that you not do this unless necessary since it can ! have a significant impact on the efficiency of DVODE_F90. (For ! example, when solving a linear problem only one evaluation of ! the Jacobian is required with the default option.) ! 3. If you choose BANDED_J = .TRUE. or if you supply a value of MF ! that corresponds to a banded Jacobian, you must also supply the ! lower bandwidth ML and the upper bandwidth of the Jacobian MU ! by including the keywords ! LOWER_BANDWIDTH = value of ML and UPPER_BANDWIDTH = value of M ! More on Method Selection ! The keyword options available in SET_OPTS are intended to replace ! the original method indicator flag MF. However, if you wish to ! retain the flexibility of the original solver, you may specify MF ! directly in your call to SET_OPTS. This is done by using the ! keyword METHOD_FLAG=MF in your SET_OPTS where MF has any of the ! values in the following description. Refer to the demonstration ! program demosp.f90 for an example in which this is done. ! MF = The method flag. Used only for input. The legal values of ! MF are: ! 10, 11, 12, 13, 14, 15, 16, 17, 20, 21, 22, 23, 24, 25, 26, ! 27, -11, -12, -14, -15, -21, -22, -24, -25, -26, -27. ! MF is a signed two-digit integer, MF = JSV*(10*METH+MITER). ! JSV = SIGN(MF) indicates the Jacobian-saving strategy: ! JSV = 1 means a copy of the Jacobian is saved for reuse ! in the corrector iteration algorithm. ! JSV = -1 means a copy of the Jacobian is not saved ! (valid only for MITER = 1, 2, 4, or 5). ! METH indicates the basic linear multistep method: ! METH = 1 means the implicit Adams method. ! METH = 2 means the method based on backward ! differentiation formulas (BDF-s). ! MITER indicates the corrector iteration method: ! MITER = 0 means functional iteration (no Jacobian matrix ! is involved). ! MITER = 1 means chord iteration with a user-supplied ! full (NEQ by NEQ) Jacobian. ! MITER = 2 means chord iteration with an internally ! generated (difference quotient) full Jacobian ! (using NEQ extra calls to F per df/dy value). ! MITER = 4 means chord iteration with a user-supplied ! banded Jacobian. ! MITER = 5 means chord iteration with an internally ! generated banded Jacobian (using ML+MU+1 extra ! calls to F per df/dy evaluation). ! MITER = 6 means chord iteration with a user-supplied ! sparse Jacobian. ! MITER = 7 means chord iteration with an internally ! generated sparse Jacobian ! If MITER = 1, 4, or 6 the user must supply a subroutine ! JAC(the name is arbitrary) as described above under JAC. ! For other values of MITER, JAC need not be provided. ! ______________________________________________________________________ ! Section 5. Interpolation of the Solution and Derivative ! ! Following a successful return from DVODE_F90, you may call ! subroutine DVINDY to interpolate the solution or derivative. ! SUBROUTINE DVINDY(T, K, DKY, IFLAG) ! DVINDY computes interpolated values of the K-th derivative of the ! dependent variable vector y, and stores it in DKY. This routine ! is called with K = 0 or K = 1 and T = TOUT. In either case, the ! results are returned in the array DKY of length at least NEQ which ! must be declared and dimensioned in your calling program. The ! computed values in DKY are obtained by interpolation using the ! Nordsieck history array. ! ______________________________________________________________________ ! Section 6. Handling Events (Root Finding) ! ! DVODE_F90 contains root finding provisions. It attempts to ! locates the roots of a set of functions ! g(i) = g(i,t,y(1),...,y(NEQ)) (i = 1,...,ng). ! To use root finding include NEVENTS=NG in your call to SET_OPTS ! where NG is the number of root finding functions. You must then ! supply subroutine GFUN in your call to DVODE_F90 using ! G_FCN=GFUN as the last argument. GFUN must has the form ! SUBROUTINE GFUN(NEQ, T, Y, NG, GOUT) ! where NEQ, T, Y, and NG are input, and the array GOUT is output. ! NEQ, T, and Y have the same meaning as in the F routine, and ! GOUT is an array of length NG. For i = 1,...,NG, this routine is ! to load into GOUT(i) the value at (T,Y) of the i-th constraint ! function g(i). DVODE_F90 will find roots of the g(i) of odd ! multiplicity (i.e. sign changes) as they occur during the ! integration. GFUN must be declared EXTERNAL in the calling ! program. Note that because of numerical errors in the functions ! g(i) due to roundoff and integration error, DVODE_F90 may return ! false roots, or return the same root at two or more nearly equal ! values of t. This is particularly true for problems in which the ! integration is restarted (ISTATE = 1) at a root. If such false ! roots are suspected, you should consider smaller error tolerances ! and/or higher precision in the evaluation of the g(i). Note ! further that if a root of some g(i) defines the end of the ! problem, the input to DVODE_F90 should nevertheless allow ! integration to a point slightly past that root, so that DVODE_F90 ! can locate the root by interpolation. Each time DVODE_F90 locates ! a root of one of your event functions it makes a return to the ! calling program with ISTATE = 3. When such a return is made and ! you have processed the results, simply change ISTATE = 2 and call ! DVODE_F90 again without making other changes. ! ______________________________________________________________________ ! Section 7. Gathering Integration Statistics ! ! SUBROUTINE GET_STATS(RSTATS, ISTATS, NUMEVENTS, JROOTS) ! Caution: ! RSTATS and ISTATS must be declared and dimensioned in your ! main program. The minimum dimensions are: ! DIMENSION RSTATS(22), ISTATS(31) ! This subroutine returns the user portions of the original DVODE ! RUSER and IUSER arrays, and if root finding is being done, it ! returns the original LSODAR JROOT vector. NUMEVENTS and JROOTS ! are optional parameters. NUMEVENTS is the number of root functions ! and JROOTS is an integer array of length NUMEVENTS. ! Available Integration Statistics: ! HU RUSER(11) The step size in t last used (successfully). ! HCUR RUSER(12) The step size to be attempted on the next step. ! TCUR RUSER(13) The current value of the independent variable ! which the solver has actually reached, i.e. the ! current internal mesh point in t. In the output, ! TCUR will always be at least as far from the ! initial value of t as the current argument T, ! but may be farther (if interpolation was done). ! TOLSF RUSER(14) A tolerance scale factor, greater than 1.0, ! computed when a request for too much accuracy was ! detected (ISTATE = -3 if detected at the start of ! the problem, ISTATE = -2 otherwise). If ITOL is ! left unaltered but RTOL and ATOL are uniformly ! scaled up by a factor of TOLSF for the next call, ! then the solver is deemed likely to succeed. ! (The user may also ignore TOLSF and alter the ! tolerance parameters in any other way appropriate.) ! NST IUSER(11) The number of steps taken for the problem so far. ! NFE IUSER(12) The number of f evaluations for the problem so far. ! NJE IUSER(13) The number of Jacobian evaluations so far. ! NQU IUSER(14) The method order last used (successfully). ! NQCUR IUSER(15) The order to be attempted on the next step. ! IMXER IUSER(16) The index of the component of largest magnitude in ! the weighted local error vector (E(i)/EWT(i)), ! on an error return with ISTATE = -4 or -5. ! LENRW IUSER(17) The length of RUSER actually required. ! This is defined on normal returns and on an illegal ! input return for insufficient storage. ! LENIW IUSER(18) The length of IUSER actually required. ! This is defined on normal returns and on an illegal ! input return for insufficient storage. ! NLU IUSER(19) The number of matrix LU decompositions so far. ! NNI IUSER(20) The number of nonlinear (Newton) iterations so far. ! NCFN IUSER(21) The number of convergence failures of the nonlinear ! solver so far. ! NETF IUSER(22) The number of error test failures of the integrator ! so far. ! MA28AD_CALLS IUSER(23) The number of calls made to MA28AD ! MA28BD_CALLS IUSER(24) The number of calls made to MA28BD ! MA28CD_CALLS IUSER(25) The number of calls made to MA28CD ! MC19AD_CALLS IUSER(26) The number of calls made to MC19AD ! IRNCP IUSER(27) The number of compressions done on array JAN ! ICNCP IUSER(28) The number of compressions done on array ICN ! MINIRN IUSER(29) Minimum size for JAN array ! MINICN IUSER(30) Minimum size for ICN array ! MINNZ IUSER(31) Number of nonzeros in sparse Jacobian ! JROOTS JROOTS Optional array of component indices for components ! having a zero at the current time ! ______________________________________________________________________ ! Section 8. Determining Jacobian Sparsity Structure Arrays ! ! If you are solving a problem with a sparse Jacobian, the arrays ! that define the sparsity structure are needed. The arrays may ! be determined in any of several ways. ! 1. If you choose the default mode by indicating SPARSE=.TRUE., ! the sparsity arrays will be determined internally by DVODE_F90 ! by making calls to your derivative subroutine. This mode is ! equivalent to using the integration method flag MF = 227. ! 2. The DVODE_F90 method flag MF is defined to be ! MF = 100*MOSS + 10*METH + MITER. If you supply MF = 227 (or 217), ! the sparse Jacobian will be determined using finite differences; ! and the sparsity arrays will be determined by calling your ! derivative subroutine. ! 3. If you supply MF = 126 (or 116), you must supply the Jacobian ! subroutine JAC to define the exact Jacobian. JAC must have the ! following form: ! SUBROUTINE JAC (N, T, Y, IA, JA, NZ, PD) ! Given the number of odes N, the current time T, and the current ! solution vector Y, JAC must do the following: ! - If NZ = 0 on input: ! Replace NZ by the number of nonzero elements in the Jacobian. ! The diagonal of the Jacobian must be included. ! Do NOT define the arrays IA, JA, PD at this time. ! Once JAC has been called with NZ = 0 and you have defined the ! value of NZ, future calls to JAC will use this value of NZ. ! - When a call is made with NZ unequal to 0, you must define the ! sparsity structure arrays IA and JA, and the sparse Jacobian ! PD. ! - IA defines the number of nonzeros including the diagonal ! in each column of the Jacobian. Define IA(1) = 1 and for ! J = 1,..., N, ! IA(J+1) = IA(J) + number of nonzeros in column J. ! Diagonal elements must be include even if they are zero. ! You should check to ensure that IA(N+1)-1 = NZ. ! - JA defines the rows in which the nonzeros occur. For ! I = 1,...,NZ, JA(I) is the row in which the Ith element ! of the Jacobian occurs. JA must also include the diagonal ! elements of the Jacobian. ! - PD defines the numerical value of the Jacobian elements. ! For I = 1,...,NZ, PD(I) is the numerical value of the ! Ith element in the Jacobian. PD must also include the ! diagonal elements of the Jacobian. ! 4. If you wish to supply the IA and JA arrays directly, use ! MF = 27. In this case, after calling SET_OPTS, you must call ! SET_IAJA supplying the arrays IAUSER and JAUSER described in ! the documentation prologue for SET_IAJA. These arrays will be ! used when approximate Jacobians are determined using finite ! differences. ! There are two user callable sparsity structure subroutines: ! USERSETS_IAJA may be used if you wish to supply the sparsity ! structure directly. ! SUBROUTINE USERSETS_IAJA(IAUSER,NIAUSER,JAUSER,NJAUSER) ! Caution: ! If it is called, USERSETS_IAJA must be called after the ! call to SET_OPTS. ! Usage: ! CALL SET_IAJA(IAUSER,NIAUSER,JAUSER,NJAUSER) ! In this case, IAUSER of length NIAUSER will be used for ! IA; and JAUSER of length NJAUSER will be used for JA. ! Arguments: ! IAUSER = user supplied IA array ! NIAUSER = length of IAUSER array ! JAUSER = user supplied JA vector ! NJAUSER = length of JAUSER array ! The second subroutine allows you to approximate the sparsity ! structure using derivative differences. It allows more flexibility ! in the determination of perturbation increments used. ! SUBROUTINE SET_IAJA(DFN,NEQ,T,Y,FMIN,NTURB,DTURB,IAUSER, & ! NIAUSER, JAUSER, NJAUSER) ! Caution: ! If it is called, SET_IAJA must be called after the call to ! SET_OPTS. ! Usage: ! SET_IAJA may be called in one of two ways: ! CALL SET_IAJA(DFN,NEQ,T,Y,FMIN,NTURB,DTURB) ! In this case IA and JA will be determined using calls ! to your derivative routine DFN. ! CALL SET_IAJA(DFN,NEQ,T,Y,FMIN,NTURB,DTURB,IAUSER,NIAUSER, & ! JAUSER, NJAUSER) ! In this case, IAUSER of length NIAUSER will be used for ! IA; and JAUSER of length NJAUSER will be used for JA. ! T, Y, FMIN, NTURB, and DTURB will be ignored (though ! they must be present in the argument list). ! Arguments: ! DFN = DVODE derivative subroutine ! NEQ = Number of odes ! T = independent variable t ! Y = solution y(t) ! FMIN = Jacobian threshold value. Elements of the Jacobian ! with magnitude smaller than FMIN will be ignored. ! FMIN will be ignored if it is less than or equal ! to ZERO. ! NTURB = Perturbation flag. If NTURB=1, component I of Y ! will be perturbed by 1.01D0. ! If NTURB=NEQ, component I of Y will be perturbed ! by ONE + DTURB(I). ! DTURB = perturbation vector of length 1 or NEQ. ! If these four optional parameters are present, IAUSER and JAUSER ! will be copied to IA and JA rather than making derivative calls ! to approximate IA and JA: ! IAUSER = user supplied IA array ! NIAUSER = length of IAUSER array ! JAUSER = user supplied JA vector ! NJAUSER = length of JAUSER array ! ______________________________________________________________________ ! Section 9. Original DVODE.F Documentation Prologue ! ! SUBROUTINE DVODE(F, NEQ, Y, T, TOUT, ITASK, ISTATE, OPTS, JAC, GFUN) ! DVODE: Variable-coefficient Ordinary Differential Equation solver, ! with fixed-leading-coefficient implementation. ! Note: ! Numerous changes have been made in the documentation and the code ! from the original Fortran 77 DVODE solver. With regard to the new ! F90 version, if you choose options that correspond to options ! available in the original f77 solver, you should obtain the same ! results. In all testing, identical results have been obtained ! between this version and a simple F90 translation of the original ! solver. ! DVODE solves the initial value problem for stiff or nonstiff ! systems of first order ODEs, ! dy/dt = f(t,y), or, in component form, ! dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(NEQ)) (i = 1,...,NEQ). ! DVODE is a package based on the EPISODE and EPISODEB packages, and ! on the ODEPACK user interface standard, with minor modifications. ! This version is based also on elements of LSODES and LSODAR. ! Authors: ! Peter N. Brown and Alan C. Hindmarsh ! Center for Applied Scientific Computing, L-561 ! Lawrence Livermore National Laboratory ! Livermore, CA 94551 ! George D. Byrne ! Illinois Institute of Technology ! Chicago, IL 60616 ! References: ! 1. P. N. Brown, G. D. Byrne, and A. C. Hindmarsh, "VODE: A Variable ! Coefficient ODE Solver," SIAM J. Sci. Stat. Comput., 10 (1989), ! pp. 1038-1051. Also, LLNL Report UCRL-98412, June 1988. ! 2. G. D. Byrne and A. C. Hindmarsh, "A Polyalgorithm for the ! Numerical Solution of Ordinary Differential Equations," ! ACM Trans. Math. Software, 1 (1975), pp. 71-96. ! 3. A. C. Hindmarsh and G. D. Byrne, "EPISODE: An Effective Package ! for the Integration of Systems of Ordinary Differential ! Equations," LLNL Report UCID/30112, Rev. 1, April 1977. ! 4. G. D. Byrne and A. C. Hindmarsh, "EPISODEB: An Experimental ! Package for the Integration of Systems of Ordinary Differential ! Equations with Banded Jacobians," LLNL Report UCID/30132, April ! 1976. ! 5. A. C. Hindmarsh, "ODEPACK, a Systematized Collection of ODE ! Solvers," in Scientific Computing, R. S. Stepleman et al., eds., ! North-Holland, Amsterdam, 1983, pp. 55-64. ! 6. K. R. Jackson and R. Sacks-Davis, "An Alternative Implementation ! of Variable Step-Size Multistep Formulas for Stiff ODEs," ACM ! Trans. Math. Software, 6 (1980), pp. 295-318. ! Summary of Usage ! Communication between the user and the DVODE package, for normal ! situations, is summarized here. This summary describes only a subset ! of the full set of options available. See the full description for ! details, including optional communication, nonstandard options, ! and instructions for special situations. See also the example ! problem (with program and output) following this summary. ! A. First provide a subroutine of the form: ! SUBROUTINE F(NEQ, T, Y, YDOT) ! REAL(KIND=WP) T, Y(NEQ), YDOT(NEQ) ! which supplies the vector function f by loading YDOT(i) with f(i). ! B. Next determine (or guess) whether or not the problem is stiff. ! Stiffness occurs when the Jacobian matrix df/dy has an eigenvalue ! whose real part is negative and large in magnitude, compared to the ! reciprocal of the t span of interest. If the problem is nonstiff, ! use a method flag MF = 10. If it is stiff, there are four standard ! choices for MF(21, 22, 24, 25), and DVODE requires the Jacobian ! matrix in some form. In these cases (MF > 0), DVODE will use a ! saved copy of the Jacobian matrix. If this is undesirable because of ! storage limitations, set MF to the corresponding negative value ! (-21, -22, -24, -25). (See full description of MF below.) ! The Jacobian matrix is regarded either as full (MF = 21 or 22), ! or banded (MF = 24 or 25). In the banded case, DVODE requires two ! half-bandwidth parameters ML and MU. These are, respectively, the ! widths of the lower and upper parts of the band, excluding the main ! diagonal. Thus the band consists of the locations (i,j) with ! i-ML <= j <= i+MU, and the full bandwidth is ML+MU+1. ! C. If the problem is stiff, you are encouraged to supply the Jacobian ! directly (MF = 21 or 24), but if this is not feasible, DVODE will ! compute it internally by difference quotients (MF = 22 or 25). ! If you are supplying the Jacobian, provide a subroutine of the form: ! SUBROUTINE JAC(NEQ, T, Y, ML, MU, PD, NROWPD) ! REAL(KIND=WP) T, Y(NEQ), PD(NROWPD,NEQ) ! which supplies df/dy by loading PD as follows: ! For a full Jacobian (MF = 21), load PD(i,j) with df(i)/dy(j), ! the partial derivative of f(i) with respect to y(j). (Ignore the ! ML and MU arguments in this case.) ! For a banded Jacobian (MF = 24), load PD(i-j+MU+1,j) with ! df(i)/dy(j), i.e. load the diagonal lines of df/dy into the rows of ! PD from the top down. ! In either case, only nonzero elements need be loaded. ! D. Write a main program which calls subroutine DVODE once for ! each point at which answers are desired. This should also provide ! for possible use of logical unit 6 for output of error messages ! by DVODE. On the first call to DVODE, supply arguments as follows: ! F = Name of subroutine for right-hand side vector f. ! This name must be declared external in calling program. ! NEQ = Number of first order ODEs. ! Y = Array of initial values, of length NEQ. ! T = The initial value of the independent variable. ! TOUT = First point where output is desired (/= T). ! ITOL = 1 or 2 according as ATOL(below) is a scalar or array. ! RTOL = Relative tolerance parameter (scalar). ! ATOL = Absolute tolerance parameter (scalar or array). ! The estimated local error in Y(i) will be controlled so as ! to be roughly less (in magnitude) than ! EWT(i) = RTOL*ABS(Y(i)) + ATOL if ITOL = 1, or ! EWT(i) = RTOL*ABS(Y(i)) + ATOL(i) if ITOL = 2. ! Thus the local error test passes if, in each component, ! either the absolute error is less than ATOL(or ATOL(i)), ! or the relative error is less than RTOL. ! Use RTOL = 0.0 for pure absolute error control, and ! use ATOL = 0.0 (or ATOL(i) = 0.0) for pure relative error ! control. Caution: Actual (global) errors may exceed these ! local tolerances, so choose them conservatively. ! ITASK = 1 for normal computation of output values of Y at t = TOUT. ! ISTATE = Integer flag (input and output). Set ISTATE = 1. ! IOPT = 0 to indicate no optional input used. ! JAC = Name of subroutine for Jacobian matrix (MF = 21 or 24). ! If used, this name must be declared external in calling ! program. If not used, pass a dummy name. ! MF = Method flag. Standard values are: ! 10 for nonstiff (Adams) method, no Jacobian used. ! 21 for stiff (BDF) method, user-supplied full Jacobian. ! 22 for stiff method, internally generated full Jacobian. ! 24 for stiff method, user-supplied banded Jacobian. ! 25 for stiff method, internally generated banded Jacobian. ! E. The output from the first call (or any call) is: ! Y = Array of computed values of y(t) vector. ! T = Corresponding value of independent variable (normally TOUT). ! ISTATE = 2 if DVODE was successful, negative otherwise. ! -1 means excess work done on this call. (Perhaps wrong MF.) ! -2 means excess accuracy requested. (Tolerances too small.) ! -3 means illegal input detected. (See printed message.) ! -4 means repeated error test failures. (Check all input.) ! -5 means repeated convergence failures. (Perhaps bad ! Jacobian supplied or wrong choice of MF or tolerances.) ! -6 means error weight became zero during problem. (Solution ! component I vanished, and ATOL or ATOL(I) = 0.) ! F. To continue the integration after a successful return, simply ! reset TOUT and call DVODE again. No other parameters need be reset. ! Full Description of User Interface to DVODE ! The user interface to DVODE consists of the following parts. ! i. The call sequence to subroutine DVODE, which is a driver ! routine for the solver. This includes descriptions of both ! the call sequence arguments and of user-supplied routines. ! Following these descriptions is ! * a description of optional input available through the ! call sequence, ! * a description of optional output (in the work arrays), and ! * instructions for interrupting and restarting a solution. ! ii. Descriptions of other routines in the DVODE package that may be ! (optionally) called by the user. These provide the ability to ! alter error message handling, save and restore the internal ! PRIVATE variables, and obtain specified derivatives of the ! solution y(t). ! iii. Descriptions of PRIVATE variables to be declared in overlay ! or similar environments. ! iv. Description of two routines in the DVODE package, either of ! which the user may replace with his own version, if desired. ! these relate to the measurement of errors. ! Part i. Call Sequence. ! The call sequence parameters used for input only are ! F, NEQ, TOUT, ITOL, RTOL, ATOL, ITASK, IOPT, JAC, MF, ! and those used for both input and output are ! Y, T, ISTATE. ! The work arrays RUSER and IUSER are used for conditional and ! optional input and optional output. (The term output here refers ! to the return from subroutine DVODE to the user's calling program.) ! The legality of input parameters will be thoroughly checked on the ! initial call for the problem, but not checked thereafter unless a ! change in input parameters is flagged by ISTATE = 3 in the input. ! The descriptions of the call arguments are as follows. ! F = The name of the user-supplied subroutine defining the ! ODE system. The system must be put in the first-order ! form dy/dt = f(t,y), where f is a vector-valued function ! of the scalar t and the vector y. Subroutine F is to ! compute the function f. It is to have the form ! SUBROUTINE F(NEQ, T, Y, YDOT) ! REAL(KIND=WP) T, Y(NEQ), YDOT(NEQ) ! where NEQ, T, and Y are input, and the array YDOT = f(t,y) ! is output. Y and YDOT are arrays of length NEQ. ! Subroutine F should not alter Y(1),...,Y(NEQ). ! F must be declared EXTERNAL in the calling program. ! If quantities computed in the F routine are needed ! externally to DVODE, an extra call to F should be made ! for this purpose, for consistent and accurate results. ! If only the derivative dy/dt is needed, use DVINDY instead. ! NEQ = The size of the ODE system (number of first order ! ordinary differential equations). Used only for input. ! NEQ may not be increased during the problem, but ! can be decreased (with ISTATE = 3 in the input). ! Y = A real array for the vector of dependent variables, of ! length NEQ or more. Used for both input and output on the ! first call (ISTATE = 1), and only for output on other calls. ! On the first call, Y must contain the vector of initial ! values. In the output, Y contains the computed solution ! evaluated at T. If desired, the Y array may be used ! for other purposes between calls to the solver. ! This array is passed as the Y argument in all calls to ! F and JAC. ! T = The independent variable. In the input, T is used only on ! the first call, as the initial point of the integration. ! In the output, after each call, T is the value at which a ! computed solution Y is evaluated (usually the same as TOUT). ! On an error return, T is the farthest point reached. ! TOUT = The next value of t at which a computed solution is desired. ! Used only for input. ! When starting the problem (ISTATE = 1), TOUT may be equal ! to T for one call, then should /= T for the next call. ! For the initial T, an input value of TOUT /= T is used ! in order to determine the direction of the integration ! (i.e. the algebraic sign of the step sizes) and the rough ! scale of the problem. Integration in either direction ! (forward or backward in t) is permitted. ! If ITASK = 2 or 5 (one-step modes), TOUT is ignored after ! the first call (i.e. the first call with TOUT /= T). ! Otherwise, TOUT is required on every call. ! If ITASK = 1, 3, or 4, the values of TOUT need not be ! monotone, but a value of TOUT which backs up is limited ! to the current internal t interval, whose endpoints are ! TCUR - HU and TCUR. (See optional output, below, for ! TCUR and HU.) ! ITOL = An indicator for the type of error control. See ! description below under ATOL. Used only for input. ! RTOL = A relative error tolerance parameter, either a scalar or ! an array of length NEQ. See description below under ATOL. ! Input only. ! ATOL = An absolute error tolerance parameter, either a scalar or ! an array of length NEQ. Input only. ! The input parameters ITOL, RTOL, and ATOL determine ! the error control performed by the solver. The solver will ! control the vector e = (e(i)) of estimated local errors ! in Y, according to an inequality of the form ! rms-norm of (E(i)/EWT(i)) <= 1, ! where EWT(i) = RTOL(i)*ABS(Y(i)) + ATOL(i), ! and the rms-norm (root-mean-square norm) here is ! rms-norm(v) = sqrt(sum v(i)**2 / NEQ). Here EWT ! is a vector of weights which must always be positive, and ! the values of RTOL and ATOL should all be nonnegative. ! The following table gives the types (scalar/array) of ! RTOL and ATOL, and the corresponding form of EWT(i). ! ITOL RTOL ATOL EWT(i) ! 1 scalar scalar RTOL*ABS(Y(i)) + ATOL ! 2 scalar array RTOL*ABS(Y(i)) + ATOL(i) ! 3 array scalar RTOL(i)*ABS(Y(i)) + ATOL ! 4 array array RTOL(i)*ABS(Y(i)) + ATOL(i) ! When either of these parameters is a scalar, it need not ! be dimensioned in the user's calling program. ! If none of the above choices (with ITOL, RTOL, and ATOL ! fixed throughout the problem) is suitable, more general ! error controls can be obtained by substituting ! user-supplied routines for the setting of EWT and/or for ! the norm calculation. See Part iv below. ! If global errors are to be estimated by making a repeated ! run on the same problem with smaller tolerances, then all ! components of RTOL and ATOL(i.e. of EWT) should be scaled ! down uniformly. ! ITASK = An index specifying the task to be performed. ! Input only. ITASK has the following values and meanings. ! 1 means normal computation of output values of y(t) at ! t = TOUT(by overshooting and interpolating). ! 2 means take one step only and return. ! 3 means stop at the first internal mesh point at or ! beyond t = TOUT and return. ! 4 means normal computation of output values of y(t) at ! t = TOUT but without overshooting t = TCRIT. ! TCRIT must be input as RUSER(1). TCRIT may be equal to ! or beyond TOUT, but not behind it in the direction of ! integration. This option is useful if the problem ! has a singularity at or beyond t = TCRIT. ! 5 means take one step, without passing TCRIT, and return. ! TCRIT must be input as RUSER(1). ! Note: If ITASK = 4 or 5 and the solver reaches TCRIT ! (within roundoff), it will return T = TCRIT(exactly) to ! indicate this (unless ITASK = 4 and TOUT comes before TCRIT, ! in which case answers at T = TOUT are returned first). ! ISTATE = an index used for input and output to specify the ! the state of the calculation. ! In the input, the values of ISTATE are as follows. ! 1 means this is the first call for the problem ! (initializations will be done). See note below. ! 2 means this is not the first call, and the calculation ! is to continue normally, with no change in any input ! parameters except possibly TOUT and ITASK. ! (If ITOL, RTOL, and/or ATOL are changed between calls ! with ISTATE = 2, the new values will be used but not ! tested for legality.) ! 3 means this is not the first call, and the ! calculation is to continue normally, but with ! a change in input parameters other than ! TOUT and ITASK. Changes are allowed in ! NEQ, ITOL, RTOL, ATOL, IOPT, MF, ML, MU, ! and any of the optional input except H0. ! (See IUSER description for ML and MU.) ! Caution: ! If you make a call to DVODE_F90 with ISTATE=3, you will ! first need to call SET_OPTS again, supplying the new ! necessary option values. ! Note: A preliminary call with TOUT = T is not counted ! as a first call here, as no initialization or checking of ! input is done. (Such a call is sometimes useful to include ! the initial conditions in the output.) ! Thus the first call for which TOUT /= T requires ! ISTATE = 1 in the input. ! In the output, ISTATE has the following values and meanings. ! 1 means nothing was done, as TOUT was equal to T with ! ISTATE = 1 in the input. ! 2 means the integration was performed successfully. ! -1 means an excessive amount of work (more than MXSTEP ! steps) was done on this call, before completing the ! requested task, but the integration was otherwise ! successful as far as T. (MXSTEP is an optional input ! and is normally 5000.) To continue, the user may ! simply reset ISTATE to a value > 1 and call again. ! (The excess work step counter will be reset to 0.) ! In addition, the user may increase MXSTEP to avoid ! this error return. (See optional input below.) ! -2 means too much accuracy was requested for the precision ! of the machine being used. This was detected before ! completing the requested task, but the integration ! was successful as far as T. To continue, the tolerance ! parameters must be reset, and ISTATE must be set ! to 3. The optional output TOLSF may be used for this ! purpose. (Note: If this condition is detected before ! taking any steps, then an illegal input return ! (ISTATE = -3) occurs instead.) ! -3 means illegal input was detected, before taking any ! integration steps. See written message for details. ! Note: If the solver detects an infinite loop of calls ! to the solver with illegal input, it will cause ! the run to stop. ! -4 means there were repeated error test failures on ! one attempted step, before completing the requested ! task, but the integration was successful as far as T. ! The problem may have a singularity, or the input ! may be inappropriate. ! -5 means there were repeated convergence test failures on ! one attempted step, before completing the requested ! task, but the integration was successful as far as T. ! This may be caused by an inaccurate Jacobian matrix, ! if one is being used. ! -6 means EWT(i) became zero for some i during the ! integration. Pure relative error control (ATOL(i)=0.0) ! was requested on a variable which has now vanished. ! The integration was successful as far as T. ! Note: Since the normal output value of ISTATE is 2, ! it does not need to be reset for normal continuation. ! Also, since a negative input value of ISTATE will be ! regarded as illegal, a negative output value requires the ! user to change it, and possibly other input, before ! calling the solver again. ! IOPT = An integer flag to specify whether or not any optional ! input is being used on this call. Input only. ! The optional input is listed separately below. ! IOPT = 0 means no optional input is being used. ! Default values will be used in all cases. ! IOPT = 1 means optional input is being used. ! RUSER = A real working array (real(wp)). ! The length of RUSER must be at least 22 ! 20 + NYH * (MAXORD + 1) where ! NYH = the initial value of NEQ, ! MAXORD = 12 (if METH = 1) or 5 (if METH = 2) (unless a ! smaller value is given as an optional input), ! The first 22 words of RUSER are reserved for conditional ! and optional input and optional output. ! The following word in RUSER is a conditional input: ! RUSER(1) = TCRIT = critical value of t which the solver ! is not to overshoot. Required if ITASK is ! 4 or 5, and ignored otherwise. (See ITASK.) ! IUSER = An integer work array. The length of IUSER must be at least 30. ! 30 if MITER = 0 or 3 (MF = 10, 13, 20, 23), or ! 30 + NEQ otherwise (ABS(MF) = 11,12,14,15,16,17,21,22, ! 24,25,26,27). ! The first 30 words of IUSER are reserved for conditional and ! optional input and optional output. ! The following 2 words in IUSER are conditional input: ! IUSER(1) = ML These are the lower and upper ! IUSER(2) = MU half-bandwidths, respectively, of the ! banded Jacobian, excluding the main diagonal. ! The band is defined by the matrix locations ! (i,j) with i-ML <= j <= i+MU. ML and MU ! must satisfy 0 <= ML,MU <= NEQ-1. ! These are required if MITER is 4 or 5, and ! ignored otherwise. ML and MU may in fact be ! the band parameters for a matrix to which ! df/dy is only approximately equal. ! Note: The work arrays must not be altered between calls to DVODE ! for the same problem, except possibly for the conditional and ! optional input, and except for the last 3*NEQ words of RUSER. ! The latter space is used for internal scratch space, and so is ! available for use by the user outside DVODE between calls, if ! desired (but not for use by F or JAC). ! JAC = The name of the user-supplied routine (MITER = 1 or 4 or 6) ! to compute the Jacobian matrix, df/dy, as a function of ! the scalar t and the vector y. It is to have the form ! SUBROUTINE JAC(NEQ, T, Y, ML, MU, PD, NROWPD) ! REAL(KIND=WP) T, Y(NEQ), PD(NROWPD,NEQ) ! where NEQ, T, Y, ML, MU, and NROWPD are input and the array ! PD is to be loaded with partial derivatives (elements of the ! Jacobian matrix) in the output. PD must be given a first ! dimension of NROWPD. T and Y have the same meaning as in ! Subroutine F. ! In the full matrix case (MITER = 1), ML and MU are ! ignored, and the Jacobian is to be loaded into PD in ! columnwise manner, with df(i)/dy(j) loaded into PD(i,j). ! In the band matrix case (MITER = 4), the elements ! within the band are to be loaded into PD in columnwise ! manner, with diagonal lines of df/dy loaded into the rows ! of PD. Thus df(i)/dy(j) is to be loaded into PD(i-j+MU+1,j). ! ML and MU are the half-bandwidth parameters. (See IUSER). ! The locations in PD in the two triangular areas which ! correspond to nonexistent matrix elements can be ignored ! or loaded arbitrarily, as they are overwritten by DVODE. ! In the sparse matrix case the elements of the matrix ! are determined by the sparsity structure given by the ! IA and JA pointer arrays. Refer to the documentation ! prologue for SET_OPTS for a description of the arguments ! for JAC since they differ from the dense and banded cases. ! JAC need not provide df/dy exactly. A crude ! approximation (possibly with a smaller bandwidth) will do. ! In either case, PD is preset to zero by the solver, ! so that only the nonzero elements need be loaded by JAC. ! Each call to JAC is preceded by a call to F with the same ! arguments NEQ, T, and Y. Thus to gain some efficiency, ! intermediate quantities shared by both calculations may be ! saved in a user common block by F and not recomputed by JAC, ! if desired. Also, JAC may alter the Y array, if desired. ! JAC must be declared external in the calling program. ! MF = The method flag. Used only for input. The legal values of ! MF are 10, 11, 12, 13, 14, 15, 16, 17, 20, 21, 22, 23, 24, ! 25, 26, 27, -11, -12, -14, -15, -21, -22, -24, -25, -26, ! -27. ! MF is a signed two-digit integer, MF = JSV*(10*METH+MITER). ! JSV = SIGN(MF) indicates the Jacobian-saving strategy: ! JSV = 1 means a copy of the Jacobian is saved for reuse ! in the corrector iteration algorithm. ! JSV = -1 means a copy of the Jacobian is not saved ! (valid only for MITER = 1, 2, 4, or 5). ! METH indicates the basic linear multistep method: ! METH = 1 means the implicit Adams method. ! METH = 2 means the method based on backward ! differentiation formulas (BDF-s). ! MITER indicates the corrector iteration method: ! MITER = 0 means functional iteration (no Jacobian matrix ! is involved). ! MITER = 1 means chord iteration with a user-supplied ! full (NEQ by NEQ) Jacobian. ! MITER = 2 means chord iteration with an internally ! generated (difference quotient) full Jacobian ! (using NEQ extra calls to F per df/dy value). ! MITER = 3 means chord iteration with an internally ! generated diagonal Jacobian approximation ! (using 1 extra call to F per df/dy evaluation). ! MITER = 4 means chord iteration with a user-supplied ! banded Jacobian. ! MITER = 5 means chord iteration with an internally ! generated banded Jacobian (using ML+MU+1 extra ! calls to F per df/dy evaluation). ! MITER = 6 means chord iteration with a user-supplied ! sparse Jacobian. ! MITER = 7 means chord iteration with an internally ! generated sparse Jacobian ! If MITER = 1, 4, or 6 the user must supply a subroutine ! JAC(the name is arbitrary) as described above under JAC. ! For other values of MITER, a dummy argument can be used. ! Optional Input ! The following is a list of the optional input provided for in the ! call sequence. (See also Part ii.) For each such input variable, ! this table lists its name as used in this documentation, its ! location in the call sequence, its meaning, and the default value. ! The use of any of this input requires IOPT = 1, and in that ! case all of this input is examined. A value of zero for any of ! these optional input variables will cause the default value to be ! used. Thus to use a subset of the optional input, simply preload ! locations 5 to 10 in RUSER and IUSER to 0.0 and 0, respectively, ! and then set those of interest to nonzero values. ! NAME LOCATION MEANING AND DEFAULT VALUE ! H0 RUSER(5) The step size to be attempted on the first step. ! The default value is determined by the solver. ! HMAX RUSER(6) The maximum absolute step size allowed. ! The default value is infinite. ! HMIN RUSER(7) The minimum absolute step size allowed. ! The default value is 0. (This lower bound is not ! enforced on the final step before reaching TCRIT ! when ITASK = 4 or 5.) ! MAXORD IUSER(5) The maximum order to be allowed. The default ! value is 12 if METH = 1, and 5 if METH = 2. ! If MAXORD exceeds the default value, it will ! be reduced to the default value. ! If MAXORD is changed during the problem, it may ! cause the current order to be reduced. ! MXSTEP IUSER(6) Maximum number of (internally defined) steps ! allowed during one call to the solver. ! The default value is 5000. ! MXHNIL IUSER(7) Maximum number of messages printed (per problem) ! warning that T + H = T on a step (H = step size). ! This must be positive to result in a non-default ! value. The default value is 10. ! Optional Output ! As optional additional output from DVODE, the variables listed ! below are quantities related to the performance of DVODE ! which are available to the user. These are communicated by way of ! the work arrays, but also have internal mnemonic names as shown. ! Except where stated otherwise, all of this output is defined ! on any successful return from DVODE, and on any return with ! ISTATE = -1, -2, -4, -5, or -6. On an illegal input return ! (ISTATE = -3), they will be unchanged from their existing values ! (if any), except possibly for TOLSF, LENRW, and LENIW. ! On any error return, output relevant to the error will be defined, ! as noted below. ! NAME LOCATION MEANING ! HU RUSER(11) The step size in t last used (successfully). ! HCUR RUSER(12) The step size to be attempted on the next step. ! TCUR RUSER(13) The current value of the independent variable ! which the solver has actually reached, i.e. the ! current internal mesh point in t. In the output, ! TCUR will always be at least as far from the ! initial value of t as the current argument T, ! but may be farther (if interpolation was done). ! TOLSF RUSER(14) A tolerance scale factor, greater than 1.0, ! computed when a request for too much accuracy was ! detected (ISTATE = -3 if detected at the start of ! the problem, ISTATE = -2 otherwise). If ITOL is ! left unaltered but RTOL and ATOL are uniformly ! scaled up by a factor of TOLSF for the next call, ! then the solver is deemed likely to succeed. ! (The user may also ignore TOLSF and alter the ! tolerance parameters in any other way appropriate.) ! NST IUSER(11) The number of steps taken for the problem so far. ! NFE IUSER(12) The number of f evaluations for the problem so far. ! NJE IUSER(13) The number of Jacobian evaluations so far. ! NQU IUSER(14) The method order last used (successfully). ! NQCUR IUSER(15) The order to be attempted on the next step. ! IMXER IUSER(16) The index of the component of largest magnitude in ! the weighted local error vector (e(i)/EWT(i)), ! on an error return with ISTATE = -4 or -5. ! LENRW IUSER(17) The length of RUSER actually required. ! This is defined on normal returns and on an illegal ! input return for insufficient storage. ! LENIW IUSER(18) The length of IUSER actually required. ! This is defined on normal returns and on an illegal ! input return for insufficient storage. ! NLU IUSER(19) The number of matrix LU decompositions so far. ! NNI IUSER(20) The number of nonlinear (Newton) iterations so far. ! NCFN IUSER(21) The number of convergence failures of the nonlinear ! solver so far. ! NETF IUSER(22) The number of error test failures of the integrator ! so far. ! The following two arrays are segments of the RUSER array which ! may also be of interest to the user as optional output. ! For each array, the table below gives its internal name, ! its base address in RUSER, and its description. ! Interrupting and Restarting ! If the integration of a given problem by DVODE is to be interrupted ! and then later continued, such as when restarting an interrupted run ! or alternating between two or more ODE problems, the user should save, ! following the return from the last DVODE call prior to the ! interruption, the contents of the call sequence variables and ! internal PRIVATE variables, and later restore these values before the ! next DVODE call for that problem. To save and restore the PRIVATE ! variables, use subroutine DVSRCO, as described below in part ii. ! In addition, if non-default values for either LUN or MFLAG are ! desired, an extra call to XSETUN and/or XSETF should be made just ! before continuing the integration. See Part ii below for details. ! Part ii. Other Routines Callable. ! The following are optional calls which the user may make to ! gain additional capabilities in conjunction with DVODE. ! (The routines XSETUN and XSETF are designed to conform to the ! SLATEC error handling package.) ! FORM OF CALL FUNCTION ! CALL XSETUN(LUN) Set the logical unit number, LUN, for ! output of messages from DVODE, if ! the default is not desired. ! The default value of LUN is 6. ! CALL XSETF(MFLAG) Set a flag to control the printing of ! messages by DVODE. ! MFLAG = 0 means do not print. (Danger: ! This risks losing valuable information.) ! Either of the above calls may be made at ! any time and will take effect immediately. ! CALL DVINDY(...) Provide derivatives of y, of various ! orders, at a specified point T, if ! desired. It may be called only after ! a successful return from DVODE. ! The detailed instructions for using DVINDY are as follows. ! The form of the call is: ! CALL DVINDY(T,K,DKY,IFLAG) ! The input parameters are: ! T = Value of independent variable where answers are desired ! (normally the same as the T last returned by DVODE). ! For valid results, T must lie between TCUR - HU and TCUR. ! (See optional output for TCUR and HU.) ! K = Integer order of the derivative desired. K must satisfy ! 0 <= K <= NQCUR, where NQCUR is the current order ! (see optional output). The capability corresponding ! to K = 0, i.e. computing y(T), is already provided ! by DVODE directly. Since NQCUR >= 1, the first ! derivative dy/dt is always available with DVINDY. ! The output parameters are: ! DKY = A real array of length NEQ containing the computed value ! of the K-th derivative of y(t). ! IFLAG = Integer flag, returned as 0 if K and T were legal, ! -1 if K was illegal, and -2 if T was illegal. ! On an error return, a message is also written. ! Part iii. Optionally Replaceable Solver Routines. ! Below are descriptions of two routines in the DVODE package which ! relate to the measurement of errors. Either routine can be ! replaced by a user-supplied version, if desired. However, since such ! a replacement may have a major impact on performance, it should be ! done only when absolutely necessary, and only with great caution. ! (Note: The means by which the package version of a routine is ! superseded by the user's version may be system-dependent.) ! (a) DEWSET. ! The following subroutine is called just before each internal ! integration step, and sets the array of error weights, EWT, as ! described under ITOL/RTOL/ATOL above: ! SUBROUTINE DEWSET(NEQ, ITOL, RTOL, ATOL, YCUR, EWT) ! where NEQ, ITOL, RTOL, and ATOL are as in the DVODE call sequence, ! YCUR contains the current dependent variable vector, and ! EWT is the array of weights set by DEWSET. ! If the user supplies this subroutine, it must return in EWT(i) ! (i = 1,...,NEQ) a positive quantity suitable for comparison with ! errors in Y(i). The EWT array returned by DEWSET is passed to the ! DVNORM function (See below.), and also used by DVODE in the ! computation of the optional output IMXER, the diagonal Jacobian ! approximation, and the increments for difference quotient Jacobians. ! In the user-supplied version of DEWSET, it may be desirable to use ! the current values of derivatives of y. Derivatives up to order NQ ! are available from the history array YH, described above under ! Optional Output. In DEWSET, YH is identical to the YCUR array, ! extended to NQ + 1 columns with a column length of NYH and scale ! factors of h**j/factorial(j). On the first call for the problem, ! given by NST = 0, NQ is 1 and H is temporarily set to 1.0. ! NYH is the initial value of NEQ. Thus, for example, the current ! value of dy/dt can be obtained as YCUR(NYH+i)/H (i=1,...,NEQ) ! (and the division by H is unnecessary when NST = 0). ! (b) DVNORM. ! The following is a function which computes the weighted ! root-mean-square norm of a vector v: ! D = DVNORM(N, V, W) ! where: ! N = the length of the vector, ! V = real array of length N containing the vector, ! W = real array of length N containing weights, ! D = sqrt((1/N) * sum(V(i)*W(i))**2). ! DVNORM is called with N = NEQ and with W(i) = 1.0/EWT(i), where ! EWT is as set by subroutine DEWSET. ! If the user supplies this routine, it should return a nonnegative ! value of DVNORM suitable for use in the error control in DVODE. ! None of the arguments should be altered by DVNORM. ! For example, a user-supplied DVNORM function might: ! -substitute a max-norm of (V(i)*W(i)) for the rms-norm, or ! -ignore some components of V in the norm, with the effect of ! suppressing the error control on those components of Y. !_______________________________________________________________________ ! Other Routines in the DVODE Package ! In addition to subroutine DVODE, the DVODE package includes the ! following subroutines and function routines (not user callable): ! DVHIN computes an approximate step size for the initial step. ! DVINDY_CORE computes an interpolated value of the y vector at t=TOUT. ! DVINDY computes an interpolated value of the y vector at t=TOUT. ! (user callable) ! DVSTEP is the core integrator, which does one step of the ! integration and the associated error control. ! DVSET sets all method coefficients and test constants. ! DVNLSD, solves the underlying nonlinear system -- the corrector. ! DVNLSS28 ! DVJAC, computes and preprocesses the Jacobian matrix J = df/dy ! DVJACS28 and the Newton iteration matrix P = I - (h/l1)*J. ! DVSOL, manages solution of linear system in chord iteration. ! DVSOLS28 ! DVJUST adjusts the history array on a change of order. ! DEWSET sets the error weight vector EWT before each step. ! DVNORM computes the weighted r.m.s. norm of a vector. ! DACOPY is a routine to copy a two-dimensional array to another. ! DGEFA_F90 and DGESL_F90 are routines from LINPACK for solving full ! systems of linear algebraic equations. ! DGBFA_F90 and DGBSL_F90 are routines from LINPACK for solving banded ! linear systems. ! DAXPY_F90, DSCAL_F90, and DCOPY_F90 are basic linear algebra modules ! (BLAS). ! DVCHECK does preliminary checking for roots, and serves as an ! interface between subroutine DVODE_F90 and subroutine ! DVROOTS. ! DVROOTS finds the leftmost root of a set of functions. ! ______________________________________________________________________ ! Section 10. Example Usage ! ! MODULE example1 ! The following is a simple example problem, with the coding ! needed for its solution by DVODE_F90. The problem is from ! chemical kinetics, and consists of the following three rate ! equations: ! dy1/dt = -.04d0*y1 + 1.d4*y2*y3 ! dy2/dt = .04d0*y1 - 1.d4*y2*y3 - 3.d7*y2**2 ! dy3/dt = 3.d7*y2**2 ! on the interval from t = 0.0d0 to t = 4.d10, with initial ! conditions y1 = 1.0d0, y2 = y3 = 0.0d0. The problem is stiff. ! The following coding solves this problem with DVODE_F90, ! using a user supplied Jacobian and printing results at ! t = .4, 4.,...,4.d10. It uses ITOL = 2 and ATOL much smaller ! for y2 than y1 or y3 because y2 has much smaller values. At ! the end of the run, statistical quantities of interest are ! printed. (See optional output in the full DVODE description ! below.) Output is written to the file example1.dat. ! CONTAINS ! SUBROUTINE FEX(NEQ, T, Y, YDOT) ! IMPLICIT NONE ! INTEGER NEQ ! DOUBLE PRECISION T, Y, YDOT ! DIMENSION Y(NEQ), YDOT(NEQ) ! YDOT(1) = -.04D0*Y(1) + 1.D4*Y(2)*Y(3) ! YDOT(3) = 3.E7*Y(2)*Y(2) ! YDOT(2) = -YDOT(1) - YDOT(3) ! RETURN ! END SUBROUTINE FEX ! SUBROUTINE JEX(NEQ, T, Y, ML, MU, PD, NRPD) ! IMPLICIT NONE ! INTEGER NEQ,ML,MU,NRPD ! DOUBLE PRECISION PD, T, Y ! DIMENSION Y(NEQ), PD(NRPD,NEQ) ! PD(1,1) = -.04D0 ! PD(1,2) = 1.D4*Y(3) ! PD(1,3) = 1.D4*Y(2) ! PD(2,1) = .04D0 ! PD(2,3) = -PD(1,3) ! PD(3,2) = 6.E7*Y(2) ! PD(2,2) = -PD(1,2) - PD(3,2) ! RETURN ! END SUBROUTINE JEX ! END MODULE example1 !****************************************************************** ! PROGRAM runexample1 ! USE DVODE_F90_M ! USE example1 ! IMPLICIT NONE ! DOUBLE PRECISION ATOL, RTOL, T, TOUT, Y, RSTATS ! INTEGER NEQ, ITASK, ISTATE, ISTATS, IOUT, IERROR, I ! DIMENSION Y(3), ATOL(3), RSTATS(22), ISTATS(31) ! TYPE(VODE_OPTS) :: OPTIONS ! OPEN(UNIT=6, FILE = 'example1.dat') ! IERROR = 0 ! NEQ = 3 ! Y(1) = 1.0D0 ! Y(2) = 0.0D0 ! Y(3) = 0.0D0 ! T = 0.0D0 ! TOUT = 0.4D0 ! RTOL = 1.D-4 ! ATOL(1) = 1.D-8 ! ATOL(2) = 1.D-14 ! ATOL(3) = 1.D-6 ! ITASK = 1 ! ISTATE = 1 ! OPTIONS = SET_OPTS(DENSE_J=.TRUE.,ABSERR_VECTOR=ATOL, & ! RELERR=RTOL, USER_SUPPLIED_JACOBIAN=.TRUE.) ! DO IOUT = 1,12 ! CALL DVODE_F90(FEX,NEQ,Y,T,TOUT,ITASK,ISTATE,OPTIONS,J_FCN=JEX) ! CALL GET_STATS(RSTATS,ISTATS) ! WRITE(6,63)T,Y(1),Y(2),Y(3) ! DO I = 1, NEQ ! IF (Y(I) < 0.0D0) IERROR = 1 ! END DO ! IF (ISTATE < 0) THEN ! WRITE(6,64)ISTATE ! STOP ! END IF ! TOUT = TOUT*10.0D0 ! END DO ! WRITE(6,60) ISTATS(11),ISTATS(12),ISTATS(13),ISTATS(19), & ! ISTATS(20),ISTATS(21),ISTATS(22) ! IF (IERROR == 1) THEN ! WRITE(6,61) ! ELSE ! WRITE(6,62) ! END IF ! 60 FORMAT(/' No. steps =',I4,' No. f-s =',I4, & ! ' No. J-s =',I4,' No. LU-s =',I4/ & ! ' No. nonlinear iterations =',I4/ & ! ' No. nonlinear convergence failures =',I4/ & ! ' No. error test failures =',I4/) ! 61 FORMAT(/' An error occurred.') ! 62 FORMAT(/' No errors occurred.') ! 63 FORMAT(' At t =',D12.4,' y =',3D14.6) ! 64 FORMAT(///' Error halt: ISTATE =',I3) ! STOP ! END PROGRAM runexample1 ! ! MODULE example2 ! The following is a modification of the previous example ! program to illustrate root finding. The problem is from ! chemical kinetics, and consists of the following three ! rate equations: ! dy1/dt = -.04d0*y1 + 1.d4*y2*y3 ! dy2/dt = .04d0*y1 - 1.d4*y2*y3 - 3.d7*y2**2 ! dy3/dt = 3.d7*y2**2 ! on the interval from t = 0.0d0 to t = 4.d10, with initial ! conditions y1 = 1.0d0, y2 = y3 = 0.0d0. The problem is stiff. ! In addition, we want to find the values of t, y1, y2, ! and y3 at which: ! (1) y1 reaches the value 1.d-4, and ! (2) y3 reaches the value 1.d-2. ! The following coding solves this problem with DVODE_F90 ! using an internally generated dense Jacobian and ! printing results at t = .4, 4., ..., 4.d10, and at the ! computed roots. It uses ITOL = 2 and ATOL much smaller ! for y2 than y1 or y3 because y2 has much smaller values. ! At the end of the run, statistical quantities of interest ! are printed (see optional outputs in the full description ! below). Output is written to the file example2.dat. ! CONTAINS ! SUBROUTINE FEX (NEQ, T, Y, YDOT) ! IMPLICIT NONE ! INTEGER NEQ ! DOUBLE PRECISION T, Y, YDOT ! DIMENSION Y(3), YDOT(3) ! YDOT(1) = -0.04D0*Y(1) + 1.0D4*Y(2)*Y(3) ! YDOT(3) = 3.0D7*Y(2)*Y(2) ! YDOT(2) = -YDOT(1) - YDOT(3) ! RETURN ! END SUBROUTINE FEX ! SUBROUTINE GEX (NEQ, T, Y, NG, GOUT) ! IMPLICIT NONE ! INTEGER NEQ, NG ! DOUBLE PRECISION T, Y, GOUT ! DIMENSION Y(3), GOUT(2) ! GOUT(1) = Y(1) - 1.0D-4 ! GOUT(2) = Y(3) - 1.0D-2 ! RETURN ! END SUBROUTINE GEX ! END MODULE example2 !****************************************************************** ! PROGRAM runexample2 ! USE DVODE_F90_M ! USE example2 ! IMPLICIT NONE ! INTEGER ITASK, ISTATE, NG, NEQ, IOUT, JROOT, ISTATS, & ! IERROR, I ! DOUBLE PRECISION ATOL, RTOL, RSTATS, T, TOUT, Y ! DIMENSION Y(3), ATOL(3), RSTATS(22), ISTATS(31), JROOT(2) ! TYPE(VODE_OPTS) :: OPTIONS ! OPEN (UNIT=6, FILE='example2.dat') ! IERROR = 0 ! NEQ = 3 ! Y(1) = 1.0D0 ! Y(2) = 0.0D0 ! Y(3) = 0.0D0 ! T = 0.0D0 ! TOUT = 0.4D0 ! RTOL = 1.0D-4 ! ATOL(1) = 1.0D-8 ! ATOL(2) = 1.0D-12 ! ATOL(3) = 1.0D-8 ! ITASK = 1 ! ISTATE = 1 ! NG = 2 ! OPTIONS = SET_OPTS(DENSE_J=.TRUE.,RELERR=RTOL, & ! ABSERR_VECTOR=ATOL,NEVENTS=NG) ! DO 40 IOUT = 1,12 ! 10 CONTINUE ! CALL DVODE_F90(FEX,NEQ,Y,T,TOUT,ITASK,ISTATE,OPTIONS,G_FCN=GEX) ! CALL GET_STATS(RSTATS, ISTATS, NG, JROOT) ! WRITE(6,20) T, Y(1), Y(2), Y(3) ! DO I = 1, NEQ ! IF (Y(I) < 0.0D0) IERROR = 1 ! END DO ! 20 FORMAT(' At t =',D12.4,' Y =',3D14.6) ! IF (ISTATE < 0) GOTO 60 ! IF (ISTATE == 2) GOTO 40 ! WRITE(6,30) JROOT(1),JROOT(2) ! 30 FORMAT(5X,' The above line is a root, JROOT =',2I5) ! ISTATE = 2 ! GOTO 10 ! 40 TOUT = TOUT*10.0D0 ! WRITE(6,50) ISTATS(11), ISTATS(12), ISTATS(13), ISTATS(10) ! IF (IERROR == 1) THEN ! WRITE(6,61) ! ELSE ! WRITE(6,62) ! END IF ! 50 FORMAT(/' No. steps =',I4,' No. f-s =',I4,' No. J-s =',I4, & ! ' No. g-s =',I4/) ! STOP ! 60 WRITE(6,70) ISTATE ! 61 FORMAT(/' An error occurred.') ! 62 FORMAT(/' No errors occurred.') ! 70 FORMAT(///' Error halt.. ISTATE =',I3) ! STOP ! END PROGRAM runexample2 !_______________________________________________________________________ ! BEGINNING OF DVODE_F90_M PRIVATE SECTION. ! Note: This global information is used throughout DVODE_F90. !_______________________________________________________________________ ! JACSPDB arrays and parameters. LOGICAL, PRIVATE :: USE_JACSP, LIKE_ORIGINAL_VODE INTEGER, PRIVATE :: INFODS, LIWADS, MAXGRPDS, MINGRPDS, NRFJACDS, & NCFJACDS, LWKDS, LIWKDS INTEGER, ALLOCATABLE, PRIVATE :: INDROWDS(:), INDCOLDS(:), & NGRPDS(:), IPNTRDS(:), JPNTRDS(:), IWADS(:), IWKDS(:), IOPTDS(:) KPP_REAL, ALLOCATABLE, PRIVATE :: YSCALEDS(:), WKDS(:), FACDS(:) KPP_REAL, PRIVATE :: U125, U325 !_______________________________________________________________________ LOGICAL, PARAMETER, PRIVATE :: USE_MA48_FOR_SPARSE=.FALSE. !_______________________________________________________________________ ! *****MA48 build change point. Replace the above statement. ! LOGICAL, PARAMETER, PRIVATE :: USE_MA48_FOR_SPARSE=.TRUE. !_______________________________________________________________________ ! *****MA48 build change point. Insert these statements. ! MA48 type declarations: ! TYPE(ZD01_TYPE) MATRIX ! TYPE(MA48_CONTROL) CONTROL ! TYPE(MA48_FACTORS) FACTORS ! TYPE(MA48_AINFO) AINFO ! TYPE(MA48_FINFO) FINFO ! TYPE(MA48_SINFO) SINFO !_______________________________________________________________________ ! .. Parameters .. ! IPCUTH_MAX - maximum number of times the solver will halve the ! stepsize to prevent an infeasible prediction if ! solution bounds are used ! KFC - maximum number of consecutive convergence failures ! before crashing the order ! KFH - maximum number of consecutive error test failures ! before giving up (changed from 7 to 15) ! MAXCOR - maximum number of corrections ! MSBP - maximum number of steps before forming new P matrix ! MXNCF - maximum number of consecutive convergence failures ! before giving up ! MXHNLO - maximum number of T+H=T messages ! MXSTP0 - maximum number of integration steps ! L***** - lengths and pointers for some internal arrays ! INTEGER, PARAMETER, PRIVATE :: KFC = -3, KFH = -7, LENIV1 = 33, & INTEGER, PARAMETER, PRIVATE :: IPCUTH_MAX = 100, KFC = -3, & KFH = -15, LENIV1 = 33, & LENIV2 = 8, LENRV1 = 48, LENRV2 = 1, LIWUSER = 30, LRWUSER = 22, & MAXCOR = 3, MAX_ARRAY_SIZE = 900000000, MSBP = 20, MXHNL0 = 10, & MXNCF = 10, MXSTP0 = 5000 !_______________________________________________________________________ ! *****LAPACK build change point. Use .TRUE. for LAPACK. ! LOGICAL, PARAMETER, PRIVATE :: USE_LAPACK = .TRUE. !_______________________________________________________________________ KPP_REAL, PARAMETER, PRIVATE :: ADDON = 1.0E-6_dp KPP_REAL, PARAMETER, PRIVATE :: BIAS1 = 6.0_dp KPP_REAL, PARAMETER, PRIVATE :: BIAS2 = 6.0_dp KPP_REAL, PARAMETER, PRIVATE :: BIAS3 = 10.0_dp KPP_REAL, PARAMETER, PRIVATE :: CCMAX = 0.3_dp KPP_REAL, PARAMETER, PRIVATE :: CORTES = 0.1_dp KPP_REAL, PARAMETER, PRIVATE :: CRDOWN = 0.3_dp KPP_REAL, PARAMETER, PRIVATE :: ETACF = 0.25_dp KPP_REAL, PARAMETER, PRIVATE :: ETAMIN = 0.1_dp KPP_REAL, PARAMETER, PRIVATE :: ETAMX1 = 1.0E4_dp KPP_REAL, PARAMETER, PRIVATE :: ETAMX2 = 10.0_dp KPP_REAL, PARAMETER, PRIVATE :: ETAMX3 = 10.0_dp KPP_REAL, PARAMETER, PRIVATE :: ETAMXF = 0.2_dp KPP_REAL, PARAMETER, PRIVATE :: FIVE = 5.0_dp KPP_REAL, PARAMETER, PRIVATE :: FOUR = 4.0_dp KPP_REAL, PARAMETER, PRIVATE :: HALF = 0.5_dp KPP_REAL, PARAMETER, PRIVATE :: HUN = 100.0_dp KPP_REAL, PARAMETER, PRIVATE :: HUNDRETH = 0.01_dp KPP_REAL, PARAMETER, PRIVATE :: ONE = 1.0_dp KPP_REAL, PARAMETER, PRIVATE :: ONEPSM = 1.00001_dp KPP_REAL, PARAMETER, PRIVATE :: PT1 = 0.1_dp KPP_REAL, PARAMETER, PRIVATE :: PT2 = 0.2_dp KPP_REAL, PARAMETER, PRIVATE :: RDIV = 2.0_dp KPP_REAL, PARAMETER, PRIVATE :: SIX = 6.0_dp KPP_REAL, PARAMETER, PRIVATE :: TEN = 10.0_dp KPP_REAL, PARAMETER, PRIVATE :: TENTH = 0.1_dp KPP_REAL, PARAMETER, PRIVATE :: THOU = 1000.0_dp KPP_REAL, PARAMETER, PRIVATE :: THRESH = 1.5_dp KPP_REAL, PARAMETER, PRIVATE :: TWO = 2.0_dp KPP_REAL, PARAMETER, PRIVATE :: ZERO = 0.0_dp ! Beginning of DVODE_F90 interface. ! .. ! .. Generic Interface Blocks .. INTERFACE DVODE_F90 ! VODE_F90 is the interface subroutine that is actually invoked ! when the user calls DVODE_F90. It in turn calls subroutine ! DVODE which is the driver that directs all the work. MODULE PROCEDURE VODE_F90 ! GET_STATS can be called to gather integration statistics. MODULE PROCEDURE GET_STATS ! DVINDY can be called to interpolate the solution and derivative. MODULE PROCEDURE DVINDY ! RELEASE_ARRAYS can be called to release/deallocate the work arrays. MODULE PROCEDURE RELEASE_ARRAYS ! SET_IAJA can be called to set sparse matrix descriptor arrays. MODULE PROCEDURE SET_IAJA ! USERSETS_IAJA can be called to set sparse matrix descriptor arrays. MODULE PROCEDURE USERSETS_IAJA ! CHECK_STAT can be called to stop if a storage allocation or ! deallocation error occurs. MODULE PROCEDURE CHECK_STAT ! JACSP can be called to calculate a Jacobian using Doug Salane's ! algoritm MODULE PROCEDURE JACSP ! DVDSM can be called to calculate sparse pointer arrays needed ! by JACSP MODULE PROCEDURE DVDSM END INTERFACE ! .. ! .. Derived Type Declarations .. TYPE, PUBLIC :: VODE_OPTS KPP_REAL, DIMENSION (:), POINTER :: ATOL, RTOL INTEGER :: MF, METH, MITER, MOSS, ITOL, IOPT, NG LOGICAL :: DENSE, BANDED, SPARSE END TYPE VODE_OPTS ! .. ! .. Local Scalars .. !_______________________________________________________________________ ! *****MA48 build change point. Insert these statements. ! For communication with subroutine ma48_control_array: ! KPP_REAL, PUBLIC :: COPY_OF_U_PIVOT !_______________________________________________________________________ KPP_REAL, PRIVATE :: ACNRM, ALPHA, BIG, BIG1, CCMXJ, CGCE, CONP, CRATE, & DRC, DRES, DXMAX, EPS, ERRMAX, ETA, ETAMAX, FRACINT, FRACSUB, H, HMIN, & HMXI, HNEW, HSCAL, HU, MEPS, MRESID, MRMIN, PRL1, RC, RESID, RL1, & RMIN, SETH, T0ST, THEMAX, TLAST, TN, TOL, TOL1, TOUTC, UMAX, UROUND, & U_PIVOT, X2, WM1, WM2 INTEGER, PRIVATE :: ADDTOJA, ADDTONNZ, CONSECUTIVE_CFAILS, & CONSECUTIVE_EFAILS, ELBOW_ROOM, IADIM, IANPIV, IAVPIV, & ICF, ICNCP, IFAIL, IMAX, IMIN, INEWJ, INIT, IPUP, IRANK, IRFND, IRNCP, & ISTART, ISTATC, ITASKC, JADIM, JCUR, JMIN, JSTART, JSV, KFLAG, KOUNTL, & KUTH, L, LARGE, LAST, LENIGP, LICN_ALL, LIRN_ALL, LIW, LIWM, LMAX, & LOCJS, LP, LRW, LWM, LWMDIM, LWMTEMP, LYH, LYHTEMP, MANPIV, MAPIV, MAXG,& MAXIT, MAXORD, MB28, MB48, METH, MICN, MICNCP, MINICN, MINIRN, MIRANK, & MIRN, MIRNCP, MITER, MLP, MOSS, MP, MSBG, MSBJ, MXHNIL, MXSTEP, N, NZB, & NCFN, NDROP, NDROP1, NDX, NETF, NEWH, NEWQ, NFE, NGC, NGE, NGP, NHNIL, & NJE, NLP, NLU, NNI, NNZ, NOITER, NQ, NQNYH, NQU, NQWAIT, NSLG, NSLJ, & NSLP, NSRCH, NSRCH1, NST, NSUBS, NSUPS, NUM, NUMNZ, NYH, NZ_ALL, & NZ_SWAG, PREVIOUS_MAXORD, WPD, WPS, MA28AD_CALLS, MA28BD_CALLS, & MA28CD_CALLS, MC19AD_CALLS, MAX_MINIRN, MAX_MINICN, MAX_NNZ, BNGRP ! MA48AD_CALLS, MA48BD_CALLS, MA48CD_CALLS ! *****MA48 build change point. Insert the above line. LOGICAL, PRIVATE :: ABORT, ABORT1, ABORT2, ABORT3, ABORTA, ABORTB, & ALLOW_DEFAULT_TOLS, BUILD_IAJA, BOUNDS, CHANGED_ACOR, GROW, IAJA_CALLED,& J_HAS_BEEN_COMPUTED, J_IS_CONSTANT, LBIG, LBIG1, LBLOCK, MA48_WAS_USED, & OK_TO_CALL_MA28, SUBS, SUPS, OPTS_CALLED, REDO_PIVOT_SEQUENCE, & SCALE_MATRIX, SPARSE, USE_FAST_FACTOR, YMAXWARN ! .. ! .. Local Arrays .. KPP_REAL, ALLOCATABLE, PRIVATE :: ACOR(:), CSCALEX(:), EWT(:), & FPTEMP(:), FTEMP(:), FTEMP1(:), G0(:), G1(:), GX(:), JMAT(:), & LB(:), PMAT(:), RSCALEX(:), RWORK(:), SAVF(:), UB(:), WM(:), & WMTEMP(:), WSCALEX(:,:), YHNQP2(:), YHTEMP(:), YMAX(:), YNNEG(:), & YTEMP(:), DTEMP(:) KPP_REAL, PRIVATE :: EL(13), RUSER(22), TAU(13), TQ(5) INTEGER, ALLOCATABLE, PRIVATE :: BIGP(:), BJGP(:), IA(:), IAB(:), IAN(:), & ICN(:), IDX(:), IGP(:), IKEEP28(:,:), IW28(:,:), IWORK(:), JA(:), & JAB(:), JAN(:), JATEMP(:), JGP(:), JROOT(:), JVECT(:), SUBDS(:), SUPDS(:) INTEGER, PRIVATE :: IDISP(2), IUSER(30), LNPIV(10), LPIV(10) INTEGER, PRIVATE :: MORD(2) = (/ 12, 5 /) ! .. ! .. Public Subroutines and Functions .. PUBLIC :: & DAXPY_F90, DCOPY_F90, DDOT_F90, DGBFA_F90, DGBSL_F90, DGEFA_F90, & DGESL_F90, DSCAL_F90, IDAMAX_F90 ! .. ! .. Private Subroutines and Functions .. PRIVATE :: & CHECK_DIAG , DACOPY , DEWSET , DGROUP , & DGROUPDS , DVCHECK , DVHIN , DVINDY_BNDS , & DVINDY_CORE , DVJAC , DVJACS28 , DVJUST , & DVNLSD , DVNLSS28 , DVNORM , DVNRDN , & DVNRDP , DVNRDS , DVODE , DVPREPS , & DVROOTS , DVSET , DVSOL , DVSOLS28 , & DVSRCO , DVSTEP , GDUMMY , IUMACH , & IXSAV , JACSPDB , JDUMMY , MA28AD , & MA28BD , MA28CD , MA28DD , MA28ID , & MA30AD , MA30BD , MA30CD , MA30DD , & MC13E , MC19AD , MC20AD , MC20BD , & MC21A , MC21B , MC22AD , MC23AD , & MC24AD , SET_ICN , XERRDV , XSETF , & XSETUN , DEGR , IDO , NUMSRT , & SEQ , SETR , SLO , SRTDAT , & FDJS ! DVJACS48 , DVNLSS48 , DVPREPS48 , DVSOLS48 !_______________________________________________________________________ ! *****MA48 build change point. Insert the above line. !_______________________________________________________________________ ! .. ! .. Intrinsic Functions .. INTRINSIC KIND ! .. ! .. Data Statements .. DATA OPTS_CALLED/ .FALSE./ DATA MP/6/, NLP/6/, MLP/6/, NSRCH/32768/, ISTART/0/, MAXIT/16/, & LBIG/ .FALSE./, LBLOCK/ .TRUE./, GROW/ .TRUE./, & TOL/0.0_dp/, CGCE/0.5_dp/, BIG/0.0_dp/, ABORT1/ .TRUE./, & ABORT2/ .TRUE./, ABORT3/ .FALSE./, ABORT/ .FALSE./, MIRN/0/, & MICN/0/, MIRNCP/0/, MICNCP/0/, MIRANK/0/, NDROP1/0/, & MRMIN/0.0D0/, MRESID/0/, OK_TO_CALL_MA28/.FALSE./ ! .. ! END OF DVODE_F90 PRIVATE SECTION. !_______________________________________________________________________ CONTAINS SUBROUTINE VODE_F90(F,NEQ,Y,T,TOUT,ITASK,ISTATE,OPTS,J_FCN,G_FCN) ! .. ! This is an interface for DVODE to allow JAC and GFUN to be ! OPTIONAL arguments. ! .. IMPLICIT NONE ! .. ! .. Structure Arguments .. TYPE (VODE_OPTS) :: OPTS ! .. ! .. Scalar Arguments .. KPP_REAL, INTENT (INOUT) :: T, TOUT INTEGER, INTENT (INOUT) :: ISTATE INTEGER, INTENT (IN) :: ITASK, NEQ ! .. ! .. Array Arguments .. KPP_REAL, INTENT (INOUT) :: Y(*) ! .. ! .. Subroutine Arguments .. OPTIONAL :: G_FCN, J_FCN EXTERNAL J_FCN ! .. ! .. Subroutine Interfaces .. INTERFACE SUBROUTINE F(NEQ,T,Y,YDOT) INTEGER, PARAMETER :: WP = KIND(1.0D0) INTEGER NEQ REAL(WP) T REAL(WP), DIMENSION(NEQ) :: Y, YDOT INTENT(IN) :: NEQ, T, Y INTENT(OUT) :: YDOT END SUBROUTINE F END INTERFACE INTERFACE SUBROUTINE G_FCN(NEQ,T,Y,NG,GROOT) INTEGER, PARAMETER :: WP = KIND(1.0D0) INTEGER NEQ, NG REAL(WP) T REAL(WP), DIMENSION(NEQ) :: Y REAL(WP), DIMENSION(NG) :: GROOT(NG) INTENT(IN) :: NEQ, T, Y, NG INTENT(OUT) :: GROOT END SUBROUTINE G_FCN END INTERFACE ! Note: ! The best we can do here is to declare J_FCN to be ! external. The interface for a sparse problem differs ! from that for a banded or dense problem. The following ! would suffuce for a banded or dense problem. ! INTERFACE ! SUBROUTINE J_FCN(NEQ,T,Y,ML,MU,PD,NROWPD) ! INTEGER, PARAMETER :: WP = KIND(1.0D0) ! INTEGER NEQ, ML, MU, NROWPD ! REAL(WP) T ! REAL(WP), DIMENSION(NEQ) :: Y ! REAL(WP), DIMENSION(NEQ) :: PD(NROWPD,NEQ) ! INTENT(IN) :: NEQ, T, Y, ML, MU, NROWPD ! INTENT(INOUT) :: PD ! END SUBROUTINE J_FCN ! END INTERFACE ! The following would suffice for a sparse problem. INTERFACE SUBROUTINE J_FCN(NEQ,T,Y,IA,JA,NZ,P) INTEGER, PARAMETER :: WP = KIND(1.0D0) INTEGER NEQ, NZ REAL(WP) T REAL(WP), DIMENSION Y(*), P(*) INTEGER, DIMENSION IA(*), JA(*) INTENT(IN) :: NEQ, T, Y INTENT(INOUT) IA, JA, NZ, P END SUBROUTINE J_FCN END INTERFACE ! .. ! .. Local Scalars .. INTEGER :: HOWCALL, METH, MFA, MITER, MOSS, NG CHARACTER (80) :: MSG ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, PRESENT ! .. ! .. FIRST EXECUTABLE STATEMENT VODE_F90 ! .. ! Check that SET_OPTS has been called. IF (.NOT.OPTS_CALLED) THEN MSG = 'You have not called SET_OPTS before' CALL XERRDV(MSG,10,1,0,0,0,0,ZERO,ZERO) MSG = 'calling DVODE_F90 the first time.' CALL XERRDV(MSG,10,2,0,0,0,0,ZERO,ZERO) END IF ! Check that JAC is present if it is needed. IF (PRESENT(J_FCN)) THEN ELSE ! Note: ! MOSS is irrelevant. OPTS%MF is two digits after the ! call to SET_OPTS. MFA = ABS(OPTS%MF) MOSS = MFA/100 METH = (MFA-100*MOSS)/10 MITER = MFA - 100*MOSS - 10*METH IF (MITER==1 .OR. MITER==4 .OR. MITER==6) THEN MSG = 'You have specified a value of the integration' CALL XERRDV(MSG,20,1,0,0,0,0,ZERO,ZERO) MSG = 'method flag MF which requires that you supply' CALL XERRDV(MSG,20,1,0,0,0,0,ZERO,ZERO) MSG = 'a Jacobian subroutine JAC; but FAC is not' CALL XERRDV(MSG,20,1,0,0,0,0,ZERO,ZERO) MSG = 'present in the argument list.' CALL XERRDV(MSG,20,2,0,0,0,0,ZERO,ZERO) END IF END IF ! Check that GFUN is present if it is needed. IF (PRESENT(G_FCN)) THEN ELSE NG = OPTS%NG IF (NG>0) THEN MSG = 'You have indicated that events are present but' CALL XERRDV(MSG,30,1,0,0,0,0,ZERO,ZERO) MSG = 'you have not supplied a GFUN subroutine.' CALL XERRDV(MSG,30,2,0,0,0,0,ZERO,ZERO) END IF END IF ! Determine how DVODE will be called. ! HOWCALL = 1: JDUMMY, GDUMMY ! 2: JAC, GFUN ! 3: JAC, GDUMMY ! 4: JDUMMY, GFUN HOWCALL = 1 IF (PRESENT(J_FCN)) THEN IF (PRESENT(G_FCN)) THEN HOWCALL = 2 ELSE HOWCALL = 3 END IF ELSE IF (PRESENT(G_FCN)) THEN HOWCALL = 4 ELSE HOWCALL = 1 END IF END IF ! Call DVODE to do the integration. IF (HOWCALL==1) THEN CALL DVODE(F,NEQ,Y,T,TOUT,ITASK,ISTATE,OPTS,JDUMMY,GDUMMY) ELSE IF (HOWCALL==2) THEN CALL DVODE(F,NEQ,Y,T,TOUT,ITASK,ISTATE,OPTS,J_FCN,G_FCN) ELSE IF (HOWCALL==3) THEN CALL DVODE(F,NEQ,Y,T,TOUT,ITASK,ISTATE,OPTS,J_FCN,GDUMMY) ELSE IF (HOWCALL==4) THEN CALL DVODE(F,NEQ,Y,T,TOUT,ITASK,ISTATE,OPTS,JDUMMY,G_FCN) END IF RETURN END SUBROUTINE VODE_F90 !_______________________________________________________________________ SUBROUTINE JDUMMY(NEQ,T,Y,ML,MU,PD,NROWPD) ! .. ! This is a dummy Jacobian subroutine for VODE_F90 (never called). ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. KPP_REAL :: T INTEGER :: ML, MU, NEQ, NROWPD, I LOGICAL DUMMY ! .. ! .. Array Arguments .. KPP_REAL :: PD(NROWPD,*), Y(*) ! .. INTENT(IN) T, Y, ML, MU, NROWPD INTENT(INOUT) PD ! .. ! .. FIRST EXECUTABLE STATEMENT JDUMMY ! .. ! Get rid of some needless compiler warning messages. DUMMY = .FALSE. IF (DUMMY) THEN I = NEQ I = ML I = MU I = NROWPD PD(1,1) = T PD(1,1) = Y(1) PD(1,1) = DBLE(REAL(I)) END IF RETURN END SUBROUTINE JDUMMY !_______________________________________________________________________ SUBROUTINE GDUMMY(NEQ,T,Y,NG,GOUT) ! .. ! This is a dummy event subroutine for VODE_F90 (never called). ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. KPP_REAL :: T INTEGER :: NEQ, NG, I LOGICAL DUMMY ! .. ! .. Array Arguments .. KPP_REAL :: GOUT(*), Y(*) ! .. INTENT(IN) NEQ, T, Y, NG INTENT(OUT) GOUT ! .. ! .. FIRST EXECUTABLE STATEMENT JDUMMY ! .. ! Get rid of some needless compiler warning messages. DUMMY = .FALSE. IF (DUMMY) THEN I = NEQ I = NG GOUT(1) = T GOUT(1) = Y(1) GOUT(1) = DBLE(REAL(I)) END IF RETURN END SUBROUTINE GDUMMY !_______________________________________________________________________ SUBROUTINE SET_OPTS_2(HMAX,HMIN,MXSTEP) ! .. ! Allow the maximum step size, the minimum step size, and the maximum ! number of steps to be changed without restarting the integration. ! .. ! Quick Summary of Options ! HMAX - Maximum step size in DVODE ! HMIN - Minimum step size in DVODE ! MXSTEP - Maximum number of integration steps in DVODE ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. KPP_REAL, OPTIONAL, INTENT (IN) :: HMAX, HMIN INTEGER, OPTIONAL, INTENT (IN) :: MXSTEP ! .. ! .. Local Scalars .. CHARACTER (80) :: MSG ! .. ! .. Intrinsic Functions .. INTRINSIC ALLOCATED, PRESENT ! .. ! .. FIRST EXECUTABLE STATEMENT SET_OPTS_2 ! .. ! Check that SET_OPTS has been called: IF (.NOT.OPTS_CALLED) THEN MSG = 'You have not called SET_OPTS before' CALL XERRDV(MSG,40,1,0,0,0,0,ZERO,ZERO) MSG = 'calling subroutine SET_OPTS_2.' CALL XERRDV(MSG,40,2,0,0,0,0,ZERO,ZERO) END IF IF (PRESENT(HMAX)) THEN RUSER(6) = HMAX MSG = 'HMAX changed in SET_OPTS_2.' CALL XERRDV(MSG,50,1,0,0,0,1,HMAX,ZERO) END IF IF (PRESENT(HMIN)) THEN RUSER(7) = HMIN MSG = 'HMIN changed in SET_OPTS_2.' CALL XERRDV(MSG,60,1,0,0,0,1,HMIN,ZERO) END IF IF (PRESENT(MXSTEP)) THEN IUSER(6) = MXSTEP MSG = 'MXSTEP changed in SET_OPTS_2.' CALL XERRDV(MSG,70,1,1,MXSTEP,0,0,ZERO,ZERO) END IF END SUBROUTINE SET_OPTS_2 !_______________________________________________________________________ FUNCTION SET_NORMAL_OPTS(DENSE_J, BANDED_J, SPARSE_J, & USER_SUPPLIED_JACOBIAN, LOWER_BANDWIDTH, UPPER_BANDWIDTH, & RELERR, ABSERR, ABSERR_VECTOR, NEVENTS) RESULT(OPTS) ! FUNCTION SET_NORMAL_OPTS: ! Jacobian type: ! DENSE_J, BANDED_J, SPARSE_J ! Analytic Jacobian: ! USER_SUPPLIED_JACOBIAN ! If banded Jacobian: ! LOWER_BANDWIDTH,UPPER_BANDWIDTH ! Error tolerances: ! RELERR, ABSERR, ABSERR_VECTOR ! Rootfinding: ! NEVENTS ! RESULT(OPTS) ! Note: ! Invoking SET_NORMAL_OPTS causes an integration restart. A common ! situation is one in which all you wish to change is one of the ! vode.f77 optional parameters HMAX, HMIN, or MXSTEP. Once the ! integration is started and this is all you wish to do, you can ! change any of these parameters without restarting the integration ! simply by calling subroutine SET_OPTS_2: ! CALL SET_OPTS_2(HMAX,HMIN,MXSTEP) ! Each of the three arguments is optional and only the ones actually ! supplied will be used. Changes will take effect in the same manner ! as in the VODE.f77 solver. ! ! NORMAL_OPTIONS sets user parameters for DVODE via keywords. ! Values that are defined herein will be used internally by ! DVODE. All option keywords are OPTIONAL and order is not ! important. These options should be adequate for most problems. ! If you wish to use more specialized options, you must use ! SET_INTERMEDIATE_OPTS or SET_OPTS rather than NORMAL_OPTS. ! If you wish to use SET_INTERMEDIATE_OPTS or SET_OPTS, you ! may use any of the SET_NORMAL_OPTS keywords or any of the ! keywords available for these two functions. Of course, you ! may opt to simply use SET_OPTS for all problems. ! Note that DVODE_F90 requires that one of SET_NORMAL_OPTS or ! SET_INTERMEDIATE_OPTS or SET_OPTS is called before the first ! time DVODE_F90 is called. ! ! Important Note: ! If feasible, you should use the dense or banded option; but ! SET_NORMAL_OPTS allows you to use a sparse internal Jacobian ! (i.e., one that is determined using finite differences) and ! structure pointere array that are determined internally ! using finite differences. If any of the following are true ! (1) DVODE_F90 doesn't perform satisfactorily for ! your problem, ! (2) you are solving a very large problem, ! (3) you wish to supply the sparse pointer arrays ! directly, ! (4) you wish to supply an analytical sparse Jacobian, ! or ! (5) you wish to use one of the specialized sparse ! Jacobian options, ! you are encouraged to use SET_OPTS which contains several ! provisions for solving sparse problems more efficiently. ! Option Types: ! DENSE_J - logical ! BANDED_J - logical ! SPARSE_J - logical ! USER_SUPPLIED_JACOBIAN - logical ! LOWER_BANDWIDTH - integer ! UPPER_BANDWIDTH - integer ! RELERR - real(wp) scalar ! ABSERR - real(wp) scalar ! ABSERR_VECTOR - real(wp) vector ! NEVENTS - integer ! Options: ! ABSERR = Absolute error tolerance ! ABSERR_VECTOR = Vector of absolute error tolerances ! RELERR = Scalar relative error tolerance ! NEVENTS = Number of event functions (requires ! user-supplied GFUN) ! DENSE_J = Use dense linear algebra if .TRUE. ! BANDED_J = Use banded linear algebra if .TRUE. ! LOWER_BANDWIDTH = Lower bandwidth of the Jacobian ! (required if BANDED_J = .TRUE.) ! UPPER_BANDWIDTH = Upper bandwidth of the Jacobian ! (required if BANDED_J = .TRUE.) ! SPARSE_J = Use sparse linear algebra if .TRUE. ! USER_SUPPLIED_JACOBIAN = Exact Jacobian option ! (requires user-supplied JAC; ! ignored for SPARSE_J=.TRUE.) ! ! Note: DENSE_J takes precedence over BANDED_J which in turn ! takes precedence over SPARSE_J if more than one is supplied. ! If neither of the three flags is present, the nonstiff Adams ! option will be used. Similiarly, ABSERR_VECTOR takes ! precedence over ABSERR. ! ! Note on Jacobian Storage Formats: ! ! If you supply an analytic Jacobian PD, load the ! Jacobian elements DF(I)/DY(J), the partial ! derivative of F(I) with respect to Y(J), using ! the following formats. Here, Y is the solution, ! F is the derivative, and PD is the Jacobian. ! ! For a full Jacobian, load PD(I,J) with DF(I)/DY(J). ! Your code might look like this: ! DO J = 1, NEQ ! DO I = 1, NEQ ! PD(I,J) = ... DF(I)/DY(J) ! END DO ! END DO ! ! For a banded Jacobian, load PD(I-J+MU+1,J) with ! DF(I)/DY(J) where ML is the lower bandwidth ! and MU is the upper bandwidth of the Jacobian. ! Your code might look like this: ! DO J = 1, NEQ ! I1 = MAX(1,J-ML) ! I2 = MIN(N,J+MU) ! DO I = I1, I2 ! K = I-J+MU+1 ! PD(K,J) = ... DF(I)/DY(J) ! END DO ! END DO ! .. IMPLICIT NONE ! .. ! .. Function Return Value .. TYPE (VODE_OPTS) :: OPTS ! .. ! .. Scalar Arguments .. KPP_REAL, OPTIONAL, INTENT (IN) :: ABSERR,RELERR INTEGER, OPTIONAL, INTENT (IN) :: LOWER_BANDWIDTH, & NEVENTS,UPPER_BANDWIDTH LOGICAL, OPTIONAL, INTENT (IN) :: BANDED_J, DENSE_J, & SPARSE_J, USER_SUPPLIED_JACOBIAN ! .. ! .. Array Arguments .. KPP_REAL, OPTIONAL, INTENT (IN) :: ABSERR_VECTOR(:) ! .. ! .. Local Scalars .. INTEGER :: IER,IOPT,METH,MF,MFA,MFSIGN,MITER,ML,MOSS, & MU,NAE,NG,NRE LOGICAL :: BANDED,DENSE,SPARSE CHARACTER (80) :: MSG ! .. ! .. Intrinsic Functions .. INTRINSIC ALLOCATED, IABS, MAX, MINVAL, PRESENT, SIGN, SIZE ! .. ! .. FIRST EXECUTABLE STATEMENT SET_NORMAL_OPTS ! .. RUSER(1:LRWUSER) = ZERO IUSER(1:LIWUSER) = 0 ! Allow default error tolerances? ALLOW_DEFAULT_TOLS = .FALSE. ! Maximum number of consecutive error test failures? CONSECUTIVE_EFAILS = KFH ! Maximum number of consecutive corrector iteration failures? CONSECUTIVE_CFAILS = MXNCF ! Use JACSP to approximate Jacobian? USE_JACSP = .FALSE. ! Set the flag to indicate that SET_NORMAL_OPTS has been called. OPTS_CALLED = .TRUE. ! Set the MA48 storage cleanup flag. MA48_WAS_USED = .FALSE. ! Set the fast factor option for MA48, USE_FAST_FACTOR = .TRUE. ! Set the constant Jacobian flags. J_IS_CONSTANT = .FALSE. J_HAS_BEEN_COMPUTED = .FALSE. ! Determine the working precision and define the value for UMAX ! expected by MA28. Note that it is different for single and ! double precision. WPD = KIND(1.0D0) WPS = KIND(1.0E0) IF (WPD/=WP .AND. WPS/=WP) THEN MSG = 'Illegal working precision in SET_NORMAL_OPTS.' CALL XERRDV(MSG,80,2,0,0,0,0,ZERO,ZERO) END IF IF (WPD==WP) THEN ! Working precision is double. UMAX = 0.999999999_dp ELSE ! Working precision is single. UMAX = 0.9999_dp END IF MA28AD_CALLS = 0 MA28BD_CALLS = 0 MA28CD_CALLS = 0 MC19AD_CALLS = 0 !_______________________________________________________________________ ! *****MA48 build change point. Insert these statements. ! MA48AD_CALLS = 0 ! MA48BD_CALLS = 0 ! MA48CD_CALLS = 0 !_______________________________________________________________________ IRNCP = 0 ICNCP = 0 MINIRN = 0 MINICN = 0 MAX_MINIRN = 0 MAX_MINICN = 0 MAX_NNZ = 0 ! Set the flag to warn the user if |(y(t)| < abserr. YMAXWARN = .FALSE. ! Load defaults for the optional input arrays for DVODE. IUSER(1:8) = 0 RUSER(1:8) = ZERO ! Set the method flag. MF = 10 IF (PRESENT(SPARSE_J)) THEN IF (SPARSE_J) THEN MF = 227 IF (PRESENT(USER_SUPPLIED_JACOBIAN)) THEN MSG = 'You have indicated you wish to supply an' CALL XERRDV(MSG,90,1,0,0,0,0,ZERO,ZERO) MSG = 'exact sparse Jacobian in function' CALL XERRDV(MSG,90,1,0,0,0,0,ZERO,ZERO) MSG = 'SET_NORMAL_OPTS. In order to do this,' CALL XERRDV(MSG,90,1,0,0,0,0,ZERO,ZERO) MSG = 'you must use SET_OPTS. Execution will' CALL XERRDV(MSG,90,1,0,0,0,0,ZERO,ZERO) MSG = 'continue.' CALL XERRDV(MSG,90,1,0,0,0,0,ZERO,ZERO) END IF END IF END IF IF (PRESENT(BANDED_J)) THEN IF (BANDED_J) THEN IF (PRESENT(USER_SUPPLIED_JACOBIAN)) THEN IF (USER_SUPPLIED_JACOBIAN) THEN MF = 24 ELSE MF = 25 END IF ELSE MF = 25 END IF END IF END IF IF (PRESENT(DENSE_J)) THEN IF (DENSE_J) THEN IF (PRESENT(USER_SUPPLIED_JACOBIAN)) THEN IF (USER_SUPPLIED_JACOBIAN) THEN MF = 21 ELSE MF = 22 END IF ELSE MF = 22 END IF END IF END IF ! Check for errors in MF. MFA = IABS(MF) MOSS = MFA/100 METH = (MFA-100*MOSS)/10 MITER = MFA - 100*MOSS - 10*METH IF (METH<1 .OR. METH>2) THEN MSG = 'Illegal value of METH in SET_NORMAL_OPTS.' CALL XERRDV(MSG,100,2,0,0,0,0,ZERO,ZERO) END IF IF (MITER<0 .OR. MITER>7) THEN MSG = 'Illegal value of MITER in SET_NORMAL_OPTS.' CALL XERRDV(MSG,110,2,0,0,0,0,ZERO,ZERO) END IF IF (MOSS<0 .OR. MOSS>2) THEN MSG = 'Illegal value of MOSS in SET_NORMAL_OPTS.' CALL XERRDV(MSG,120,2,0,0,0,0,ZERO,ZERO) END IF ! Reset MF, now that MOSS is known. MFSIGN = SIGN(1,MF) MF = MF - 100*MOSS*MFSIGN IF (MITER==0) THEN DENSE = .FALSE. BANDED = .FALSE. SPARSE = .FALSE. ELSE IF (MITER==1 .OR. MITER==2) THEN DENSE = .TRUE. BANDED = .FALSE. SPARSE = .FALSE. ELSE IF (MITER==3) THEN DENSE = .FALSE. BANDED = .FALSE. SPARSE = .FALSE. ELSE IF (MITER==4 .OR. MITER==5) THEN DENSE = .FALSE. BANDED = .TRUE. SPARSE = .FALSE. ELSE IF (MITER==6 .OR. MITER==7) THEN DENSE = .FALSE. BANDED = .FALSE. SPARSE = .TRUE. END IF ! Define the banded Jacobian band widths. IF (BANDED) THEN IF (PRESENT(LOWER_BANDWIDTH)) THEN ML = LOWER_BANDWIDTH IUSER(1) = ML ELSE MSG = 'In SET_NORMAL_OPTS you have indicated a' CALL XERRDV(MSG,130,1,0,0,0,0,ZERO,ZERO) MSG = 'banded Jacobian but you have not supplied' CALL XERRDV(MSG,130,1,0,0,0,0,ZERO,ZERO) MSG = 'the lower bandwidth.' CALL XERRDV(MSG,130,2,0,0,0,0,ZERO,ZERO) END IF IF (PRESENT(UPPER_BANDWIDTH)) THEN MU = UPPER_BANDWIDTH IUSER(2) = MU ELSE MSG = 'In SET_NORMAL_OPTS you have indicated a' CALL XERRDV(MSG,140,1,0,0,0,0,ZERO,ZERO) MSG = 'banded Jacobian but you have not supplied' CALL XERRDV(MSG,140,1,0,0,0,0,ZERO,ZERO) MSG = 'the upper bandwidth.' CALL XERRDV(MSG,140,2,0,0,0,0,ZERO,ZERO) END IF END IF ! Define the sparse Jacobian options. IF (SPARSE) THEN ! Set the MA28 message flag. LP = 0 ! Set the MA28 pivot sequence frequency flag. REDO_PIVOT_SEQUENCE = .FALSE. ! Set the MA28 singularity threshold. EPS = 1.0E-4_dp ! Use scaling of the iteration matrix. SCALE_MATRIX = .TRUE. ! Define the elbow room factor for the MA28 sparse work arrays. ELBOW_ROOM = 2 ! NZSWAG is a swag for the number of nonzeros in the Jacobian. NZ_SWAG = 0 ! Use partial pivoting. U_PIVOT = ONE ! Indicate that SET_IAJA has not yet been called successfully. IAJA_CALLED = .FALSE. ! Check for illegal method flags. IF (MOSS==2 .AND. MITER/=7) THEN MSG = 'In SET_NORMAL_OPTS MOSS=2 but MITER is not 7.' CALL XERRDV(MSG,150,2,0,0,0,0,ZERO,ZERO) END IF IF (MOSS==1 .AND. MITER/=6) THEN MSG = 'In SET_NORMAL_OPTS MOSS=1 but MITER is not 6.' CALL XERRDV(MSG,160,2,0,0,0,0,ZERO,ZERO) END IF ! IF (MOSS==0 .AND. MITER/=7) THEN ! MSG = 'In SET_NORMAL_OPTS MOSS=0 but MITER is not 7.' ! CALL XERRDV(MSG,170,2,0,0,0,0,ZERO,ZERO) ! END IF END IF ! Define the number of event functions. IF (PRESENT(NEVENTS)) THEN IF (NEVENTS>0) THEN NG = NEVENTS ELSE NG = 0 END IF ELSE NG = 0 END IF ! No solution bounds will be imposed. BOUNDS = .FALSE. ! Load the user options into the solution structure. OPTS%MF = MF OPTS%METH = METH OPTS%MITER = MITER OPTS%MOSS = MOSS OPTS%DENSE = DENSE OPTS%BANDED = BANDED OPTS%SPARSE = SPARSE OPTS%NG = NG IOPT = 1 OPTS%IOPT = IOPT ! Process the error tolerances. ! Relative error tolerance. NRE = 1 ALLOCATE (OPTS%RTOL(NRE),STAT=IER) CALL CHECK_STAT(IER,10) IF (PRESENT(RELERR)) THEN IF (RELERR2) THEN MSG = 'Illegal value of METH in SET_INTERMEDIATE_OPTS.' CALL XERRDV(MSG,330,2,0,0,0,0,ZERO,ZERO) END IF IF (MITER<0 .OR. MITER>7) THEN MSG = 'Illegal value of MITER in SET_INTERMEDIATE_OPTS.' CALL XERRDV(MSG,340,2,0,0,0,0,ZERO,ZERO) END IF IF (MOSS<0 .OR. MOSS>2) THEN MSG = 'Illegal value of MOSS in SET_INTERMEDIATE_OPTS.' CALL XERRDV(MSG,350,2,0,0,0,0,ZERO,ZERO) END IF ! Reset MF, now that MOSS is known. MFSIGN = SIGN(1,MF) MF = MF - 100*MOSS*MFSIGN IF (MITER==0) THEN DENSE = .FALSE. BANDED = .FALSE. SPARSE = .FALSE. ELSE IF (MITER==1 .OR. MITER==2) THEN DENSE = .TRUE. BANDED = .FALSE. SPARSE = .FALSE. ELSE IF (MITER==3) THEN DENSE = .FALSE. BANDED = .FALSE. SPARSE = .FALSE. ELSE IF (MITER==4 .OR. MITER==5) THEN DENSE = .FALSE. BANDED = .TRUE. SPARSE = .FALSE. ELSE IF (MITER==6 .OR. MITER==7) THEN DENSE = .FALSE. BANDED = .FALSE. SPARSE = .TRUE. END IF ! Define the banded Jacobian band widths. IF (BANDED) THEN IF (PRESENT(LOWER_BANDWIDTH)) THEN ML = LOWER_BANDWIDTH IUSER(1) = ML ELSE MSG = 'In SET_INTERMEDIATE_OPTS you have indicated a' CALL XERRDV(MSG,360,1,0,0,0,0,ZERO,ZERO) MSG = 'banded Jacobian but you have not' CALL XERRDV(MSG,360,1,0,0,0,0,ZERO,ZERO) MSG = 'supplied the lower bandwidth.' CALL XERRDV(MSG,360,2,0,0,0,0,ZERO,ZERO) END IF IF (PRESENT(UPPER_BANDWIDTH)) THEN MU = UPPER_BANDWIDTH IUSER(2) = MU ELSE MSG = 'In SET_INTERMEDIATE_OPTS you have indicated a' CALL XERRDV(MSG,370,1,0,0,0,0,ZERO,ZERO) MSG = 'banded Jacobian but you have not' CALL XERRDV(MSG,370,1,0,0,0,0,ZERO,ZERO) MSG = 'supplied the upper bandwidth.' CALL XERRDV(MSG,370,2,0,0,0,0,ZERO,ZERO) END IF ! Define the nonzero diagonals. BNGRP = 0 SUBS = .FALSE. SUPS = .FALSE. NSUBS = 0 NSUPS = 0 END IF ! Define the sparse Jacobian options. SCALE_MATRIX = .FALSE. ELBOW_ROOM = 2 IF (SPARSE) THEN ! NZSWAG for the number of nonzeros in the Jacobian. IF (PRESENT(NZSWAG)) THEN NZ_SWAG = MAX(NZSWAG,0) ELSE NZ_SWAG = 0 END IF ! Indicate that SET_IAJA has not yet been called successfully. IAJA_CALLED = .FALSE. ! Check for illegal method flags. IF (MOSS==2 .AND. MITER/=7) THEN MSG = 'In SET_INTERMEDIATE_OPTS MOSS=2 but MITER is not 7.' CALL XERRDV(MSG,380,2,0,0,0,0,ZERO,ZERO) END IF IF (MOSS==1 .AND. MITER/=6) THEN MSG = 'In SET_INTERMEDIATE_OPTS MOSS=1 but MITER is not 6.' CALL XERRDV(MSG,390,2,0,0,0,0,ZERO,ZERO) END IF ! IF (MOSS==0 .AND. MITER/=7) THEN ! MSG = 'In SET_INTERMEDIATE_OPTS MOSS=0 but MITER is not 7.' ! CALL XERRDV(MSG,400,2,0,0,0,0,ZERO,ZERO) ! END IF ! Allow MC19 scaling for the Jacobian. SCALE_MATRIX = .FALSE. END IF ! Define the number of event functions. IF (PRESENT(NEVENTS)) THEN IF (NEVENTS>0) THEN NG = NEVENTS ELSE NG = 0 END IF ELSE NG = 0 END IF ! Process the constrained solution components. IF (PRESENT(CONSTRAINED)) THEN NDX = SIZE(CONSTRAINED) IF (NDX<1) THEN MSG = 'In SET_INTERMEDIATE_OPTS the size of CONSTRAINED < 1.' CALL XERRDV(MSG,410,2,0,0,0,0,ZERO,ZERO) END IF IF (.NOT.(PRESENT(CLOWER)) .OR. .NOT.(PRESENT(CUPPER))) THEN MSG = 'In SET_INTERMEDIATE_OPTS the arrays CLOWER and CUPPER' CALL XERRDV(MSG,420,1,0,0,0,0,ZERO,ZERO) MSG = 'are not present.' CALL XERRDV(MSG,420,2,0,0,0,0,ZERO,ZERO) END IF IF (SIZE(CLOWER)/=NDX .OR. SIZE(CUPPER)/=NDX) THEN MSG = 'In SET_INTERMEDIATE_OPTS the size of the solution bound' CALL XERRDV(MSG,430,1,0,0,0,0,ZERO,ZERO) MSG = 'arrays must be the same as the CONSTRAINED array.' CALL XERRDV(MSG,430,2,0,0,0,0,ZERO,ZERO) END IF ! Note: The contents of CONSTRAINED will be checked ! in subroutine DVODE after NEQ is known. IF (ALLOCATED(IDX)) THEN DEALLOCATE (IDX,LB,UB,STAT=IER) CALL CHECK_STAT(IER,30) END IF ALLOCATE (IDX(NDX),LB(NDX),UB(NDX),STAT=IER) CALL CHECK_STAT(IER,40) IDX(1:NDX) = CONSTRAINED(1:NDX) LB(1:NDX) = CLOWER(1:NDX) UB(1:NDX) = CUPPER(1:NDX) BOUNDS = .TRUE. ELSE IF (ALLOCATED(IDX)) THEN DEALLOCATE (IDX,LB,UB,STAT=IER) CALL CHECK_STAT(IER,50) END IF NDX = 0 BOUNDS = .FALSE. END IF ! Is the Jacobian constant? J_IS_CONSTANT = .FALSE. J_HAS_BEEN_COMPUTED = .FALSE. ! Load the user options into the solution structure. OPTS%MF = MF OPTS%METH = METH OPTS%MITER = MITER OPTS%MOSS = MOSS OPTS%DENSE = DENSE OPTS%BANDED = BANDED OPTS%SPARSE = SPARSE OPTS%NG = NG ! Process the miscellaneous options. ! Don't step past TCRIT variable. IF (PRESENT(TCRIT)) THEN RUSER(1) = TCRIT ELSE RUSER(1) = ZERO END IF ! DVODE optional parameters. IOPT = 1 IF (PRESENT(MAXORD)) THEN IUSER(5) = MAXORD IOPT = 1 END IF IF (PRESENT(MXSTEP)) THEN IUSER(6) = MXSTEP IOPT = 1 END IF IF (PRESENT(MXHNIL)) THEN IUSER(7) = MXHNIL IOPT = 1 END IF IF (PRESENT(H0)) THEN RUSER(5) = H0 IOPT = 1 END IF IF (PRESENT(HMAX)) THEN RUSER(6) = HMAX IOPT = 1 END IF IF (PRESENT(HMIN)) THEN RUSER(7) = HMIN IOPT = 1 END IF U_PIVOT = ONE OPTS%IOPT = IOPT ! Define the error tolerances. ! Relative error tolerances. NRE = 1 ALLOCATE (OPTS%RTOL(NRE),STAT=IER) CALL CHECK_STAT(IER,60) IF (PRESENT(RELERR)) THEN IF (RELERR ZERO) THEN EPS = MA28_EPS ELSE EPS = 1.0E-4_dp END IF ELSE EPS = 1.0E-4_dp END IF ! Set the MA28 pivot sequence frequency flag. IF (PRESENT(MA28_RPS)) THEN IF (MA28_RPS) THEN REDO_PIVOT_SEQUENCE = MA28_RPS ELSE REDO_PIVOT_SEQUENCE = .FALSE. END IF ELSE REDO_PIVOT_SEQUENCE = .FALSE. END IF MA28AD_CALLS = 0 MA28BD_CALLS = 0 MA28CD_CALLS = 0 MC19AD_CALLS = 0 !_______________________________________________________________________ ! *****MA48 build change point. Insert these statements. ! MA48AD_CALLS = 0 ! MA48BD_CALLS = 0 ! MA48CD_CALLS = 0 !_______________________________________________________________________ IRNCP = 0 ICNCP = 0 MINIRN = 0 MINICN = 0 MAX_MINIRN = 0 MAX_MINICN = 0 MAX_NNZ = 0 ! Set the flag to warn the user if |(y(t)| < abserr. IF (PRESENT(YMAGWARN)) THEN IF (YMAGWARN) THEN YMAXWARN = .TRUE. ELSE YMAXWARN = .FALSE. END IF ELSE YMAXWARN = .FALSE. END IF ! Load defaults for the optional input arrays for DVODE. IUSER(1:8) = 0 RUSER(1:8) = ZERO ! Set the method flag. IF (.NOT.(PRESENT(METHOD_FLAG))) THEN MF = 10 IF (PRESENT(SPARSE_J)) THEN IF (SPARSE_J) THEN IF (PRESENT(USER_SUPPLIED_JACOBIAN)) THEN IF (USER_SUPPLIED_JACOBIAN) THEN MF = 126 ELSE MF = 227 END IF ELSE MF = 227 END IF IF (PRESENT(USER_SUPPLIED_SPARSITY)) THEN IF (USER_SUPPLIED_SPARSITY) THEN MF = MF - 100*(MF/100) END IF END IF IF (PRESENT(SAVE_JACOBIAN)) THEN IF (.NOT.SAVE_JACOBIAN) THEN MF = -MF END IF END IF END IF END IF IF (PRESENT(BANDED_J)) THEN IF (BANDED_J) THEN IF (PRESENT(USER_SUPPLIED_JACOBIAN)) THEN IF (USER_SUPPLIED_JACOBIAN) THEN MF = 24 ELSE MF = 25 END IF ELSE MF = 25 END IF IF (PRESENT(SAVE_JACOBIAN)) THEN IF (.NOT.SAVE_JACOBIAN) THEN MF = -MF END IF END IF END IF END IF IF (PRESENT(DENSE_J)) THEN IF (DENSE_J) THEN IF (PRESENT(USER_SUPPLIED_JACOBIAN)) THEN IF (USER_SUPPLIED_JACOBIAN) THEN MF = 21 ELSE MF = 22 END IF ELSE MF = 22 END IF IF (PRESENT(SAVE_JACOBIAN)) THEN IF (.NOT.SAVE_JACOBIAN) THEN MF = -MF END IF END IF END IF END IF ELSE MF = METHOD_FLAG END IF ! Check for errors in MF. MFA = IABS(MF) MOSS = MFA/100 METH = (MFA-100*MOSS)/10 MITER = MFA - 100*MOSS - 10*METH IF (METH<1 .OR. METH>2) THEN MSG = 'Illegal value of METH in SET_OPTS.' CALL XERRDV(MSG,570,2,0,0,0,0,ZERO,ZERO) END IF IF (MITER<0 .OR. MITER>7) THEN MSG = 'Illegal value of MITER in SET_OPTS.' CALL XERRDV(MSG,580,2,0,0,0,0,ZERO,ZERO) END IF IF (MOSS<0 .OR. MOSS>2) THEN MSG = 'Illegal value of MOSS in SET_OPTS.' CALL XERRDV(MSG,580,2,0,0,0,0,ZERO,ZERO) END IF ! Reset MF, now that MOSS is known. MFSIGN = SIGN(1,MF) MF = MF - 100*MOSS*MFSIGN IF (MITER==0) THEN DENSE = .FALSE. BANDED = .FALSE. SPARSE = .FALSE. ELSE IF (MITER==1 .OR. MITER==2) THEN DENSE = .TRUE. BANDED = .FALSE. SPARSE = .FALSE. ELSE IF (MITER==3) THEN DENSE = .FALSE. BANDED = .FALSE. SPARSE = .FALSE. ELSE IF (MITER==4 .OR. MITER==5) THEN DENSE = .FALSE. BANDED = .TRUE. SPARSE = .FALSE. ELSE IF (MITER==6 .OR. MITER==7) THEN DENSE = .FALSE. BANDED = .FALSE. SPARSE = .TRUE. END IF ! Define the banded Jacobian band widths. IF (BANDED) THEN IF (PRESENT(LOWER_BANDWIDTH)) THEN ML = LOWER_BANDWIDTH IUSER(1) = ML ELSE MSG = 'In SET_OPTS you have indicated a' CALL XERRDV(MSG,590,1,0,0,0,0,ZERO,ZERO) MSG = 'banded Jacobian but you have not' CALL XERRDV(MSG,590,1,0,0,0,0,ZERO,ZERO) MSG = 'supplied the lower bandwidth.' CALL XERRDV(MSG,590,2,0,0,0,0,ZERO,ZERO) END IF IF (PRESENT(UPPER_BANDWIDTH)) THEN MU = UPPER_BANDWIDTH IUSER(2) = MU ELSE MSG = 'In SET_OPTS you have indicated a' CALL XERRDV(MSG,600,1,0,0,0,0,ZERO,ZERO) MSG = 'banded Jacobian but you have not' CALL XERRDV(MSG,600,1,0,0,0,0,ZERO,ZERO) MSG = 'supplied the upper bandwidth.' CALL XERRDV(MSG,600,2,0,0,0,0,ZERO,ZERO) END IF ! Define the nonzero diagonals. BNGRP = 0 SUBS = .FALSE. SUPS = .FALSE. NSUBS = 0 NSUPS = 0 IF (PRESENT(SUB_DIAGONALS)) THEN SUBS = .TRUE. NSUBS = SIZE(SUB_DIAGONALS) IF (NSUBS > 0) THEN IF (ALLOCATED(SUBDS)) THEN DEALLOCATE(SUBDS,STAT=IER) CALL CHECK_STAT(IER,80) END IF ALLOCATE(SUBDS(NSUBS),STAT=IER) CALL CHECK_STAT(IER,90) SUBDS(1:NSUBS) = SUB_DIAGONALS(1:NSUBS) ELSE IF (ML > 0) THEN MSG = 'You must indicated that the lower bandwidth' CALL XERRDV(MSG,610,1,0,0,0,0,ZERO,ZERO) MSG = 'is positive but you have not specified the' CALL XERRDV(MSG,610,1,0,0,0,0,ZERO,ZERO) MSG = 'indices for the lower sub diagonals.' CALL XERRDV(MSG,610,2,0,0,0,0,ZERO,ZERO) END IF END IF END IF IF (PRESENT(SUP_DIAGONALS)) THEN SUPS = .TRUE. NSUPS = SIZE(SUP_DIAGONALS) IF (NSUPS > 0) THEN IF (ALLOCATED(SUPDS)) THEN DEALLOCATE(SUPDS,STAT=IER) CALL CHECK_STAT(IER,100) END IF ALLOCATE(SUPDS(NSUPS),STAT=IER) CALL CHECK_STAT(IER,110) SUPDS(1:NSUPS) = SUP_DIAGONALS(1:NSUPS) ELSE IF (ML > 0) THEN MSG = 'You must indicated that the upper bandwidth' CALL XERRDV(MSG,620,1,0,0,0,0,ZERO,ZERO) MSG = 'is positive but you have not specified the' CALL XERRDV(MSG,620,1,0,0,0,0,ZERO,ZERO) MSG = 'indices for the upper sub diagonals.' CALL XERRDV(MSG,620,2,0,0,0,0,ZERO,ZERO) END IF END IF END IF END IF ! Define the sparse Jacobian options. SCALE_MATRIX = .FALSE. ELBOW_ROOM = 2 IF (SPARSE) THEN ! NZSWAG for the number of nonzeros in the Jacobian. IF (PRESENT(NZSWAG)) THEN NZ_SWAG = MAX(NZSWAG,0) ELSE NZ_SWAG = 0 END IF ! Indicate that SET_IAJA has not yet been called successfully. IAJA_CALLED = .FALSE. ! Check for illegal method flags. IF (MOSS==2 .AND. MITER/=7) THEN MSG = 'In SET_OPTS MOSS=2 but MITER is not 7.' CALL XERRDV(MSG,630,2,0,0,0,0,ZERO,ZERO) END IF IF (MOSS==1 .AND. MITER/=6) THEN MSG = 'In SET_OPTS MOSS=1 but MITER is not 6.' CALL XERRDV(MSG,640,2,0,0,0,0,ZERO,ZERO) END IF ! IF (MOSS==0 .AND. MITER/=7) THEN ! MSG = 'In SET_OPTS MOSS=0 but MITER is not 7.' ! CALL XERRDV(MSG,650,2,0,0,0,0,ZERO,ZERO) ! END IF ! Allow the work array elbow room to be increased. IF (PRESENT(MA28_ELBOW_ROOM)) THEN ELBOW_ROOM = MAX(MA28_ELBOW_ROOM, ELBOW_ROOM) END IF ! Allow MC19 scaling for the Jacobian. SCALE_MATRIX = .FALSE. IF (PRESENT(MC19_SCALING)) THEN IF (MC19_SCALING) THEN !_______________________________________________________________________ ! *****MA48 build change point. Insert these statements. ! IF (USE_MA48_FOR_SPARSE) THEN ! MSG = 'MC29AD scaling is not available at this time.' ! CALL XERRDV(MSG,660,1,0,0,0,0,ZERO,ZERO) ! MSG = 'Execution will continue.' ! CALL XERRDV(MSG,660,1,0,0,0,0,ZERO,ZERO) ! END IF !_______________________________________________________________________ SCALE_MATRIX = MC19_SCALING ! SCALE_MATRIX = .FALSE. END IF END IF !_______________________________________________________________________ ! *****MA48 build change point. Replace above with these statements. ! IF (PRESENT(MC19_SCALING)) THEN ! IF (MC19_SCALING) THEN ! IF (USE_MA48_FOR_SPARSE) THEN ! MSG = 'Please note that this version uses MC19AD rather' ! CALL XERRDV(MSG,670,1,0,0,0,0,ZERO,ZERO) ! MSG = 'than MC29AD to sacle the iteration matrix.' ! CALL XERRDV(MSG,670,1,0,0,0,0,ZERO,ZERO) ! MSG = 'Execution will continue.' ! CALL XERRDV(MSG,670,1,0,0,0,0,ZERO,ZERO) ! END IF ! SCALE_MATRIX = MC19_SCALING ! END IF ! END IF !_______________________________________________________________________ END IF ! Define the number of event functions. IF (PRESENT(NEVENTS)) THEN IF (NEVENTS>0) THEN NG = NEVENTS ELSE NG = 0 END IF ELSE NG = 0 END IF ! Process the constrained solution components. IF (PRESENT(CONSTRAINED)) THEN NDX = SIZE(CONSTRAINED) IF (NDX<1) THEN MSG = 'In SET_OPTS the size of CONSTRAINED < 1.' CALL XERRDV(MSG,680,2,0,0,0,0,ZERO,ZERO) END IF IF (.NOT.(PRESENT(CLOWER)) .OR. .NOT.(PRESENT(CUPPER))) THEN MSG = 'In SET_OPTS the arrays CLOWER and CUPPER are' CALL XERRDV(MSG,690,1,0,0,0,0,ZERO,ZERO) MSG = 'not present.' CALL XERRDV(MSG,690,2,0,0,0,0,ZERO,ZERO) END IF IF (SIZE(CLOWER)/=NDX .OR. SIZE(CUPPER)/=NDX) THEN MSG = 'In SET_OPTS the size of the solution bound arrays' CALL XERRDV(MSG,700,1,0,0,0,0,ZERO,ZERO) MSG = 'must be the same as the CONSTRAINED array.' CALL XERRDV(MSG,700,2,0,0,0,0,ZERO,ZERO) END IF ! Note: The contents of CONSTRAINED will be checked ! in subroutine DVODE after NEQ is known. IF (ALLOCATED(IDX)) THEN DEALLOCATE (IDX,LB,UB,STAT=IER) CALL CHECK_STAT(IER,120) END IF ALLOCATE (IDX(NDX),LB(NDX),UB(NDX),STAT=IER) CALL CHECK_STAT(IER,130) IDX(1:NDX) = CONSTRAINED(1:NDX) LB(1:NDX) = CLOWER(1:NDX) UB(1:NDX) = CUPPER(1:NDX) BOUNDS = .TRUE. ELSE IF (ALLOCATED(IDX)) THEN DEALLOCATE (IDX,LB,UB,STAT=IER) CALL CHECK_STAT(IER,140) END IF NDX = 0 BOUNDS = .FALSE. END IF ! Is the Jacobian constant? J_IS_CONSTANT = .FALSE. J_HAS_BEEN_COMPUTED = .FALSE. !_______________________________________________________________________ IF (PRESENT(CONSTANT_JACOBIAN)) THEN IF (CONSTANT_JACOBIAN) THEN J_IS_CONSTANT = .TRUE. !_______________________________________________________________________ ! *****MA48 build change point. Insert these statements. IF (USE_MA48_FOR_SPARSE .AND. SPARSE) THEN MSG = 'The constant Jacobian option is not yet available' CALL XERRDV(MSG,710,1,0,0,0,0,ZERO,ZERO) MSG = 'with the sparse MA48 solution option. Execution' CALL XERRDV(MSG,710,1,0,0,0,0,ZERO,ZERO) MSG = 'will continue.' CALL XERRDV(MSG,710,1,0,0,0,0,ZERO,ZERO) J_IS_CONSTANT = .FALSE. END IF !_______________________________________________________________________ END IF END IF ! *****MA48 build change point. Replace above with these statements. ! IF (PRESENT(CONSTANT_JACOBIAN)) THEN ! IF (CONSTANT_JACOBIAN) THEN ! IF (USE_MA48_FOR_SPARSE) THEN ! MSG = 'The constant Jacobian option is not yet available' ! CALL XERRDV(MSG,720,1,0,0,0,0,ZERO,ZERO) ! MSG = 'with the sparse MA48 solution option. Execution' ! CALL XERRDV(MSG,720,1,0,0,0,0,ZERO,ZERO) ! MSG = 'will continue.' ! CALL XERRDV(MSG,720,1,0,0,0,0,ZERO,ZERO) ! END IF ! ELSE ! J_IS_CONSTANT = .TRUE. ! END IF ! END IF !_______________________________________________________________________ IF (J_IS_CONSTANT) THEN IF (PRESENT(SAVE_JACOBIAN)) THEN IF (.NOT.SAVE_JACOBIAN) THEN MSG = 'You have specified that the Jacobian is constant.' CALL XERRDV(MSG,730,1,0,0,0,0,ZERO,ZERO) MSG = 'In this case you cannot also specify that' CALL XERRDV(MSG,730,1,0,0,0,0,ZERO,ZERO) MSG = 'SAVE_JACOBIAN=.FALSE.' CALL XERRDV(MSG,730,2,0,0,0,0,ZERO,ZERO) END IF END IF IF (PRESENT(USER_SUPPLIED_JACOBIAN)) THEN IF (USER_SUPPLIED_JACOBIAN .AND. SPARSE) THEN MSG = 'You have specified that the Jacobian is constant' CALL XERRDV(MSG,740,1,0,0,0,0,ZERO,ZERO) MSG = 'and that you wish to supply an analytic Jacobian' CALL XERRDV(MSG,740,1,0,0,0,0,ZERO,ZERO) MSG = 'for a sparse problem. In this case your request' CALL XERRDV(MSG,740,1,0,0,0,0,ZERO,ZERO) MSG = 'to use a constant Jacobian will be ignored.' CALL XERRDV(MSG,740,1,0,0,0,0,ZERO,ZERO) MSG = 'Execution will continue.' CALL XERRDV(MSG,740,1,0,0,0,0,ZERO,ZERO) END IF END IF END IF ! Load the user options into the solution structure. OPTS%MF = MF OPTS%METH = METH OPTS%MITER = MITER OPTS%MOSS = MOSS OPTS%DENSE = DENSE OPTS%BANDED = BANDED OPTS%SPARSE = SPARSE OPTS%NG = NG ! Process the miscellaneous options. ! Don't step past TCRIT variable. IF (PRESENT(TCRIT)) THEN RUSER(1) = TCRIT ELSE RUSER(1) = ZERO END IF ! DVODE optional parameters. IOPT = 1 IF (PRESENT(MAXORD)) THEN IUSER(5) = MAXORD IOPT = 1 END IF IF (PRESENT(MXSTEP)) THEN IUSER(6) = MXSTEP IOPT = 1 END IF IF (PRESENT(MXHNIL)) THEN IUSER(7) = MXHNIL IOPT = 1 END IF IF (PRESENT(H0)) THEN RUSER(5) = H0 IOPT = 1 END IF IF (PRESENT(HMAX)) THEN RUSER(6) = HMAX IOPT = 1 END IF IF (PRESENT(HMIN)) THEN RUSER(7) = HMIN IOPT = 1 END IF IF (PRESENT(SETH)) THEN RUSER(8) = SETH IOPT = 1 END IF IF (PRESENT(UPIVOT)) THEN U_PIVOT = UPIVOT IF (U_PIVOTONE) U_PIVOT = ONE ELSE U_PIVOT = ONE END IF !_______________________________________________________________________ ! *****MA48 build change point. Insert this statement. ! COPY_OF_U_PIVOT = U_PIVOT !_______________________________________________________________________ OPTS%IOPT = IOPT ! Define the error tolerances. ! Relative error tolerances. IF (PRESENT(RELERR_VECTOR)) THEN IF (MINVAL(RELERR_VECTOR)ZERO) THEN EMIN = MAX(FMIN,ZERO) ELSE EMIN = ZERO END IF ! Solution perturbation factors. IF (NTURB>0) THEN IF (NTURB<1 .OR. (NTURB>1 .AND. NTURB/=NEQ)) GOTO 30 IF (NTURB==NEQ) THEN DO I = 1, NEQ DTURB(I) = MAX(DTURB(I),HUNDRETH) END DO ELSE MTURB = 1 DTRB = MAX(DTURB(1),HUNDRETH) END IF ELSE MTURB = 1 DTRB = HUNDRETH END IF JADIM = MIN(NEQ*NEQ,MAX(1000,NZ_SWAG)) ADDTOJA = MAX(1000,NZ_SWAG) ! Loop point for array allocation. 10 CONTINUE IF (ALLOCATED(IA)) THEN DEALLOCATE (IA,JA,FTEMP,FPTEMP,STAT=JER) CALL CHECK_STAT(JER,210) END IF IMIN = NEQ + 1 IADIM = NEQ + 1 JMIN = 0 JADIM = JADIM + ADDTOJA IF (JADIM>MAX_ARRAY_SIZE) THEN MSG = 'Maximum array size exceeded. Stopping.' CALL XERRDV(MSG,880,2,0,0,0,0,ZERO,ZERO) END IF ALLOCATE (IA(IADIM),JA(JADIM),FTEMP(NEQ),FPTEMP(NEQ),STAT=JER) CALL CHECK_STAT(JER,220) ! f = y'(t,y). CALL DFN(NEQ,T,Y,FTEMP) IA(1) = 1 K = 1 ! Calculate unit roundoff and powers of it used if JACSP ! is used. UROUND = EPSILON(ONE) ! Successively perturb each of the solution components and ! calculate the corresponding derivatives. DO J = 1, NEQ IF (MTURB==NEQ) DTRB = DTURB(J) YJ = Y(J) YJSAVE = YJ IF (ABS(YJ)<=ZERO) YJ = HUN*UROUND YPJ = YJ*(ONE+DTRB) RJ = ABS(YPJ-YJ) IF (ABS(RJ)<=ZERO) RJ = HUN*UROUND IF (ABS(RJ)<=ZERO) GOTO 30 Y(J) = YPJ CALL DFN(NEQ,T,Y,FPTEMP) DO 20 I = 1, NEQ ! Estimate the Jacobian element. AIJ = ABS(FPTEMP(I)-FTEMP(I))/RJ IF ((AIJ<=EMIN) .AND. (I/=J)) GOTO 20 ! Need more storage for JA. IF (K>JADIM) GOTO 10 JMIN = K JA(K) = I K = K + 1 20 CONTINUE JP1 = J + 1 IA(JP1) = K Y(J) = YJSAVE END DO GOTO 40 30 CONTINUE MSG = 'An error occurred in subroutine SET_IAJA.' CALL XERRDV(MSG,890,2,0,0,0,0,ZERO,ZERO) 40 CONTINUE ! Set the flags to indicate to DVODE_F90 that IA and JA have ! been calculated successfully. SPARSE = .TRUE. IAJA_CALLED = .TRUE. ! Trim JA. ALLOCATE (JATEMP(JMIN),STAT=JER) CALL CHECK_STAT(JER,230) JATEMP(1:JMIN) = JA(1:JMIN) DEALLOCATE (JA,STAT=JER) CALL CHECK_STAT(JER,240) ALLOCATE (JA(JMIN),STAT=JER) CALL CHECK_STAT(JER,250) JA(1:JMIN) = JATEMP(1:JMIN) DEALLOCATE (JATEMP,STAT=JER) CALL CHECK_STAT(JER,260) JADIM = JMIN RETURN END SUBROUTINE SET_IAJA !_______________________________________________________________________ SUBROUTINE DVODE(F,NEQ,Y,T,TOUT,ITASK,ISTATE,OPTS,JAC,GFUN) ! .. ! This is the core driver (modified original DVODE.F driver). ! .. ! The documentation prologue was moved nearer the top of the file. ! .. IMPLICIT NONE ! .. ! .. Structure Arguments .. TYPE (VODE_OPTS) :: OPTS ! .. ! .. Scalar Arguments .. KPP_REAL, INTENT (INOUT) :: T, TOUT INTEGER, INTENT (INOUT) :: ISTATE INTEGER, INTENT (IN) :: ITASK, NEQ ! .. ! .. Array Arguments .. KPP_REAL, INTENT (INOUT) :: Y(*) ! .. ! .. Subroutine Arguments .. EXTERNAL F, GFUN, JAC ! .. ! .. Local Scalars .. KPP_REAL :: ATOLI, BIG, EWTI, H0, HMAX, HMX, RH, RTOLI, SIZEST, & TCRIT, TNEXT, TOLSF, TP INTEGER :: I, IER, IFLAG, IMXER, IOPT, IPCUTH, IRFP, IRT, ITOL, JCO, & JER, KGO, LENIW, LENJ, LENP, LENRW, LENWM, LF0, MBAND, MF, MFA, ML, & MU, NG, NITER, NSLAST LOGICAL :: IHIT CHARACTER (80) :: MSG ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, ALLOCATED, EPSILON, MAX, MIN, SIGN, SQRT ! .. ! The following internal PRIVATE variable blocks contain variables which ! are communicated between subroutines in the DVODE package, or which ! are to be saved between calls to DVODE. ! In each block, real variables precede integers. ! The variables stored in the internal PRIVATE variable blocks are as ! follows: ! ACNRM = Weighted r.m.s. norm of accumulated correction vectors. ! CCMXJ = Threshhold on DRC for updating the Jacobian. (See DRC.) ! CONP = The saved value of TQ(5). ! CRATE = Estimated corrector convergence rate constant. ! DRC = Relative change in H*RL1 since last DVJAC call. ! EL = Real array of integration coefficients. See DVSET. ! ETA = Saved tentative ratio of new to old H. ! ETAMAX = Saved maximum value of ETA to be allowed. ! H = The step size. ! HMIN = The minimum absolute value of the step size H to be used. ! HMXI = Inverse of the maximum absolute value of H to be used. ! HMXI = 0.0 is allowed and corresponds to an infinite HMAX. ! HNEW = The step size to be attempted on the next step. ! HSCAL = Stepsize in scaling of YH array. ! PRL1 = The saved value of RL1. ! RC = Ratio of current H*RL1 to value on last DVJAC call. ! RL1 = The reciprocal of the coefficient EL(2). ! TAU = Real vector of past NQ step sizes, length 13. ! TQ = A real vector of length 5 in which DVSET stores constants ! used for the convergence test, the error test, and the ! selection of H at a new order. ! TN = The independent variable, updated on each step taken. ! UROUND = The machine unit roundoff. The smallest positive real number ! such that 1.0 + UROUND /= 1.0 ! ICF = Integer flag for convergence failure in DVNLSD: ! 0 means no failures. ! 1 means convergence failure with out of date Jacobian ! (recoverable error). ! 2 means convergence failure with current Jacobian or ! singular matrix (unrecoverable error). ! INIT = Saved integer flag indicating whether initialization of the ! problem has been done (INIT = 1) or not. ! IPUP = Saved flag to signal updating of Newton matrix. ! JCUR = Output flag from DVJAC showing Jacobian status: ! JCUR = 0 means J is not current. ! JCUR = 1 means J is current. ! JSTART = Integer flag used as input to DVSTEP: ! 0 means perform the first step. ! 1 means take a new step continuing from the last. ! -1 means take the next step with a new value of MAXORD, ! HMIN, HMXI, N, METH, MITER, and/or matrix parameters. ! On return, DVSTEP sets JSTART = 1. ! JSV = Integer flag for Jacobian saving, = sign(MF). ! KFLAG = A completion code from DVSTEP with the following meanings: ! 0 the step was successful. ! -1 the requested error could not be achieved. ! -2 corrector convergence could not be achieved. ! -3, -4 fatal error in DVNLSD(can not occur here). ! KUTH = Input flag to DVSTEP showing whether H was reduced by the ! driver. KUTH = 1 if H was reduced, = 0 otherwise. ! L = Integer variable, NQ + 1, current order plus one. ! LMAX = MAXORD + 1 (used for dimensioning). ! LOCJS = A pointer to the saved Jacobian, whose storage starts at ! WM(LOCJS), if JSV = 1. ! LYH = Saved integer pointer to segments of RWORK and IWORK. ! MAXORD = The maximum order of integration method to be allowed. ! METH/MITER = The method flags. See MF. ! MSBJ = The maximum number of steps between J evaluations, = 50. ! MXHNIL = Saved value of optional input MXHNIL. ! MXSTEP = Saved value of optional input MXSTEP. ! N = The number of first-order ODEs, = NEQ. ! NEWH = Saved integer to flag change of H. ! NEWQ = The method order to be used on the next step. ! NHNIL = Saved counter for occurrences of T + H = T. ! NQ = Integer variable, the current integration method order. ! NQNYH = Saved value of NQ*NYH. ! NQWAIT = A counter controlling the frequency of order changes. ! An order change is about to be considered if NQWAIT = 1. ! NSLJ = The number of steps taken as of the last Jacobian update. ! NSLP = Saved value of NST as of last Newton matrix update. ! NYH = Saved value of the initial value of NEQ. ! HU = The step size in t last used. ! NCFN = Number of nonlinear convergence failures so far. ! NETF = The number of error test failures of the integrator so far. ! NFE = The number of f evaluations for the problem so far. ! NJE = The number of Jacobian evaluations so far. ! NLU = The number of matrix LU decompositions so far. ! NNI = Number of nonlinear iterations so far. ! NQU = The method order last used. ! NST = The number of steps taken for the problem so far. ! Block 0. ! Retrieve the necessary flags from the OPTIONS structure and manage ! the storage allocation. ! .. ! .. FIRST EXECUTABLE STATEMENT DVODE ! .. ! Retrieve the local flags from the options structure. IOPT = OPTS%IOPT ITOL = OPTS%ITOL MF = OPTS%MF METH = OPTS%METH MITER = OPTS%MITER MOSS = OPTS%MOSS NG = OPTS%NG ! Allocate the necessary storage for RWORK and IWORK. (Assume that ! both or neither of the arrays are allocated.) ! If we are starting a new problem, deallocate the old RWORK and ! IWORK arrays if they were allocated in a previous call. Also ! manage the event residual arrays. IF (ISTATE==1) THEN IF (ALLOCATED(DTEMP)) THEN DEALLOCATE (DTEMP,YTEMP,STAT=JER) CALL CHECK_STAT(JER,270) END IF IF (ALLOCATED(RWORK)) THEN DEALLOCATE (RWORK,IWORK,ACOR,SAVF,EWT,WM,STAT=JER) CALL CHECK_STAT(JER,280) END IF IF (ALLOCATED(JROOT)) THEN DEALLOCATE (JROOT,G0,G1,GX,STAT=JER) CALL CHECK_STAT(JER,290) END IF IF (ALLOCATED(YMAX)) THEN DEALLOCATE (YMAX,STAT=JER) CALL CHECK_STAT(JER,300) END IF END IF ! If the user has made changes and called DVODE_F90 with ISTATE=3, ! temporarily save the necessary portion of the Nordsieck array ! and then release RWORK and IWORK. Also, save the contents of ! the WM array and release WM. Note: ACOR, SAVF, and EWT do not ! need to be saved. IF (ISTATE==3) THEN IF (IOPT/=1) THEN MAXORD = MORD(METH) ELSE MAXORD = IUSER(5) IF (MAXORD<0) GOTO 520 IF (MAXORD==0) MAXORD = 100 MAXORD = MIN(MAXORD,MORD(METH)) END IF IF (MAXORD=NEQ) GOTO 500 IF (MU<0 .OR. MU>=NEQ) GOTO 510 LWMDIM = (3*ML+2*MU+2)*NEQ ELSE IF (MF==-14 .OR. MF==-15) THEN ML = IUSER(1) MU = IUSER(2) IF (ML<0 .OR. ML>=NEQ) GOTO 500 IF (MU<0 .OR. MU>=NEQ) GOTO 510 LWMDIM = (2*ML+MU+1)*NEQ ELSE IF (MF==16 .OR. MF==17) THEN LWMDIM = 0 ELSE IF (MF==-16 .OR. MF==-17) THEN LWMDIM = 0 ELSE IF (MF==20) THEN LWMDIM = 0 ELSE IF (MF==21 .OR. MF==22) THEN LWMDIM = 2*NEQ**2 ELSE IF (MF==-21 .OR. MF==-22) THEN LWMDIM = NEQ**2 ELSE IF (MF==23) THEN LWMDIM = NEQ ELSE IF (MF==24 .OR. MF==25) THEN ML = IUSER(1) MU = IUSER(2) IF (ML<0 .OR. ML>=NEQ) GOTO 500 IF (MU<0 .OR. MU>=NEQ) GOTO 510 LWMDIM = (3*ML+2*MU+2)*NEQ ELSE IF (MF==-24 .OR. MF==-25) THEN ML = IUSER(1) MU = IUSER(2) IF (ML<0 .OR. ML>=NEQ) GOTO 500 IF (MU<0 .OR. MU>=NEQ) GOTO 510 LWMDIM = (2*ML+MU+1)*NEQ ELSE IF (MF==26 .OR. MF==27) THEN LWMDIM = 0 ELSE IF (MF==-26 .OR. MF==-27) THEN LWMDIM = 0 END IF ! LWMDIM = LWMDIM + 2 ALLOCATE (RWORK(LRW),WM(LWMDIM),STAT=JER) CALL CHECK_STAT(JER,370) RWORK(1:LRW) = ZERO WM(1:LWMDIM) = ZERO IF (.NOT.ALLOCATED(DTEMP)) THEN ALLOCATE (DTEMP(NEQ),YTEMP(NEQ),STAT=JER) CALL CHECK_STAT(JER,380) END IF ALLOCATE (ACOR(NEQ),SAVF(NEQ),EWT(NEQ),STAT=JER) CALL CHECK_STAT(JER,390) ! If necessary, reload the saved portion of the Nordsieck ! array and the WM array, saved above. IF (ISTATE==3) THEN RWORK(1:LYHTEMP) = YHTEMP(1:LYHTEMP) I = MIN(LWMTEMP,LWMDIM) ! WM(1:LWMTEMP) = WMTEMP(1:LWMTEMP) WM(1:I) = WMTEMP(1:I) DEALLOCATE (YHTEMP,WMTEMP,STAT=JER) CALL CHECK_STAT(JER,400) END IF RWORK(1:LRWUSER) = RUSER(1:LRWUSER) ! IUSER: = LIWUSER if MITER = 0 or 3 (MF = 10, 13, 20, 23) ! = LIWUSER + NEQ otherwise ! (ABS(MF) = 11,12,14,15,16,17,21,22,24,25,26,27). LIW = LIWUSER + NEQ IF (MITER==0 .OR. MITER==3) LIW = LIWUSER ALLOCATE (IWORK(LIW),STAT=JER) CALL CHECK_STAT(JER,410) IWORK(1:LIWUSER) = IUSER(1:LIWUSER) ! Allocate the YMAX vector. ALLOCATE (YMAX(NEQ),STAT=JER) CALL CHECK_STAT(JER,420) END IF ! Allocate the event arrays if they haven't already been allocated ! in a previous call. IF (ALLOCATED(JROOT)) THEN ELSE IF (NG>0) THEN ALLOCATE (JROOT(NG),G0(NG),G1(NG),GX(NG),STAT=JER) CALL CHECK_STAT(JER,430) END IF END IF ! Block A. ! This code block is executed on every call. It tests ISTATE and ! ITASK for legality and branches appropriately. ! If ISTATE > 1 but the flag INIT shows that initialization has ! not yet been done, an error return occurs. ! If ISTATE = 1 and TOUT = T, return immediately. ! The user portion of RWORK and IWORK are reloaded since something ! may have changed since the previous visit. RWORK(1:LRWUSER) = RUSER(1:LRWUSER) IWORK(1:LIWUSER) = IUSER(1:LIWUSER) IF (ISTATE<1 .OR. ISTATE>3) GOTO 420 IF (ITASK<1 .OR. ITASK>5) GOTO 430 ITASKC = ITASK IF (ISTATE==1) GOTO 10 IF (INIT/=1) GOTO 440 IF (ISTATE==2) GOTO 130 GOTO 20 10 INIT = 0 IF (ABS(TOUT-T)<=ZERO) THEN RUSER(1:LRWUSER) = RWORK(1:LRWUSER) IUSER(1:LIWUSER) = IWORK(1:LIWUSER) RETURN END IF ! Block B. ! The next code block is executed for the initial call (ISTATE = 1), ! or for a continuation call with parameter changes (ISTATE = 3). ! It contains checking of all input and various initializations. ! First check legality of the non-optional input NEQ, ITOL, IOPT, ! MF, ML, and MU. 20 IF (NEQ<=0) GOTO 450 IF (ISTATE==1) GOTO 30 IF (NEQ>N) GOTO 460 IF (NEQ/=N) GOTO 465 30 N = NEQ IF (ITOL<1 .OR. ITOL>4) GOTO 470 IF (IOPT<0 .OR. IOPT>1) GOTO 480 JSV = SIGN(1,MF) INEWJ = (1-JSV)/2 MFA = ABS(MF) METH = MFA/10 MITER = MFA - 10*METH IF (METH<1 .OR. METH>2) GOTO 490 IF (MITER<0 .OR. MITER>7) GOTO 490 IF (MITER<=3) GOTO 40 IF (MITER<=5) THEN ML = IWORK(1) MU = IWORK(2) IF (ML<0 .OR. ML>=N) GOTO 500 IF (MU<0 .OR. MU>=N) GOTO 510 END IF 40 CONTINUE IF (NG<0) GOTO 700 IF (ISTATE==1) GOTO 50 IF (IRFND==0 .AND. NG/=NGC) GOTO 710 50 NGC = NG ! Next process and check the optional input. IF (IOPT==1) GOTO 60 MAXORD = MORD(METH) MXSTEP = MXSTP0 MXHNIL = MXHNL0 IF (ISTATE==1) H0 = ZERO HMXI = ZERO HMIN = ZERO GOTO 80 60 MAXORD = IWORK(5) IF (MAXORD<0) GOTO 520 IF (MAXORD==0) MAXORD = 100 MAXORD = MIN(MAXORD,MORD(METH)) MXSTEP = IWORK(6) IF (MXSTEP<0) GOTO 530 IF (MXSTEP==0) MXSTEP = MXSTP0 MXHNIL = IWORK(7) IF (MXHNIL<0) GOTO 540 IF (MXHNIL==0) MXHNIL = MXHNL0 IF (ISTATE/=1) GOTO 70 H0 = RWORK(5) IF ((TOUT-T)*H0ZERO) HMXI = ONE/HMAX HMIN = RWORK(7) IF (HMINNEQ) THEN MSG = 'The size of the CONSTRAINED vector' CALL XERRDV(MSG,900,1,0,0,0,0,ZERO,ZERO) MSG = 'must be between 1 and NEQ.' CALL XERRDV(MSG,900,2,0,0,0,0,ZERO,ZERO) END IF DO I = 1, NDX IF (IDX(I)<1 .OR. IDX(I)>N) THEN MSG = 'Each component of THE CONSTRAINED' CALL XERRDV(MSG,910,1,0,0,0,0,ZERO,ZERO) MSG = 'vector must be between 1 and N.' CALL XERRDV(MSG,910,2,0,0,0,0,ZERO,ZERO) END IF END DO END IF ! Check the sub diagonal and super diagonal arrays. IF (MITER==4 .OR. MITER==5) THEN IF (SUBS) THEN DO I = 1, NSUBS IF (SUBDS(I) < 2 .OR. SUBDS(I) > ML+1) THEN MSG = 'Each element of SUB_DIAGONALS' CALL XERRDV(MSG,920,1,0,0,0,0,ZERO,ZERO) MSG = 'must be between 2 and ML + 1.' CALL XERRDV(MSG,920,2,0,0,0,0,ZERO,ZERO) END IF END DO END IF IF (SUPS) THEN DO I = 1, NSUPS IF (SUPDS(I) < 2 .OR. SUPDS(I) > MU + 1) THEN MSG = 'Each element of SUP_DIAGONALS' CALL XERRDV(MSG,930,1,0,0,0,0,ZERO,ZERO) MSG = 'must be between 2 and MU + 1.' CALL XERRDV(MSG,930,2,0,0,0,0,ZERO,ZERO) END IF END DO END IF ! Compute the banded column grouping. IF (SUBS .OR. SUPS) THEN CALL BGROUP(N,EWT,ACOR,YMAX,ML,MU) BUILD_IAJA = .FALSE. BUILD_IAJA = .TRUE. IF (BUILD_IAJA) THEN CALL BANDED_IAJA(N,ML,MU) NZB = IAB(N+1) - 1 END IF END IF END IF IF ((MITER==2 .OR. MITER==5) .AND. USE_JACSP) THEN ! Allocate the arrays needed by DVJAC/JACSPD. IF (ALLOCATED(INDROWDS)) THEN DEALLOCATE (INDROWDS, INDCOLDS, NGRPDS, IPNTRDS, JPNTRDS, & IWADS, IWKDS, IOPTDS, YSCALEDS, WKDS, FACDS) CALL CHECK_STAT(IER,440) END IF ALLOCATE (INDROWDS(1), INDCOLDS(1), NGRPDS(1), IPNTRDS(1), & JPNTRDS(1), IWADS(1), IWKDS(50+N), IOPTDS(5), YSCALEDS(N), & WKDS(3*N), FACDS(N), STAT=IER) CALL CHECK_STAT(IER,450) ! For use in DVJAC: IOPTDS(4) = 0 END IF ! Set work array pointers and check lengths LRW and LIW. Pointers ! to segments of RWORK and IWORK are named by prefixing L to the ! name of the segment. e.g., the segment YH starts at RWORK(LYH). ! Within WM, LOCJS is the location of the saved Jacobian (JSV > 0). 80 LYH = 21 IF (ISTATE==1) NYH = N LENRW = LYH + (MAXORD+1)*NYH - 1 IWORK(17) = LENRW IF (LENRW>LRW) GOTO 580 IF (LENRW/=LRW) GOTO 580 LWM = 1 ! Save MAXORD in case the calling program calls with ISTATE=3. PREVIOUS_MAXORD = MAXORD JCO = MAX(0,JSV) ! IF (MITER==0) LENWM = 2 IF (MITER==0) LENWM = 0 IF (MITER==1 .OR. MITER==2) THEN ! LENWM = 2 + (1+JCO)*N*N ! LOCJS = N*N + 3 LENWM = (1+JCO)*N*N LOCJS = N*N + 1 END IF ! IF (MITER==3) LENWM = N + 2 IF (MITER==3) LENWM = N IF (MITER==4 .OR. MITER==5) THEN MBAND = ML + MU + 1 LENP = (MBAND+ML)*N LENJ = MBAND*N ! LENWM = 2 + LENP + JCO*LENJ ! LOCJS = LENP + 3 LENWM = LENP + JCO*LENJ LOCJS = LENP + 1 END IF IF (MITER==6 .OR. MITER==7) THEN ! LENWM = 2 LENWM = 0 END IF IF (LENWM>LWMDIM) GOTO 730 IF (LENWM/=LWMDIM) GOTO 730 LIWM = 1 LENIW = 30 + N IF (MITER==0 .OR. MITER==3) LENIW = 30 IWORK(18) = LENIW IF (LENIW>LIW) GOTO 590 ! Check RTOL and ATOL for legality. RTOLI = OPTS%RTOL(1) ATOLI = OPTS%ATOL(1) DO I = 1, N IF (ITOL>=3) RTOLI = OPTS%RTOL(I) IF (ITOL==2 .OR. ITOL==4) ATOLI = OPTS%ATOL(I) IF (RTOLI0) WM1 = SQRT(UROUND) ! ISTATC controls the determination of the sparsity arrays ! if the sparse solution option is used. ISTATC = ISTATE GOTO 130 ! Block C. ! The next block is for the initial call only (ISTATE = 1). ! It contains all remaining initializations, the initial call to F, ! and the calculation of the initial step size. ! The error weights in EWT are inverted after being loaded. 100 UROUND = EPSILON(ONE) U125 = UROUND ** 0.125_dp U325 = UROUND ** 0.325_dp ! ISTATC controls the determination of the sparsity arrays if ! the sparse solution option is used. ISTATC = ISTATE TN = T IF (ITASK/=4 .AND. ITASK/=5) GOTO 110 TCRIT = RWORK(1) IF ((TCRIT-TOUT)*(TOUT-T)ZERO .AND. (T+H0-TCRIT)*H0>ZERO) H0 = TCRIT - T 110 JSTART = 0 IF (MITER>0) WM1 = SQRT(UROUND) CCMXJ = PT2 MSBJ = 50 MSBG = 75 NHNIL = 0 NST = 0 NJE = 0 NNI = 0 NCFN = 0 NETF = 0 NLU = 0 NSLJ = 0 NSLAST = 0 HU = ZERO NQU = 0 MB28 = 0 !_______________________________________________________________________ ! *****MA48 build change point. Insert this statement. ! MB48 = 0 !_______________________________________________________________________ NSLG = 0 NGE = 0 ! Initial call to F. (LF0 points to YH(*,2).) LF0 = LYH + NYH CALL F(N,T,Y,RWORK(LF0)) NFE = 1 ! Load the initial value vector in YH. CALL DCOPY_F90(N,Y,1,RWORK(LYH),1) ! Load and invert the EWT array. (H is temporarily set to 1.0.) NQ = 1 H = ONE CALL DEWSET(N,ITOL,OPTS%RTOL,OPTS%ATOL,RWORK(LYH),EWT) DO I = 1, N IF (EWT(I)<=ZERO) GOTO 620 EWT(I) = ONE/EWT(I) END DO NNZ = 0 NGP = 0 IF (OPTS%SPARSE) THEN ISTATC = ISTATE END IF IF (ABS(H0)>ZERO) GOTO 120 ! Call DVHIN to set initial step size H0 to be attempted. CALL DVHIN(N,T,RWORK(LYH),RWORK(LF0),F,TOUT,EWT,ITOL,OPTS%ATOL,Y,ACOR, & H0,NITER,IER) NFE = NFE + NITER IF (IER/=0) GOTO 630 ! Adjust H0 if necessary to meet HMAX bound. 120 RH = ABS(H0)*HMXI IF (RH>ONE) H0 = H0/RH ! Load H with H0 and scale YH(*,2) by H0. H = H0 CALL DSCAL_F90(N,H0,RWORK(LF0),1) ! GOTO 270 ! Check for a zero of g at T. IRFND = 0 TOUTC = TOUT IF (NGC==0) GOTO 210 CALL DVCHECK(1,GFUN,NEQ,Y,RWORK(LYH),NYH,G0,G1,GX,IRT) IF (IRT==0) GOTO 210 GOTO 720 ! Block D. ! The next code block is for continuation calls only (ISTATE = 2 or 3) ! and is to check stop conditions before taking a step. 130 NSLAST = NST IRFP = IRFND IF (NGC==0) GOTO 140 IF (ITASK==1 .OR. ITASK==4) TOUTC = TOUT CALL DVCHECK(2,GFUN,NEQ,Y,RWORK(LYH),NYH,G0,G1,GX,IRT) IF (IRT/=1) GOTO 140 IRFND = 1 ISTATE = 3 T = T0ST GOTO 330 140 CONTINUE IRFND = 0 IF (IRFP==1 .AND. (ABS(TLAST-TN)>ZERO) .AND. ITASK==2) GOTO 310 KUTH = 0 GOTO (150,200,160,170,180) ITASK 150 IF ((TN-TOUT)*HZERO) GOTO 640 IF ((TN-TOUT)*HZERO) GOTO 650 IF ((TCRIT-TOUT)*HZERO) GOTO 650 190 HMX = ABS(TN) + ABS(H) IHIT = ABS(TN-TCRIT) <= HUN*UROUND*HMX IF (IHIT) GOTO 310 TNEXT = TN + HNEW*(ONE+FOUR*UROUND) IF ((TNEXT-TCRIT)*H<=ZERO) GOTO 200 H = (TCRIT-TN)*(ONE-FOUR*UROUND) KUTH = 1 ! Block E. ! The next block is normally executed for all calls and contains ! the call to the one-step core integrator DVSTEP. This is a ! looping point for the integration steps. ! First check for too many steps being taken, update EWT(if not ! at start of problem), check for too much accuracy being ! requested, and check for H below the roundoff level in T. 200 CONTINUE IF ((NST-NSLAST)>=MXSTEP) GOTO 340 CALL DEWSET(N,ITOL,OPTS%RTOL,OPTS%ATOL,RWORK(LYH),EWT) DO I = 1, N IF (EWT(I)<=ZERO) GOTO 350 EWT(I) = ONE/EWT(I) END DO 210 TOLSF = UROUND*DVNORM(N,RWORK(LYH),EWT) IPCUTH = -1 IF (TOLSF<=ONE) GOTO 220 TOLSF = TOLSF*TWO IF (NST==0) GOTO 670 GOTO 360 220 CONTINUE IPCUTH = IPCUTH + 1 IF (IPCUTH>=IPCUTH_MAX) THEN MSG = 'Too many step reductions to prevent' CALL XERRDV(MSG,940,1,0,0,0,0,ZERO,ZERO) MSG = 'an infeasible prediction.' CALL XERRDV(MSG,940,1,0,0,0,0,ZERO,ZERO) ! Retract the solution to TN: CALL DVNRDN(RWORK(LYH),NYH,N,NQ) ACOR(1:N) = ZERO ISTATE = -7 GOTO 410 END IF IF (ABS((TN+H)-TN)>ZERO) GOTO 230 NHNIL = NHNIL + 1 IF (NHNIL>MXHNIL) GOTO 230 MSG = 'Warning: internal T(=R1) and H(=R2) are such that' CALL XERRDV(MSG,950,1,0,0,0,0,ZERO,ZERO) MSG = 'in the machine, T + H = T on the next step.' CALL XERRDV(MSG,950,1,0,0,0,0,ZERO,ZERO) MSG = '(H = step size). The solver will continue anyway.' CALL XERRDV(MSG,950,1,0,0,0,2,TN,H) IF (NHNILLB(I) .AND. RWORK(LYH+ & IDX(I)-1)UB(I))) THEN ! Retract: CALL DVNRDN(RWORK(LYH),NYH,N,NQ) H = HALF*H ETA = HALF ! Rescale: CALL DVNRDS(RWORK(LYH),NYH,N,L,ETA) GOTO 220 END IF END DO ! Retract: CALL DVNRDN(RWORK(LYH),NYH,N,NQ) ACOR(1:N) = ZERO END IF ! CALL DVSTEP(Y,YH,LDYH,YH1,EWT,SAVF,ACOR,WM,IWM,F,JAC, & ! VNLS,OPTS%ATOL,ITOL) !_______________________________________________________________________ IF (MITER/=6 .AND. MITER/=7) THEN CALL DVSTEP(Y,RWORK(LYH),NYH,RWORK(LYH),EWT,SAVF,ACOR,WM, & IWORK(LIWM),F,JAC,DVNLSD,OPTS%ATOL,ITOL) ELSE CALL DVSTEP(Y,RWORK(LYH),NYH,RWORK(LYH),EWT,SAVF,ACOR,WM, & IWORK(LIWM),F,JAC,DVNLSS28,OPTS%ATOL,ITOL) END IF ! *****MA48 build change point. Replace above with these statements. ! IF (MITER /= 6 .AND. MITER /= 7) THEN ! CALL DVSTEP(Y,RWORK(LYH),NYH,RWORK(LYH),EWT,SAVF,ACOR,WM, & ! IWORK(LIWM),F,JAC,DVNLSD,OPTS%ATOL,ITOL) ! ELSE ! IF (USE_MA48_FOR_SPARSE) THEN ! CALL DVSTEP(Y,RWORK(LYH),NYH,RWORK(LYH),EWT,SAVF,ACOR,WM, & ! IWORK(LIWM), F, JAC, DVNLSS48,OPTS%ATOL,ITOL) ! ELSE ! CALL DVSTEP(Y,RWORK(LYH),NYH,RWORK(LYH),EWT,SAVF,ACOR,WM, & ! IWORK(LIWM),F,JAC,DVNLSS28,OPTS%ATOL,ITOL) ! END IF ! END IF !_______________________________________________________________________ KGO = 1 - KFLAG ! Branch on KFLAG. Note: In this version, KFLAG can not be set to ! -3; KFLAG = 0, -1, -2. GOTO (240,370,380) KGO ! Block F. ! The following block handles the case of a successful return from the ! core integrator (KFLAG = 0). Test for stop conditions. 240 INIT = 1 KUTH = 0 GOTO (250,310,270,280,300) ITASK ! ITASK = 1. If TOUT has been reached, interpolate. 250 CONTINUE IF (NGC==0) GOTO 260 CALL DVCHECK(3,GFUN,NEQ,Y,RWORK(LYH),NYH,G0,G1,GX,IRT) IF (IRT/=1) GOTO 260 IRFND = 1 ISTATE = 3 T = T0ST GOTO 330 260 CONTINUE IF ((TN-TOUT)*H=ZERO) GOTO 310 GOTO 200 ! ITASK = 4. See if TOUT or TCRIT was reached. Adjust H if necessary. 280 IF ((TN-TOUT)*H=SIZEST) GOTO 400 BIG = SIZEST IMXER = I 400 END DO IWORK(16) = IMXER ! Set Y vector, T, and optional output. 410 CONTINUE CALL DCOPY_F90(N,RWORK(LYH),1,Y,1) T = TN RWORK(11) = HU RWORK(12) = H RWORK(13) = TN IWORK(10) = NGE IWORK(11) = NST IWORK(12) = NFE IWORK(13) = NJE IWORK(14) = NQU IWORK(15) = NQ IWORK(19) = NLU IWORK(20) = NNI IWORK(21) = NCFN IWORK(22) = NETF TLAST = T RUSER(1:LRWUSER) = RWORK(1:LRWUSER) IUSER(1:LIWUSER) = IWORK(1:LIWUSER) RETURN ! Block I. ! The following block handles all error returns due to illegal input ! (ISTATE = -3), as detected before calling the core integrator. ! First the error message routine is called. If the illegal input ! is a negative ISTATE, the run is aborted (apparent infinite loop). 420 MSG = 'ISTATE(=I1) is illegal.' CALL XERRDV(MSG,1020,1,1,ISTATE,0,0,ZERO,ZERO) IF (ISTATE<0) GOTO 750 GOTO 740 430 MSG = 'ITASK(=I1) is illegal.' CALL XERRDV(MSG,1030,1,1,ITASK,0,0,ZERO,ZERO) GOTO 740 440 MSG = 'ISTATE(=I1) > 1 but DVODE is not initialized.' CALL XERRDV(MSG,1040,1,1,ISTATE,0,0,ZERO,ZERO) GOTO 740 450 MSG = 'NEQ (=I1) < 1.' CALL XERRDV(MSG,1050,1,1,NEQ,0,0,ZERO,ZERO) GOTO 740 460 MSG = 'ISTATE = 3 and NEQ increased (I1 to I2).' CALL XERRDV(MSG,1060,1,2,N,NEQ,0,ZERO,ZERO) GOTO 740 465 MSG = 'This version of DVODE requires does not allow NEQ to be reduced.' CALL XERRDV(MSG,1070,2,0,0,0,0,ZERO,ZERO) GOTO 740 470 MSG = 'ITOL(=I1) is illegal.' CALL XERRDV(MSG,1080,1,1,ITOL,0,0,ZERO,ZERO) GOTO 740 480 MSG = 'IOPT(=I1) is illegal.' CALL XERRDV(MSG,1090,1,1,IOPT,0,0,ZERO,ZERO) GOTO 740 490 MSG = 'MF(=I1) is illegal.' CALL XERRDV(MSG,1100,1,1,MF,0,0,ZERO,ZERO) GOTO 740 500 MSG = 'ML(=I1) illegal: < 0 or >= NEQ (=I2)' CALL XERRDV(MSG,1110,1,2,ML,NEQ,0,ZERO,ZERO) GOTO 740 510 MSG = 'MU(=I1) illegal: < 0 or >= NEQ (=I2)' CALL XERRDV(MSG,1120,1,2,MU,NEQ,0,ZERO,ZERO) GOTO 740 520 MSG = 'MAXORD(=I1) < 0.' CALL XERRDV(MSG,1130,1,1,MAXORD,0,0,ZERO,ZERO) GOTO 740 530 MSG = 'MXSTEP(=I1) < 0.' CALL XERRDV(MSG,1140,1,1,MXSTEP,0,0,ZERO,ZERO) GOTO 740 540 MSG = 'MXHNIL(=I1) < 0.' CALL XERRDV(MSG,1150,1,1,MXHNIL,0,0,ZERO,ZERO) GOTO 740 550 MSG = 'TOUT(=R1) is behind T(=R2).' CALL XERRDV(MSG,1160,1,0,0,0,2,TOUT,T) MSG = 'The integration direction is given by H0 (=R1).' CALL XERRDV(MSG,1160,1,0,0,0,1,H0,ZERO) GOTO 740 560 MSG = 'HMAX(=R1) < 0.' CALL XERRDV(MSG,1170,1,0,0,0,1,HMAX,ZERO) GOTO 740 570 MSG = 'HMIN(=R1) < 0.' CALL XERRDV(MSG,1180,1,0,0,0,1,HMIN,ZERO) GOTO 740 580 CONTINUE MSG = 'RWORK length needed, LENRW(=I1) > LRW(=I2)' CALL XERRDV(MSG,1190,1,2,LENRW,LRW,0,ZERO,ZERO) GOTO 740 590 CONTINUE MSG = 'IWORK length needed, LENIW(=I1) > LIW(=I2)' CALL XERRDV(MSG,1200,1,2,LENIW,LIW,0,ZERO,ZERO) GOTO 740 600 MSG = 'RTOL(I1) is R1 < 0.' CALL XERRDV(MSG,1210,1,1,I,0,1,RTOLI,ZERO) GOTO 740 610 MSG = 'ATOL(I1) is R1 < 0.' CALL XERRDV(MSG,1220,1,1,I,0,1,ATOLI,ZERO) GOTO 740 620 EWTI = EWT(I) MSG = 'EWT(I1) is R1 <= 0.' CALL XERRDV(MSG,1230,1,1,I,0,1,EWTI,ZERO) GOTO 740 630 CONTINUE MSG = 'TOUT(=R1) too close to T(=R2) to start.' CALL XERRDV(MSG,1240,1,0,0,0,2,TOUT,T) GOTO 740 640 CONTINUE MSG = 'ITASK = I1 and TOUT(=R1) < TCUR - HU(=R2).' CALL XERRDV(MSG,1250,1,1,ITASK,0,2,TOUT,TP) GOTO 740 650 CONTINUE MSG = 'ITASK = 4 or 5 and TCRIT(=R1) < TCUR(=R2).' CALL XERRDV(MSG,1260,1,0,0,0,2,TCRIT,TN) GOTO 740 660 CONTINUE MSG = 'ITASK = 4 or 5 and TCRIT(=R1) < TOUT(=R2).' CALL XERRDV(MSG,1270,1,0,0,0,2,TCRIT,TOUT) GOTO 740 670 MSG = 'At the start of the problem, too much' CALL XERRDV(MSG,1280,1,0,0,0,0,ZERO,ZERO) MSG = 'accuracy was requested for precision' CALL XERRDV(MSG,1280,1,0,0,0,1,TOLSF,ZERO) MSG = 'of machine: see TOLSF(=R1).' CALL XERRDV(MSG,1280,1,0,0,0,1,TOLSF,ZERO) RWORK(14) = TOLSF GOTO 740 680 MSG = 'Trouble from DVINDY. ITASK = I1, TOUT = R1.' CALL XERRDV(MSG,1290,1,1,ITASK,0,1,TOUT,ZERO) GOTO 740 690 MSG = 'SETH must be nonnegative.' CALL XERRDV(MSG,1300,1,0,0,0,0,ZERO,ZERO) GOTO 740 700 MSG = 'NG(=I1) < 0.' CALL XERRDV(MSG,1310,0,1,NG,0,0,ZERO,ZERO) GOTO 740 710 MSG = 'NG changed (from I1 to I2) illegally, i.e.,' CALL XERRDV(MSG,1320,1,0,0,0,0,ZERO,ZERO) MSG = 'not immediately after a root was found.' CALL XERRDV(MSG,1320,1,2,NGC,NG,0,ZERO,ZERO) GOTO 740 720 MSG = 'One or more components of g has a root' CALL XERRDV(MSG,1330,1,0,0,0,0,ZERO,ZERO) MSG = 'too near to the initial point.' CALL XERRDV(MSG,1330,1,0,0,0,0,ZERO,ZERO) GOTO 740 730 CONTINUE MSG = 'WM length needed, LENWM(=I1) > LWMDIM(=I2)' CALL XERRDV(MSG,1340,1,2,LENWM,LWMDIM,0,ZERO,ZERO) 740 CONTINUE ISTATE = -3 RUSER(1:LRWUSER) = RWORK(1:LRWUSER) IUSER(1:LIWUSER) = IWORK(1:LIWUSER) RETURN 750 MSG = 'Run aborted: apparent infinite loop.' CALL XERRDV(MSG,1350,2,0,0,0,0,ZERO,ZERO) RUSER(1:LRWUSER) = RWORK(1:LRWUSER) IUSER(1:LIWUSER) = IWORK(1:LIWUSER) RETURN END SUBROUTINE DVODE !_______________________________________________________________________ SUBROUTINE DVHIN(N,T0,Y0,YDOT,F,TOUT,EWT,ITOL,ATOL,Y,TEMP,H0, & NITER,IER) ! .. ! Calculate the initial step size. ! .. ! This routine computes the step size, H0, to be attempted on the ! first step, when the user has not supplied a value for this. ! First we check that TOUT - T0 differs significantly from zero. Then ! an iteration is done to approximate the initial second derivative ! and this is used to define h from w.r.m.s.norm(h**2 * yddot / 2) = 1. ! A bias factor of 1/2 is applied to the resulting h. ! The sign of H0 is inferred from the initial values of TOUT and T0. ! Communication with DVHIN is done with the following variables: ! N = Size of ODE system, input. ! T0 = Initial value of independent variable, input. ! Y0 = Vector of initial conditions, input. ! YDOT = Vector of initial first derivatives, input. ! F = Name of subroutine for right-hand side f(t,y), input. ! TOUT = First output value of independent variable ! UROUND = Machine unit roundoff ! EWT, ITOL, ATOL = Error weights and tolerance parameters ! as described in the driver routine, input. ! Y, TEMP = Work arrays of length N. ! H0 = Step size to be attempted, output. ! NITER = Number of iterations (and of f evaluations) to compute H0, ! output. ! IER = The error flag, returned with the value ! IER = 0 if no trouble occurred, or ! IER = -1 if TOUT and T0 are considered too close to proceed. ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. KPP_REAL, INTENT (INOUT) :: H0 KPP_REAL, INTENT (IN) :: T0, TOUT INTEGER :: IER INTEGER, INTENT (IN) :: ITOL, N INTEGER, INTENT (INOUT) :: NITER ! .. ! .. Array Arguments .. KPP_REAL, INTENT (IN) :: ATOL(*), EWT(*), Y0(*) KPP_REAL, INTENT (INOUT) :: TEMP(*), Y(*), YDOT(*) ! .. ! .. Subroutine Arguments .. EXTERNAL F ! .. ! .. Local Scalars .. KPP_REAL :: AFI, ATOLI, DELYI, H, HG, HLB, HNEW, HRAT, HUB, T1, & TDIST, TROUND, YDDNRM INTEGER :: I, ITER ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, SIGN, SQRT ! .. ! .. FIRST EXECUTABLE STATEMENT DVHIN ! .. NITER = 0 TDIST = ABS(TOUT-T0) TROUND = UROUND*MAX(ABS(T0),ABS(TOUT)) IF (TDISTDELYI) HUB = DELYI/AFI END DO ! Set initial guess for H as geometric mean of upper and ! lower bounds. ITER = 0 HG = SQRT(HLB*HUB) ! If the bounds have crossed, exit with the mean value. IF (HUBTWO) THEN HNEW = SQRT(TWO/YDDNRM) ELSE HNEW = SQRT(HG*HUB) END IF ITER = ITER + 1 ! Test the stopping conditions. ! Stop if the new and previous h values differ by a factor of < 2. ! Stop if four iterations have been done. Also, stop with previous h ! if HNEW/HG > 2 after first iteration, as this probably means that ! the second derivative value is bad because of cancellation error. IF (ITER>=4) GOTO 20 HRAT = HNEW/HG IF ((HRAT>HALF) .AND. (HRAT=2) .AND. (HNEW>TWO*HG)) THEN HNEW = HG GOTO 20 END IF HG = HNEW GOTO 10 ! Iteration done. Apply bounds, bias factor, and sign. Then exit. 20 H0 = HNEW*HALF IF (H0HUB) H0 = HUB 30 H0 = SIGN(H0,TOUT-T0) NITER = ITER IER = 0 RETURN ! Error return for TOUT - T0 too small. 40 IER = -1 RETURN END SUBROUTINE DVHIN !_______________________________________________________________________ SUBROUTINE DVINDY_CORE(T,K,YH,LDYH,DKY,IFLAG) ! .. ! Interpolate the solution and derivative. ! .. ! DVINDY_CORE computes interpolated values of the K-th derivative ! of the dependent variable vector y, and stores it in DKY. This ! routine is called within the package with K = 0 and T = TOUT, ! but may also be called by the user for any K up to the current ! order. (See detailed instructions in the usage documentation.) ! The computed values in DKY are gotten by interpolation using the ! Nordsieck history array YH. This array corresponds uniquely to a ! vector-valued polynomial of degree NQCUR or less, and DKY is set ! to the K-th derivative of this polynomial at T. ! The formula for DKY is: ! q ! DKY(i) = sum c(j,K) * (T - TN)**(j-K) * H**(-j) * YH(i,j+1) ! j=K ! where c(j,K) = j*(j-1)*...*(j-K+1), q = NQCUR, TN = TCUR, H = HCUR. ! The quantities NQ = NQCUR, L = NQ+1, N, TN, and H are ! communicated by PRIVATE variables. The above sum is done in reverse ! order. ! IFLAG is returned negative if either K or T is out of bounds. ! Discussion above and comments in driver explain all variables. ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. KPP_REAL, INTENT (IN) :: T INTEGER, INTENT (INOUT) :: IFLAG INTEGER, INTENT (IN) :: K, LDYH ! .. ! .. Array Arguments .. KPP_REAL, INTENT (INOUT) :: DKY(*), YH(LDYH,*) ! .. ! .. Local Scalars .. KPP_REAL :: C, R, S, TFUZZ, TN1, TP INTEGER :: IC, J, JB, JB2, JJ, JJ1, JP1 CHARACTER (80) :: MSG ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, REAL, SIGN ! .. ! .. FIRST EXECUTABLE STATEMENT DVINDY_CORE ! .. IFLAG = 0 IF (K<0 .OR. K>NQ) GOTO 40 ! TFUZZ = HUN * UROUND * (TN + HU) TFUZZ = HUN*UROUND*SIGN(ABS(TN)+ABS(HU),HU) TP = TN - HU - TFUZZ TN1 = TN + TFUZZ IF ((T-TP)*(T-TN1)>ZERO) GOTO 50 S = (T-TN)/H IC = 1 IF (K==0) GOTO 10 JJ1 = L - K DO JJ = JJ1, NQ IC = IC*JJ END DO 10 C = REAL(IC) DKY(1:N) = C*YH(1:N,L) IF (K==NQ) GOTO 30 JB2 = NQ - K DO JB = 1, JB2 J = NQ - JB JP1 = J + 1 IC = 1 IF (K==0) GOTO 20 JJ1 = JP1 - K DO JJ = JJ1, J IC = IC*JJ END DO 20 C = REAL(IC) DKY(1:N) = C*YH(1:N,JP1) + S*DKY(1:N) END DO 30 R = H**(-K) CALL DSCAL_F90(N,R,DKY,1) RETURN 40 MSG = 'Error in DVINDY, K(=I1) is illegal.' CALL XERRDV(MSG,1360,1,1,K,0,0,ZERO,ZERO) IFLAG = -1 RETURN 50 MSG = 'Error in DVINDY, T(=R1) is illegal. T is not' CALL XERRDV(MSG,1370,1,0,0,0,1,T,ZERO) MSG = 'in interval TCUR - HU(= R1) to TCUR(=R2)' CALL XERRDV(MSG,1370,1,0,0,0,2,TP,TN) IFLAG = -2 RETURN END SUBROUTINE DVINDY_CORE !_______________________________________________________________________ SUBROUTINE DVINDY_BNDS(T,K,YH,LDYH,DKY,IFLAG) ! .. ! Interpolate the solution and derivative and enforce nonnegativity ! (used only if user calls DVINDY and the BOUNDS option is in ! use). ! .. ! This version of DVINDY_CORE enforces nonnegativity and is called ! only by DVINDY (which is called only by the user). It uses the ! private YNNEG array produced by a call to DVINDY_CORE from DVINDY ! to enforce nonnegativity. ! DVINDY_BNDS computes interpolated values of the K-th derivative ! of the dependent variable vector y, and stores it in DKY. This ! routine is called within the package with K = 0 and T = TOUT, ! but may also be called by the user for any K up to the current ! order. (See detailed instructions in the usage documentation.) ! The computed values in DKY are gotten by interpolation using the ! Nordsieck history array YH. This array corresponds uniquely to a ! vector-valued polynomial of degree NQCUR or less, and DKY is set ! to the K-th derivative of this polynomial at T. ! The formula for DKY is: ! q ! DKY(i) = sum c(j,K) * (T - TN)**(j-K) * H**(-j) * YH(i,j+1) ! j=K ! where c(j,K) = j*(j-1)*...*(j-K+1), q = NQCUR, TN = TCUR, H = HCUR. ! The quantities NQ = NQCUR, L = NQ+1, N, TN, and H are ! communicated by PRIVATE variables. The above sum is done in reverse ! order. ! IFLAG is returned negative if either K or T is out of bounds. ! Discussion above and comments in driver explain all variables. ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. KPP_REAL, INTENT (IN) :: T INTEGER, INTENT (INOUT) :: IFLAG INTEGER, INTENT (IN) :: K, LDYH ! .. ! .. Array Arguments .. KPP_REAL, INTENT (INOUT) :: DKY(*), YH(LDYH,*) ! .. ! .. Local Scalars .. KPP_REAL :: C, R, S, TFUZZ, TN1, TP INTEGER :: I, IC, J, JB, JB2, JJ, JJ1, JP1 CHARACTER (80) :: MSG ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, REAL, SIGN ! .. ! .. FIRST EXECUTABLE STATEMENT DVINDY_BNDS ! .. IFLAG = 0 IF (K==0) GOTO 50 IF (K<0 .OR. K>NQ) GOTO 40 ! TFUZZ = HUN * UROUND * (TN + HU) TFUZZ = HUN*UROUND*SIGN(ABS(TN)+ABS(HU),HU) TP = TN - HU - TFUZZ TN1 = TN + TFUZZ IF ((T-TP)*(T-TN1)>ZERO) GOTO 60 S = (T-TN)/H IC = 1 IF (K==0) GOTO 10 JJ1 = L - K DO JJ = JJ1, NQ IC = IC*JJ END DO 10 C = REAL(IC) DKY(1:N) = C*YH(1:N,L) IF (BOUNDS) THEN DO I = 1, NDX IF (YNNEG(IDX(I))UB(I)) DKY(IDX(I)) & = ZERO END DO END IF IF (K==NQ) GOTO 30 JB2 = NQ - K DO JB = 1, JB2 J = NQ - JB JP1 = J + 1 IC = 1 IF (K==0) GOTO 20 JJ1 = JP1 - K DO JJ = JJ1, J IC = IC*JJ END DO 20 C = REAL(IC) DKY(1:N) = C*YH(1:N,JP1) + S*DKY(1:N) IF (BOUNDS) THEN DO I = 1, NDX IF (YNNEG(IDX(I))UB(I)) DKY(IDX(I)) & = ZERO END DO END IF END DO 30 R = H**(-K) CALL DSCAL_F90(N,R,DKY,1) RETURN 40 MSG = 'Error in DVINDY, K(=I1) is illegal.' CALL XERRDV(MSG,1380,1,1,K,0,0,ZERO,ZERO) IFLAG = -1 RETURN 50 MSG = 'DVINDY_BNDS cannot be called with k = 0.' CALL XERRDV(MSG,1390,1,0,0,0,0,ZERO,ZERO) IFLAG = -1 RETURN 60 MSG = 'Error in DVINDY, T(=R1) is illegal. T is not' CALL XERRDV(MSG,1400,1,0,0,0,1,T,ZERO) MSG = 'not in interval TCUR - HU(= R1) to TCUR(=R2)' CALL XERRDV(MSG,1400,1,0,0,0,2,TP,TN) IFLAG = -2 RETURN END SUBROUTINE DVINDY_BNDS !_______________________________________________________________________ SUBROUTINE DVINDY(T,K,DKY,IFLAG) ! .. ! This is a dummy interface to allow the user to interpolate the ! solution and the derivative (not called by DVODE_F90). ! .. ! May be used if the user wishes to interpolate solution or ! derivative following a successful return from DVODE_F90 ! DVINDY computes interpolated values of the K-th derivative of ! the dependent variable vector y, and stores it in DKY. This ! routine is called within the package with K = 0 and T = TOUT, ! but may also be called by the user for any K up to the current ! order. (See detailed instructions in the usage documentation.) ! The computed values in DKY are gotten by interpolation using the ! Nordsieck history array YH. This array corresponds uniquely to a ! vector-valued polynomial of degree NQCUR or less, and DKY is set ! to the K-th derivative of this polynomial at T. ! IFLAG is returned negative if either K or T is out of bounds. ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. KPP_REAL, INTENT (IN) :: T INTEGER, INTENT (INOUT) :: IFLAG INTEGER, INTENT (IN) :: K ! .. ! .. Array Arguments .. KPP_REAL, INTENT (INOUT) :: DKY(*) ! .. ! .. Local Scalars .. INTEGER :: I, IER ! .. ! .. Intrinsic Functions .. INTRINSIC ALLOCATED, SIZE ! .. ! .. FIRST EXECUTABLE STATEMENT DVINDY ! .. CALL DVINDY_CORE(T,K,RWORK(LYH),N,DKY,IFLAG) IF (.NOT.BOUNDS) RETURN IF (K==0) THEN ! Interpolate only the solution. CALL DVINDY_CORE(T,K,RWORK(LYH),N,DKY,IFLAG) ! Enforce bounds. DO I = 1, NDX IF (DKY(IDX(I))UB(I)) DKY(IDX(I)) = UB(I) END DO RETURN END IF ! k > 0 - derivatives requested. ! Make sure space is available for the interpolated solution. IF (ALLOCATED(YNNEG)) THEN IF (SIZE(YNNEG)= N, the first dimension of YH. ! N is the number of ODEs in the system. ! YH1 = A one-dimensional array occupying the same space as YH. ! EWT = An array of length N containing multiplicative weights ! for local error measurements. Local errors in y(i) are ! compared to 1.0/EWT(i) in various error tests. ! SAVF = An array of working storage, of length N. ! also used for input of YH(*,MAXORD+2) when JSTART = -1 ! and MAXORD < the current order NQ. ! ACOR = A work array of length N, used for the accumulated ! corrections. On a successful return, ACOR(i) contains ! the estimated one-step local error in y(i). ! WM,IWM = Real and integer work arrays associated with matrix ! operations in DVNLSD. ! F = Dummy name for the user supplied subroutine for f. ! JAC = Dummy name for the user supplied Jacobian subroutine. ! DVNLSD = Dummy name for the nonlinear system solving subroutine, ! whose real name is dependent on the method used. ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: LDYH, ITOL ! .. ! .. Array Arguments .. KPP_REAL, INTENT (INOUT) :: ACOR(*), EWT(*), SAVF(*), & WM(*), Y(*), YH(LDYH,*), YH1(*) KPP_REAL, INTENT (IN) :: ATOL(*) INTEGER, INTENT (INOUT) :: IWM(*) ! .. ! .. Subroutine Arguments .. EXTERNAL F, JAC, VNLS ! .. ! .. Local Scalars .. KPP_REAL :: CNQUOT, DDN, DSM, DUP, ETAQ, ETAQM1, ETAQP1, FLOTL, R, & TOLD INTEGER :: I, I1, I2, IBACK, J, JB, NCF, NFLAG ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, REAL ! .. ! .. FIRST EXECUTABLE STATEMENT DVSTEP ! .. KFLAG = 0 TOLD = TN NCF = 0 JCUR = 0 NFLAG = 0 IF (JSTART>0) GOTO 10 IF (JSTART==-1) GOTO 30 ! On the first call, the order is set to 1, and other variables are ! initialized. ETAMAX is the maximum ratio by which H can be increased ! in a single step. It is normally 10, but is larger during the first ! step to compensate for the small initial H. If a failure occurs ! (in corrector convergence or error test), ETAMAX is set to 1 for ! the next increase. LMAX = MAXORD + 1 NQ = 1 L = 2 NQNYH = NQ*LDYH TAU(1) = H PRL1 = ONE RC = ZERO ETAMAX = ETAMX1 NQWAIT = 2 HSCAL = H GOTO 70 ! Take preliminary actions on a normal continuation step (JSTART > 0). ! If the driver changed H, then ETA must be reset and NEWH set to 1. ! If a change of order was dictated on the previous step, then it is ! done here and appropriate adjustments in the history are made. ! On an order decrease, the history array is adjusted by DVJUST. ! On an order increase, the history array is augmented by a column. ! On a change of step size H, the history array YH is rescaled. 10 CONTINUE IF (KUTH==1) THEN ETA = MIN(ETA,H/HSCAL) NEWH = 1 END IF 20 IF (NEWH==0) GOTO 70 IF (NEWQ==NQ) GOTO 60 IF (NEWQNQ) THEN CALL DVJUST(YH,LDYH,1) NQ = NEWQ L = NQ + 1 NQWAIT = L GOTO 60 END IF ! The following block handles preliminaries needed when JSTART = -1. ! If N was reduced, zero out part of YH to avoid undefined references. ! If MAXORD was reduced to a value less than the tentative order NEWQ, ! then NQ is set to MAXORD, and a new H ratio ETA is chosen. ! Otherwise, we take the same preliminary actions as for JSTART > 0. ! In any case, NQWAIT is reset to L = NQ + 1 to prevent further ! changes in order for that many steps. The new H ratio ETA is ! limited by the input H if KUTH = 1, by HMIN if KUTH = 0, and by ! HMXI in any case. Finally, the history array YH is rescaled. 30 CONTINUE LMAX = MAXORD + 1 IF (N==LDYH) GOTO 40 I1 = 1 + (NEWQ+1)*LDYH I2 = (MAXORD+1)*LDYH IF (I1>I2) GOTO 40 YH1(I1:I2) = ZERO 40 IF (NEWQ<=MAXORD) GOTO 50 FLOTL = REAL(LMAX) IF (MAXORDONE) GOTO 100 ! After a successful step, update the YH and TAU arrays and decrement ! NQWAIT. If NQWAIT is then 1 and NQ < MAXORD, then ACOR is saved ! for use in a possible order increase on the next step. ! If ETAMAX = 1 (a failure occurred this step), keep NQWAIT >= 2. KFLAG = 0 NST = NST + 1 HU = H NQU = NQ DO IBACK = 1, NQ I = L - IBACK TAU(I+1) = TAU(I) END DO TAU(1) = H IF (BOUNDS) THEN ! Original: ! CALL DAXPY_F90(N,EL(1),ACOR,1,YH(1,1),1) ! CALL DAXPY_F90(N,EL(2),ACOR,1,YH(1,2),1) CALL DAXPY_F90(N,EL(1),ACOR,1,YH(1:N,1),1) CALL DAXPY_F90(N,EL(2),ACOR,1,YH(1:N,2),1) ! Take care of roundoff causing y(t) to be slightly unequal ! to the constraint bound. DO J = 1, NDX YH(IDX(J),1) = MAX(YH(IDX(J),1),LB(J)) Y(IDX(J)) = MAX(Y(IDX(J)),LB(J)) YH(IDX(J),1) = MIN(YH(IDX(J),1),UB(J)) Y(IDX(J)) = MIN(Y(IDX(J)),UB(J)) END DO ! Update the higher derivatives and project to zero if necessary. IF (L>2) THEN DO J = 3, L ! Original: ! CALL DAXPY_F90(N,EL(J),ACOR,1,YH(1,J),1) CALL DAXPY_F90(N,EL(J),ACOR,1,YH(1:N,J),1) END DO END IF ELSE ! Proceed as usual. DO J = 1, L ! Original: ! CALL DAXPY_F90(N,EL(J),ACOR,1,YH(1,J),1) CALL DAXPY_F90(N,EL(J),ACOR,1,YH(1:N,J),1) END DO END IF NQWAIT = NQWAIT - 1 IF ((L==LMAX) .OR. (NQWAIT/=1)) GOTO 90 ! Original: ! CALL DCOPY_F90(N,ACOR,1,YH(1,LMAX),1) CALL DCOPY_F90(N,ACOR,1,YH(1:N,LMAX),1) CONP = TQ(5) 90 IF (ABS(ETAMAX-ONE)>0) GOTO 130 IF (NQWAIT<2) NQWAIT = 2 NEWQ = NQ NEWH = 0 ETA = ONE HNEW = H GOTO 250 ! The error test failed. KFLAG keeps track of multiple failures. ! Restore TN and the YH array to their previous values, and prepare ! to try the step again. Compute the optimum step size for the ! same order. After repeated failures, H is forced to decrease ! more rapidly. 100 KFLAG = KFLAG - 1 NETF = NETF + 1 NFLAG = -2 TN = TOLD I1 = NQNYH + 1 DO JB = 1, NQ I1 = I1 - LDYH DO I = I1, NQNYH YH1(I) = YH1(I) - YH1(I+LDYH) END DO END DO IF (ABS(H)<=HMIN*ONEPSM) GOTO 220 ETAMAX = ONE IF (KFLAG<=KFC) GOTO 110 ! Compute ratio of new H to current H at the current order. FLOTL = REAL(L) ETA = ONE/((BIAS2*DSM)**(ONE/FLOTL)+ADDON) ETA = MAX(ETA,HMIN/ABS(H),ETAMIN) IF ((KFLAG<=-2) .AND. (ETA>ETAMXF)) ETA = ETAMXF GOTO 60 ! Control reaches this section if 3 or more consecutive failures ! have occurred. It is assumed that the elements of the YH array ! have accumulated errors of the wrong order. The order is reduced ! by one, if possible. Then H is reduced by a factor of 0.1 and ! the step is retried. After a total of 7 consecutive failures, ! an exit is taken with KFLAG = -1. !110 IF (KFLAG==KFH) GOTO 220 110 IF (KFLAG==CONSECUTIVE_EFAILS) GOTO 220 IF (NQ==1) GOTO 120 ETA = MAX(ETAMIN,HMIN/ABS(H)) CALL DVJUST(YH,LDYH,-1) L = NQ NQ = NQ - 1 NQWAIT = L GOTO 60 120 ETA = MAX(ETAMIN,HMIN/ABS(H)) H = H*ETA HSCAL = H TAU(1) = H CALL F(N,TN,Y,SAVF) NFE = NFE + 1 IF (BOUNDS) THEN DO I = 1, NDX IF (ABS(YH(IDX(I),1)-LB(I))<=ZERO) SAVF(IDX(I)) = & MAX(SAVF(IDX(I)),ZERO) IF (ABS(YH(IDX(I),1)-UB(I))<=ZERO) SAVF(IDX(I)) = & MIN(SAVF(IDX(I)),ZERO) END DO END IF YH(1:N,2) = H*SAVF(1:N) NQWAIT = 10 GOTO 70 ! If NQWAIT = 0, an increase or decrease in order by one is considered. ! Factors ETAQ, ETAQM1, ETAQP1 are computed by which H could be ! multiplied at order q, q-1, or q+1, respectively. The largest of ! these is determined, and the new order and step size set accordingly. ! A change of H or NQ is made only if H increases by at least a factor ! of THRESH. If an order change is considered and rejected, then NQWAIT ! is set to 2 (reconsider it after 2 steps). ! Compute ratio of new H to current H at the current order. 130 FLOTL = REAL(L) ETAQ = ONE/((BIAS2*DSM)**(ONE/FLOTL)+ADDON) IF (NQWAIT/=0) GOTO 170 NQWAIT = 2 ETAQM1 = ZERO IF (NQ==1) GOTO 140 ! Compute ratio of new H to current H at the current order ! less one. ! Original: ! DDN = DVNORM(N,YH(1,L),EWT)/TQ(1) DDN = DVNORM(N,YH(1:N,L),EWT)/TQ(1) ETAQM1 = ONE/((BIAS1*DDN)**(ONE/(FLOTL-ONE))+ADDON) 140 ETAQP1 = ZERO IF (L==LMAX) GOTO 150 ! Compute ratio of new H to current H at current order plus one. CNQUOT = (TQ(5)/CONP)*(H/TAU(2))**L SAVF(1:N) = ACOR(1:N) - CNQUOT*YH(1:N,LMAX) DUP = DVNORM(N,SAVF,EWT)/TQ(3) ETAQP1 = ONE/((BIAS3*DUP)**(ONE/(FLOTL+ONE))+ADDON) 150 IF (ETAQ>=ETAQP1) GOTO 160 IF (ETAQP1>ETAQM1) GOTO 190 GOTO 180 160 IF (ETAQ= N, the first dimension of YH, input. ! SAVF = A work array of length N. ! EWT = An error weight vector of length N, input. ! ACOR = A work array of length N, used for the accumulated ! corrections to the predicted y vector. ! WM,IWM = Real and integer work arrays associated with matrix ! operations in chord iteration (MITER /= 0). ! F = Dummy name for user supplied routine for f. ! JAC = Dummy name for user supplied Jacobian routine. ! NFLAG = Input/output flag, with values and meanings as follows: ! INPUT ! 0 first call for this time step. ! -1 convergence failure in previous call to DVNLSD. ! -2 error test failure in DVSTEP. ! OUTPUT ! 0 successful completion of nonlinear solver. ! -1 convergence failure or singular matrix. ! -2 unrecoverable error in matrix preprocessing ! (cannot occur here). ! -3 unrecoverable error in solution (cannot occur ! here). ! IPUP = Own variable flag with values and meanings as follows: ! 0, do not update the Newton matrix. ! MITER /= 0 update Newton matrix, because it is the ! initial step, order was changed, the error ! test failed, or an update is indicated by ! the scalar RC or step counter NST. ! For more details, see comments in driver subroutine. ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ITOL, LDYH INTEGER, INTENT (INOUT) :: NFLAG ! .. ! .. Array Arguments .. KPP_REAL, INTENT (INOUT) :: ACOR(*), EWT(*), SAVF(*), & WM(*), Y(*), YH(LDYH,*) KPP_REAL, INTENT (IN) :: ATOL(*) INTEGER, INTENT (INOUT) :: IWM(*) ! .. ! .. Subroutine Arguments .. EXTERNAL F, JAC ! .. ! .. Local Scalars .. KPP_REAL :: ACNRMNEW, CSCALE, DCON, DEL, DELP INTEGER :: I, IERPJ, IERSL, M ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN ! .. ! .. FIRST EXECUTABLE STATEMENT DVNLSD ! .. ! On the first step, on a change of method order, or after a ! nonlinear convergence failure with NFLAG = -2, set IPUP = MITER ! to force a Jacobian update when MITER /= 0. IF (JSTART==0) NSLP = 0 IF (NFLAG==0) ICF = 0 IF (NFLAG==-2) IPUP = MITER IF ((JSTART==0) .OR. (JSTART==-1)) IPUP = MITER ! If this is functional iteration, set CRATE = 1 and drop to 220 IF (MITER==0) THEN CRATE = ONE GOTO 10 END IF ! RC is the ratio of new to old values of the coefficient H/EL(2)=h/l1. ! When RC differs from 1 by more than CCMAX, IPUP is set to MITER to ! force DVJAC to be called, if a Jacobian is involved. In any case, ! DVJAC is called at least every MSBP steps. DRC = ABS(RC-ONE) IF (DRC>CCMAX .OR. NST>=NSLP+MSBP) IPUP = MITER ! Up to MAXCOR corrector iterations are taken. A convergence test is ! made on the r.m.s. norm of each correction, weighted by the error ! weight vector EWT. The sum of the corrections is accumulated in the ! vector ACOR(i). The YH array is not altered in the corrector loop. 10 M = 0 DELP = ZERO ! Original: ! CALL DCOPY_F90(N,YH(1,1),1,Y,1) CALL DCOPY_F90(N,YH(1:N,1),1,Y(1:N),1) CALL F(N,TN,Y,SAVF) NFE = NFE + 1 IF (BOUNDS) THEN DO I = 1, NDX IF (ABS(YH(IDX(I),1)-LB(I))<=ZERO) SAVF(IDX(I)) = & MAX(SAVF(IDX(I)),ZERO) IF (ABS(YH(IDX(I),1)-UB(I))<=ZERO) SAVF(IDX(I)) = & MIN(SAVF(IDX(I)),ZERO) END DO END IF IF (IPUP<=0) GOTO 20 ! If indicated, the matrix P = I - h*rl1*J is reevaluated and ! preprocessed before starting the corrector iteration. IPUP ! is set to 0 as an indicator that this has been done. CALL DVJAC(Y,YH,LDYH,EWT,ACOR,SAVF,WM,IWM,F,JAC,IERPJ, & ATOL,ITOL) IPUP = 0 RC = ONE DRC = ZERO CRATE = ONE NSLP = NST ! If matrix is singular, take error return to force cut in ! step size. IF (IERPJ/=0) GOTO 70 20 ACOR(1:N) = ZERO ! This is a looping point for the corrector iteration. 30 IF (MITER/=0) GOTO 40 ! In the case of functional iteration, update Y directly from ! the result of the last function evaluation. SAVF(1:N) = RL1*(H*SAVF(1:N)-YH(1:N,2)) Y(1:N) = SAVF(1:N) - ACOR(1:N) DEL = DVNORM(N,Y,EWT) Y(1:N) = YH(1:N,1) + SAVF(1:N) CALL DCOPY_F90(N,SAVF,1,ACOR,1) GOTO 50 ! In the case of the chord method, compute the corrector error, and ! solve the linear system with that as right-hand side and P as ! coefficient matrix. The correction is scaled by the factor ! 2/(1+RC) to account for changes in h*rl1 since the last DVJAC call. 40 Y(1:N) = (RL1*H)*SAVF(1:N) - (RL1*YH(1:N,2)+ACOR(1:N)) CALL DVSOL(WM,IWM,Y,IERSL) NNI = NNI + 1 IF (IERSL>0) GOTO 60 IF (METH==2 .AND. ABS(RC-ONE)>ZERO) THEN CSCALE = TWO/(ONE+RC) CALL DSCAL_F90(N,CSCALE,Y,1) END IF DEL = DVNORM(N,Y,EWT) CALL DAXPY_F90(N,ONE,Y,1,ACOR,1) Y(1:N) = YH(1:N,1) + ACOR(1:N) ! Test for convergence. If M > 0, an estimate of the convergence ! rate constant is stored in CRATE, and this is used in the test. 50 IF (M/=0) CRATE = MAX(CRDOWN*CRATE,DEL/DELP) DCON = DEL*MIN(ONE,CRATE)/TQ(4) IF (DCON<=ONE) GOTO 80 M = M + 1 IF (M==MAXCOR) GOTO 60 IF (M>=2 .AND. DEL>RDIV*DELP) GOTO 60 DELP = DEL CALL F(N,TN,Y,SAVF) NFE = NFE + 1 IF (BOUNDS) THEN DO I = 1, NDX IF (ABS(YH(IDX(I),1)-LB(I))<=ZERO) SAVF(IDX(I)) = & MAX(SAVF(IDX(I)),ZERO) IF (ABS(YH(IDX(I),1)-UB(I))<=ZERO) SAVF(IDX(I)) = & MIN(SAVF(IDX(I)),ZERO) END DO END IF GOTO 30 60 IF (MITER==0 .OR. JCUR==1) GOTO 70 ICF = 1 IPUP = MITER GOTO 10 70 CONTINUE NFLAG = -1 ICF = 2 IPUP = MITER RETURN ! Return for successful step. 80 CONTINUE ! Enforce bounds. IF (BOUNDS) THEN CHANGED_ACOR = .FALSE. IF (M==0) THEN ACNRM = DEL ELSE ACNRM = DVNORM(N,ACOR,EWT) END IF IF (MITER/=0) THEN ! Since Y(:) = YH(:,1) + ACOR(:) ... DO I = 1, NDX IF (Y(IDX(I))UB(I)) THEN CHANGED_ACOR = .TRUE. ACOR(IDX(I)) = UB(I) - YH(IDX(I),1) SAVF(IDX(I)) = ACOR(IDX(I)) END IF END DO ELSE ! Since Y(:) = YH(:,1) + SAVF(:) and ! since CALL DCOPY_F90(N,SAVF,1,ACOR,1) ... DO I = 1, NDX IF (Y(IDX(I))UB(IDX(I))) THEN CHANGED_ACOR = .TRUE. ACOR(IDX(I)) = UB(I) - YH(IDX(I),1) END IF END DO END IF IF (CHANGED_ACOR) THEN IF (M==0) THEN ACNRMNEW = DEL ELSE ACNRMNEW = DVNORM(N,ACOR,EWT) END IF ! ACNRM = ACNRMNEW ACNRM = MAX(ACNRM,ACNRMNEW) ELSE END IF NFLAG = 0 JCUR = 0 ICF = 0 ELSE ! No projections are required. NFLAG = 0 JCUR = 0 ICF = 0 IF (M==0) ACNRM = DEL IF (M>0) ACNRM = DVNORM(N,ACOR,EWT) END IF RETURN END SUBROUTINE DVNLSD !_______________________________________________________________________ SUBROUTINE DVJAC(Y,YH,LDYH,EWT,FTEM,SAVF,WM,IWM,F,JAC,IERPJ, & ATOL,ITOL) ! .. ! Compute and process the matrix P = I - h*rl1*J, where J is an ! approximation to the Jacobian for dense and banded solutions. ! .. ! This is a version of DVJAC that allows use of the known nonzero ! diagonals if it is available. ! DVJAC is called by DVNLSD to compute and process the matrix ! P = I - h*rl1*J, where J is an approximation to the Jacobian. ! Here J is computed by the user-supplied routine JAC if ! MITER = 1 or 4, or by finite differencing if MITER = 2, 3, or 5. ! If MITER = 3, a diagonal approximation to J is used. ! If JSV = -1, J is computed from scratch in all cases. ! If JSV = 1 and MITER = 1, 2, 4, or 5, and if the saved value of J is ! considered acceptable, then P is constructed from the saved J. ! J is stored in wm and replaced by P. If MITER /= 3, P is then ! subjected to LU decomposition in preparation for later solution ! of linear systems with P as coefficient matrix. This is done ! by DGEFA_F90 if MITER = 1 or 2, and by DGBFA_F90 if MITER = 4 or 5. ! Communication with DVJAC is done with the following variables. ! (For more details, please see the comments in the driver subroutine.) ! Y = Vector containing predicted values on entry. ! YH = The Nordsieck array, an LDYH by LMAX array, input. ! LDYH = A constant >= N, the first dimension of YH, input. ! EWT = An error weight vector of length N. ! SAVF = Array containing f evaluated at predicted y, input. ! WM = Real work space for matrices. In the output, it contains ! the inverse diagonal matrix if MITER = 3 and the LU ! decomposition of P if MITER is 1, 2, 4, or 5. ! Storage of matrix elements starts at WM(1). ! Storage of the saved Jacobian starts at WM(LOCJS). ! IWM = Integer work space containing pivot information, ! starting at IWM(31), if MITER is 1, 2, 4, or 5. ! IWM also contains band parameters ML = IWM(1) and ! MU = IWM(2) if MITER is 4 or 5. ! F = Dummy name for the user supplied subroutine for f. ! JAC = Dummy name for the user supplied Jacobian subroutine. ! RL1 = 1/EL(2) (input). ! IERPJ = Output error flag, = 0 if no trouble, 1 if the P ! matrix is found to be singular. ! JCUR = Output flag to indicate whether the Jacobian matrix ! (or approximation) is now current. ! JCUR = 0 means J is not current. ! JCUR = 1 means J is current. ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. INTEGER, INTENT (INOUT) :: IERPJ INTEGER, INTENT (IN) :: LDYH, ITOL ! .. ! .. Array Arguments .. KPP_REAL, INTENT (INOUT) :: EWT(*), FTEM(*), SAVF(*), WM(*), & Y(*),YH(LDYH,*) KPP_REAL, INTENT (IN) :: ATOL(*) INTEGER, INTENT (INOUT) :: IWM(*) ! .. ! .. Subroutine Arguments .. EXTERNAL F, JAC ! .. ! .. Local Scalars .. KPP_REAL :: CON, DI, FAC, HRL1, R, R0, SRUR, YI, YJ, YJJ INTEGER :: I, I1, I2, IER, II, J, J1, JJ, JJ1, JJ2, JOK, K, & K1, K2, LENP, MBA, MBAND, MEB1, MEBAND, ML, ML1, MU, NG, NP1 ! K1, K2, LENP, MBA, MBAND, MEB1, MEBAND, ML, ML3, MU, NG, NP1 ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, REAL ! .. ! .. FIRST EXECUTABLE STATEMENT DVJAC ! .. IERPJ = 0 HRL1 = H*RL1 ! See whether J should be evaluated (JOK = -1) or not (JOK = 1). JOK = JSV IF (JSV==1) THEN IF (NST==0 .OR. NST>NSLJ+MSBJ) JOK = -1 IF (ICF==1 .AND. DRC= MBAND) GOTO 60 ! Otherwise, use the original algorithm. IF (USE_JACSP) THEN ! Approximate the Jacobian using Doug Salane's JACSP. NSLJ = NST JCUR = 1 WM(1:LENP) = ZERO IOPTDS(1) = 1 IOPTDS(2) = MBAND IOPTDS(3) = 1 IOPTDS(5) = ML ! INFORDS(4) was initialized in DVODE. LWKDS = 3 * N LIWKDS = 50 + N ! NRFJACDS = MEBAND*N ! NCFJACDS = 1 NRFJACDS = MEBAND NCFJACDS = N MBA = MIN(MBAND,N) MAXGRPDS = MBA ! Calculate the YSCALEDS vector for JACSPDV. IF (LIKE_ORIGINAL_VODE) THEN FAC = DVNORM(N,SAVF,EWT) ! JACSPDB multiplies YSCALEDS(*) BY UROUND**0.825: ! R0 = THOU*ABS(H)*UROUND*REAL(N)*FAC R0 = THOU*ABS(H)*REAL(N)*FAC IF (ABS(R0)<=ZERO) R0 = ONE SRUR = WM1 DO J = 1, N ! JACSPDB multiplies YSCALEDS(*) BY UROUND**0.825: ! R = MAX(ABS(Y(J)),R0/EWT(J)) R = MAX(ABS(Y(J))/U325,(R0/EWT(J))*U125) YSCALEDS(J) = R END DO ELSE IF (ITOL == 1 .OR. ITOL == 3) THEN DO J = 1, N YSCALEDS(J) = MAX(ABS(Y(J)),ATOL(1),UROUND) END DO ELSE DO J = 1, N YSCALEDS(J) = MAX(ABS(Y(J)),ATOL(J),UROUND) END DO END IF END IF CALL JACSPDB(F,N,TN,Y,SAVF,WM(1),NRFJACDS, & YSCALEDS,FACDS,IOPTDS,WKDS,LWKDS,IWKDS,LIWKDS, & MAXGRPDS,NGRPDS,JPNTRDS,INDROWDS) NFE = NFE + IWKDS(7) NJE = NJE + 1 ELSE NSLJ = NST JCUR = 1 MBA = MIN(MBAND,N) MEB1 = MEBAND - 1 SRUR = WM1 FAC = DVNORM(N,SAVF,EWT) R0 = THOU*ABS(H)*UROUND*REAL(N)*FAC IF (ABS(R0)<=ZERO) R0 = ONE DO J = 1, MBA DO I = J, N, MBAND YI = Y(I) R = MAX(SRUR*ABS(YI),R0/EWT(I)) Y(I) = Y(I) + R END DO CALL F(N,TN,Y,FTEM) DO JJ = J, N, MBAND Y(JJ) = YH(JJ,1) YJJ = Y(JJ) R = MAX(SRUR*ABS(YJJ),R0/EWT(JJ)) FAC = ONE/R I1 = MAX(JJ-MU,1) I2 = MIN(JJ+ML,N) ! II = JJ*MEB1 - ML + 2 II = JJ*MEB1 - ML DO I = I1, I2 WM(II+I) = (FTEM(I)-SAVF(I))*FAC END DO END DO END DO NFE = NFE + MBA NJE = NJE + 1 END IF IF (J_IS_CONSTANT) J_HAS_BEEN_COMPUTED = .TRUE. GOTO 90 60 CONTINUE ! User supplied diagonals information is available. ! WM(3:LENP+2) = ZERO WM(1:LENP) = ZERO NJE = NJE + 1 NSLJ = NST JCUR = 1 MBA = MIN(MBAND,N) MEB1 = MEBAND - 1 SRUR = WM1 FAC = DVNORM(N,SAVF,EWT) R0 = THOU*ABS(H)*UROUND*REAL(N)*FAC IF (ABS(R0)<=ZERO) R0 = ONE ! For each group of columns... DO NG = 1, BNGRP ! Find the first and last columns in the group. JJ1 = BIGP(NG) JJ2 = BIGP(NG+1) - 1 ! For each column in this group... DO JJ = JJ1, JJ2 J = BJGP(JJ) R = MAX(SRUR*ABS(Y(J)),R0/EWT(J)) Y(J) = Y(J) + R END DO CALL F(N,TN,Y,FTEM) ! For each column in this group... DO JJ = JJ1, JJ2 J = BJGP(JJ) Y(J) = YH(J,1) R = MAX(SRUR*ABS(Y(J)),R0/EWT(J)) FAC = ONE/R IF (BUILD_IAJA) THEN ! Use the IAB, JAB sparse structure arrays to ! determine the first and last nonzeros in ! column J. K1 = IAB(J) K2 = IAB(J+1) - 1 ELSE ! Extract the positions of the first and ! last nonzeros in this column directly. CALL BANDED_GET_BJNZ(N,ML,MU,J,IWM(31),I) DO K = 1, N IF (IWM(30+K) /= 0) THEN K1 = K GOTO 70 END IF END DO 70 CONTINUE DO K = N, 1, -1 IF (IWM(30+K) /= 0) THEN K2 = K GOTO 80 END IF END DO 80 CONTINUE END IF ! Load the nonzeros for column J in the banded matrix. IF (BUILD_IAJA) THEN DO K = K1, K2 I = JAB(K) ! II = J * MEB1 - ML + 2 II = J * MEB1 - ML WM(II+I) = (FTEM(I)-SAVF(I))*FAC END DO ELSE DO K = K1, K2 I = IWM(30+K) IF (I /= 0) THEN ! II = J * MEB1 - ML + 2 II = J * MEB1 - ML WM(II+I) = (FTEM(I)-SAVF(I))*FAC END IF END DO END IF END DO END DO NFE = NFE + BNGRP IF (J_IS_CONSTANT) J_HAS_BEEN_COMPUTED = .TRUE. 90 CONTINUE ! IF (JSV==1) CALL DACOPY(MBAND,N,WM(ML3),MEBAND,WM(LOCJS),MBAND) IF (JSV==1) CALL DACOPY(MBAND,N,WM(ML1),MEBAND,WM(LOCJS),MBAND) END IF IF (JOK==1) THEN JCUR = 0 ! CALL DACOPY(MBAND,N,WM(LOCJS),MBAND,WM(ML3),MEBAND) CALL DACOPY(MBAND,N,WM(LOCJS),MBAND,WM(ML1),MEBAND) END IF ! Multiply Jacobian by scalar, add identity, and do LU ! decomposition. CON = -HRL1 ! CALL DSCAL_F90(LENP,CON,WM(3),1) CALL DSCAL_F90(LENP,CON,WM(1),1) ! II = MBAND + 2 II = MBAND DO I = 1, N WM(II) = WM(II) + ONE II = II + MEBAND END DO NLU = NLU + 1 ! ______________________________________________________________________ ! CALL DGBFA_F90(WM(3),MEBAND,N,ML,MU,IWM(31),IER) CALL DGBFA_F90(WM(1),MEBAND,N,ML,MU,IWM(31),IER) IF (IER/=0) IERPJ = 1 ! *****LAPACK build change point. Replace above with these statements. ! IF (.NOT.USE_LAPACK) THEN !! CALL DGBFA_f90(WM(3),MEBAND,N,ML,MU,IWM(31),IER) ! CALL DGBFA_f90(WM(1),MEBAND,N,ML,MU,IWM(31),IER) ! IF (IER /= 0) IERPJ = 1 ! ELSE !! CALL DGBTRF(N,N,ML,MU,WM(3),MEBAND,IWM(31),IER) ! CALL DGBTRF(N,N,ML,MU,WM(1),MEBAND,IWM(31),IER) ! IF (IER /= 0) IERPJ = 1 ! END IF ! ______________________________________________________________________ RETURN ! End of code block for MITER = 4 or 5. END SUBROUTINE DVJAC !_______________________________________________________________________ SUBROUTINE DACOPY(NROW,NCOL,A,NROWA,B,NROWB) ! .. ! Copy one array to another. ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: NCOL, NROW, NROWA, NROWB ! .. ! .. Array Arguments .. KPP_REAL, INTENT (IN) :: A(NROWA,NCOL) KPP_REAL, INTENT (INOUT) :: B(NROWB,NCOL) ! .. ! .. Local Scalars .. INTEGER :: IC ! .. ! .. FIRST EXECUTABLE STATEMENT DACOPY ! .. DO IC = 1, NCOL CALL DCOPY_F90(NROW,A(1,IC),1,B(1,IC),1) END DO RETURN END SUBROUTINE DACOPY !_______________________________________________________________________ SUBROUTINE DVSOL(WM,IWM,X,IERSL) ! .. ! Manage the solution of the linear system arising from a chord ! iteration for dense and banded solutions. ! .. ! This routine manages the solution of the linear system arising from ! a chord iteration. It is called if MITER /= 0. ! If MITER is 1 or 2, it calls DGESL_F90 to accomplish this. ! If MITER = 3 it updates the coefficient H*RL1 in the diagonal ! matrix, and then computes the solution. ! If MITER is 4 or 5, it calls DGBSL_F90. ! Communication with DVSOL uses the following variables: ! WM = Real work space containing the inverse diagonal matrix if ! MITER = 3 and the LU decomposition of the matrix otherwise. ! Storage of matrix elements starts at WM(1). ! WM also contains the following matrix-related data: ! WM1 = SQRT(UROUND) (not used here), ! WM2 = HRL1, the previous value of H*RL1, used if MITER = 3. ! IWM = Integer work space containing pivot information, starting at ! IWM(31), if MITER is 1, 2, 4, or 5. IWM also contains band ! parameters ML = IWM(1) and MU = IWM(2) if MITER is 4 or 5. ! X = The right-hand side vector on input, and the solution vector ! on output, of length N. ! IERSL = Output flag. IERSL = 0 if no trouble occurred. ! IERSL = 1 if a singular matrix arose with MITER = 3. ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. INTEGER, INTENT (INOUT) :: IERSL ! .. ! .. Array Arguments .. KPP_REAL, INTENT (INOUT) :: WM(*), X(*) INTEGER, INTENT (INOUT) :: IWM(*) ! .. ! .. Local Scalars .. KPP_REAL :: DI, HRL1, PHRL1, R INTEGER :: I, MEBAND, ML, MU ! .. ! .. Intrinsic Functions .. INTRINSIC ABS ! .. ! ______________________________________________________________________ ! *****LAPACK build change point. Insert this statement. ! INTEGER INFO ! CHARACTER*1 TRANS ! ______________________________________________________________________ ! .. FIRST EXECUTABLE STATEMENT DVSOL ! .. IERSL = 0 GOTO (10,10,20,50,50) MITER 10 CONTINUE ! ______________________________________________________________________ ! CALL DGESL_F90(WM(3),N,N,IWM(31),X,0) CALL DGESL_F90(WM(1),N,N,IWM(31),X,0) ! *****LAPACK build change point. Replace above with these statements. ! IF (.NOT.USE_LAPACK) THEN !! CALL DGESL_f90(WM(3),N,N,IWM(31),X,0) ! CALL DGESL_f90(WM(1),N,N,IWM(31),X,0) ! ELSE ! TRANS = 'N' !! CALL DGETRS(TRANS,N,1,WM(3),N,IWM(31),X,N,INFO) ! CALL DGETRS(TRANS,N,1,WM(1),N,IWM(31),X,N,INFO) ! IF (INFO /= 0) THEN ! WRITE(6,*) 'Stopping in DVSOL with INFO = ', INFO ! STOP ! END IF ! END IF ! ______________________________________________________________________ RETURN 20 PHRL1 = WM2 HRL1 = H*RL1 WM2 = HRL1 IF (ABS(HRL1-PHRL1)<=ZERO) GOTO 30 R = HRL1/PHRL1 DO I = 1, N ! DI = ONE - R*(ONE-ONE/WM(I+2)) DI = ONE - R*(ONE-ONE/WM(I)) IF (ABS(DI)<=ZERO) GOTO 40 ! WM(I+2) = ONE/DI WM(I) = ONE/DI END DO 30 DO I = 1, N ! X(I) = WM(I+2)*X(I) X(I) = WM(I)*X(I) END DO RETURN 40 IERSL = 1 RETURN 50 ML = IWM(1) MU = IWM(2) MEBAND = 2*ML + MU + 1 ! ______________________________________________________________________ ! CALL DGBSL_F90(WM(3),MEBAND,N,ML,MU,IWM(31),X,0) CALL DGBSL_F90(WM(1),MEBAND,N,ML,MU,IWM(31),X,0) ! *****LAPACK build change point. Replace above with these statements. ! IF (.NOT.USE_LAPACK) THEN !! CALL DGBSL_F90(WM(3),MEBAND,N,ML,MU,IWM(31),X,0) ! CALL DGBSL_F90(WM(1),MEBAND,N,ML,MU,IWM(31),X,0) ! ELSE ! TRANS = 'N' !! CALL DGBTRS(TRANS,N,ML,MU,1,WM(3),MEBAND,IWM(31),X,N,INFO) ! CALL DGBTRS(TRANS,N,ML,MU,1,WM(1),MEBAND,IWM(31),X,N,INFO) ! IF (INFO /= 0) THEN ! WRITE(6,*) 'Stopping in DVSOL with INFO = ', INFO ! STOP ! END IF ! END IF ! ______________________________________________________________________ RETURN END SUBROUTINE DVSOL !_______________________________________________________________________ SUBROUTINE DVSRCO(RSAV,ISAV,JOB) ! .. ! Save or restore (depending on JOB) the contents of the PRIVATE ! variable blocks, which are used internally by DVODE (not called ! by DVODE_F90). ! .. ! RSAV = real array of length 49 or more. ! ISAV = integer array of length 41 or more. ! JOB = flag indicating to save or restore the PRIVATE variable ! blocks: ! JOB = 1 if PRIVATE variables is to be saved ! (written to RSAV/ISAV). ! JOB = 2 if PRIVATE variables is to be restored ! (read from RSAV/ISAV). ! A call with JOB = 2 presumes a prior call with JOB = 1. ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: JOB ! .. ! .. Array Arguments .. KPP_REAL, INTENT (INOUT) :: RSAV(*) INTEGER, INTENT (INOUT) :: ISAV(*) ! .. ! .. FIRST EXECUTABLE STATEMENT DVSRCO ! .. IF (JOB/=2) THEN ! Save the contents of the PRIVATE blocks. RSAV(1) = ACNRM RSAV(2) = CCMXJ RSAV(3) = CONP RSAV(4) = CRATE RSAV(5) = DRC RSAV(6:18) = EL(1:13) RSAV(19) = ETA RSAV(20) = ETAMAX RSAV(21) = H RSAV(22) = HMIN RSAV(23) = HMXI RSAV(24) = HNEW RSAV(25) = HSCAL RSAV(26) = PRL1 RSAV(27) = RC RSAV(28) = RL1 RSAV(29:41) = TAU(1:13) RSAV(42:46) = TQ(1:5) RSAV(47) = TN RSAV(48) = UROUND RSAV(LENRV1+1) = HU ISAV(1) = ICF ISAV(2) = INIT ISAV(3) = IPUP ISAV(4) = JCUR ISAV(5) = JSTART ISAV(6) = JSV ISAV(7) = KFLAG ISAV(8) = KUTH ISAV(9) = L ISAV(10) = LMAX ISAV(11) = LYH ISAV(12) = 0 ISAV(13) = 0 ISAV(14) = 0 ISAV(15) = LWM ISAV(16) = LIWM ISAV(17) = LOCJS ISAV(18) = MAXORD ISAV(19) = METH ISAV(20) = MITER ISAV(21) = MSBJ ISAV(22) = MXHNIL ISAV(23) = MXSTEP ISAV(24) = N ISAV(25) = NEWH ISAV(26) = NEWQ ISAV(27) = NHNIL ISAV(28) = NQ ISAV(29) = NQNYH ISAV(30) = NQWAIT ISAV(31) = NSLJ ISAV(32) = NSLP ISAV(33) = NYH ISAV(LENIV1+1) = NCFN ISAV(LENIV1+2) = NETF ISAV(LENIV1+3) = NFE ISAV(LENIV1+4) = NJE ISAV(LENIV1+5) = NLU ISAV(LENIV1+6) = NNI ISAV(LENIV1+7) = NQU ISAV(LENIV1+8) = NST RETURN ELSE ! Replace the contents of the PRIVATE blocks. ACNRM = RSAV(1) CCMXJ = RSAV(2) CONP = RSAV(3) CRATE = RSAV(4) DRC = RSAV(5) EL(1:13) = RSAV(6:18) ETA = RSAV(19) ETAMAX = RSAV(20) H = RSAV(21) HMIN = RSAV(22) HMXI = RSAV(23) HNEW = RSAV(24) HSCAL = RSAV(25) PRL1 = RSAV(26) RC = RSAV(27) RL1 = RSAV(28) TAU(1:13) = RSAV(29:41) TQ(1:5) = RSAV(42:46) TN = RSAV(47) UROUND = RSAV(48) HU = RSAV(LENRV1+1) ICF = ISAV(1) INIT = ISAV(2) IPUP = ISAV(3) JCUR = ISAV(4) JSTART = ISAV(5) JSV = ISAV(6) KFLAG = ISAV(7) KUTH = ISAV(8) L = ISAV(9) LMAX = ISAV(10) LYH = ISAV(11) LWM = ISAV(15) LIWM = ISAV(16) LOCJS = ISAV(17) MAXORD = ISAV(18) METH = ISAV(19) MITER = ISAV(20) MSBJ = ISAV(21) MXHNIL = ISAV(22) MXSTEP = ISAV(23) N = ISAV(24) NEWH = ISAV(25) NEWQ = ISAV(26) NHNIL = ISAV(27) NQ = ISAV(28) NQNYH = ISAV(29) NQWAIT = ISAV(30) NSLJ = ISAV(31) NSLP = ISAV(32) NYH = ISAV(33) NCFN = ISAV(LENIV1+1) NETF = ISAV(LENIV1+2) NFE = ISAV(LENIV1+3) NJE = ISAV(LENIV1+4) NLU = ISAV(LENIV1+5) NNI = ISAV(LENIV1+6) NQU = ISAV(LENIV1+7) NST = ISAV(LENIV1+8) RETURN END IF END SUBROUTINE DVSRCO !_______________________________________________________________________ SUBROUTINE DEWSET(N,ITOL,RTOL,ATOL,YCUR,EWT) ! .. ! Set the error weight vector. ! .. ! This subroutine sets the error weight vector EWT according to ! EWT(i) = RTOL(i)*ABS(YCUR(i)) + ATOL(i), i = 1,...,N, ! with the subscript on RTOL and/or ATOL possibly replaced by 1 ! above, depending on the value of ITOL. ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ITOL, N ! .. ! .. Array Arguments .. KPP_REAL, INTENT (IN) :: ATOL(*), RTOL(*), YCUR(N) KPP_REAL, INTENT (OUT) :: EWT(N) ! .. ! .. Intrinsic Functions .. INTRINSIC ABS ! .. ! .. FIRST EXECUTABLE STATEMENT DEWSET ! .. GOTO (10,20,30,40) ITOL 10 CONTINUE EWT(1:N) = RTOL(1)*ABS(YCUR(1:N)) + ATOL(1) RETURN 20 CONTINUE EWT(1:N) = RTOL(1)*ABS(YCUR(1:N)) + ATOL(1:N) RETURN 30 CONTINUE EWT(1:N) = RTOL(1:N)*ABS(YCUR(1:N)) + ATOL(1) RETURN 40 CONTINUE EWT(1:N) = RTOL(1:N)*ABS(YCUR(1:N)) + ATOL(1:N) RETURN END SUBROUTINE DEWSET !_______________________________________________________________________ FUNCTION DVNORM(N,V,W) ! .. ! Calculate weighted root-mean-square (rms) vector norm. ! .. ! This routine computes the weighted root-mean-square norm ! of the vector of length N contained in the array V, with ! weights contained in the array W of length N. ! DVNORM = SQRT((1/N) * SUM(V(i)*W(i))**2) ! .. IMPLICIT NONE ! .. ! .. Function Return Value .. KPP_REAL :: DVNORM ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: N ! .. ! .. Array Arguments .. KPP_REAL, INTENT (IN) :: V(N), W(N) ! .. ! .. Local Scalars .. KPP_REAL :: SUM INTEGER :: I ! .. ! .. Intrinsic Functions .. INTRINSIC SQRT ! .. ! .. FIRST EXECUTABLE STATEMENT DVNORM ! .. SUM = ZERO DO I = 1, N SUM = SUM + (V(I)*W(I))**2 END DO DVNORM = SQRT(SUM/N) RETURN END FUNCTION DVNORM !_______________________________________________________________________ ! The modified SLATEC error handling routines begin here. SUBROUTINE XERRDV(MSG,NERR,LEVEL,NI,I1,I2,NR,R1,R2) ! .. ! Write error messages with values. ! .. ! This is an adaptation of subroutine XERRWD (NMES eliminated). ! Subroutines XERRDV, XSETF, XSETUN, and Functions IXSAV ! as given here, constitute a simplified version of the SLATEC ! error handling package. ! ! All arguments are input arguments. ! MSG = The message (character array). ! NERR = The error number (not used). ! LEVEL = The error level ! 0 or 1 means recoverable (control returns to caller). ! 2 means fatal (run is aborted--see note below). ! NI = Number of integers (0, 1, or 2) to be printed with message. ! I1,I2 = Integers to be printed, depending on NI. ! NR = Number of reals (0, 1, or 2) to be printed with message. ! R1,R2 = Reals to be printed, depending on NR. ! Note: This routine is machine-dependent and specialized for use ! in limited context, in the following ways: ! 1. The argument MSG is assumed to be of type CHARACTER, and ! the message is printed with a format of (1X,A). ! 2. The message is assumed to take only one line. ! Multi-line messages are generated by repeated calls. ! 3. If LEVEL = 2, control passes to the statement: STOP ! to abort the run. This statement may be machine-dependent. ! 4. R1 and R2 are assumed to be in real(wp) and are printed ! in D21.13 format. ! Internal Notes: ! For a different default logical unit number, IXSAV(or a subsidiary ! function that it calls) will need to be modified. ! For a different run-abort command, change the statement following ! statement 100 at the end. ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. KPP_REAL :: R1, R2 INTEGER :: I1, I2, LEVEL, NERR, NI, NR CHARACTER (*) :: MSG LOGICAL PRINT_NERR ! .. ! .. Local Scalars .. INTEGER :: LUNIT, MESFLG ! .. ! .. FIRST EXECUTABLE STATEMENT XERRDV ! .. ! Get logical unit number and message print flag. LUNIT = IXSAV(1,0,.FALSE.) MESFLG = IXSAV(2,0,.FALSE.) IF (MESFLG==0) GOTO 10 PRINT_NERR = .FALSE. IF (PRINT_NERR) PRINT *, MSG, 'Message number = ', NERR ! Write the message. WRITE (LUNIT,90000) MSG 90000 FORMAT (1X,A) IF (NI==1) WRITE (LUNIT,90001) I1 90001 FORMAT ('In the above message, I1 = ',I10) IF (NI==2) WRITE (LUNIT,90002) I1, I2 90002 FORMAT ('In the above message, I1 = ',I10,3X,'I2 = ',I10) IF (NR==1) WRITE (LUNIT,90003) R1 90003 FORMAT ('In the above message, R1 = ',D21.13) IF (NR==2) WRITE (LUNIT,90004) R1, R2 90004 FORMAT ('In the above message, R1 = ',D21.13,3X,'R2 = ',D21.13) ! Abort the run if LEVEL = 2. 10 IF (LEVEL/=2) RETURN WRITE (LUNIT,90005) 90005 FORMAT ('LEVEL = 2 in XERRDV. Stopping.') STOP END SUBROUTINE XERRDV !_______________________________________________________________________ SUBROUTINE XSETF(MFLAG) ! .. ! Reset the error print control flag. ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: MFLAG ! .. ! .. Local Scalars .. INTEGER :: JUNK ! .. ! .. FIRST EXECUTABLE STATEMENT XSETF ! .. IF (MFLAG==0 .OR. MFLAG==1) JUNK = IXSAV(2,MFLAG,.TRUE.) ! Get rid of a compiler warning message: IF (JUNK/=JUNK) STOP RETURN END SUBROUTINE XSETF !_______________________________________________________________________ SUBROUTINE XSETUN(LUN) ! .. ! Reset the logical unit number for error messages. ! .. ! XSETUN sets the logical unit number for error messages to LUN. ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. INTEGER :: LUN ! .. ! .. Local Scalars .. INTEGER :: JUNK ! .. ! .. FIRST EXECUTABLE STATEMENT XSETUN ! .. IF (LUN>0) JUNK = IXSAV(1,LUN,.TRUE.) ! Get rid of a compiler warning message: IF (JUNK/=JUNK) STOP RETURN END SUBROUTINE XSETUN !_______________________________________________________________________ FUNCTION IXSAV(IPAR,IVALUE,ISET) ! .. ! Save and recall error message control parameters. ! .. ! IXSAV saves and recalls one of two error message parameters: ! LUNIT, the logical unit number to which messages are printed, ! and MESFLG, the message print flag. ! This is a modification of the SLATEC library routine J4SAVE. ! Saved local variables: ! LUNIT = Logical unit number for messages. The default is ! obtained by a call to IUMACH(may be machine-dependent). ! MESFLG = Print control flag: ! 1 means print all messages (the default). ! 0 means no printing. ! On input: ! IPAR = Parameter indicator (1 for LUNIT, 2 for MESFLG). ! IVALUE = The value to be set for the parameter, if ISET = .TRUE. ! ISET = Logical flag to indicate whether to read or write. ! If ISET = .TRUE., the parameter will be given ! the value IVALUE. If ISET = .FALSE., the parameter ! will be unchanged, and IVALUE is a dummy argument. ! On return: ! IXSAV = The (old) value of the parameter. ! .. IMPLICIT NONE ! .. ! .. Function Return Value .. INTEGER :: IXSAV ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: IPAR, IVALUE LOGICAL, INTENT (IN) :: ISET ! .. ! .. Local Scalars .. INTEGER, SAVE :: LUNIT, MESFLG ! .. ! .. Data Statements .. DATA LUNIT/ -1/, MESFLG/1/ ! .. ! .. FIRST EXECUTABLE STATEMENT IXSAV ! .. IF (IPAR==1) THEN IF (LUNIT==-1) LUNIT = IUMACH() ! i Get rid of a compiler warning message: IF (LUNIT/=LUNIT) STOP IXSAV = LUNIT IF (ISET) LUNIT = IVALUE END IF IF (IPAR==2) THEN IXSAV = MESFLG IF (ISET) MESFLG = IVALUE END IF RETURN END FUNCTION IXSAV !_______________________________________________________________________ FUNCTION IUMACH() ! .. ! Provide the standard output unit number. ! .. ! INTEGER LOUT, IUMACH ! LOUT = IUMACH() ! Function Return Values: ! LOUT: the standard logical unit for Fortran output. ! Internal Notes: ! The built-in value of 6 is standard on a wide range ! of Fortran systems. This may be machine-dependent. ! .. ! .. Function Return Value .. INTEGER :: IUMACH ! .. ! .. FIRST EXECUTABLE STATEMENT IUMACH ! .. IUMACH = 6 RETURN END FUNCTION IUMACH ! The modified error handling routines end here. !_______________________________________________________________________ SUBROUTINE CHECK_STAT(IER,CALLED_FROM_WHERE) ! .. ! Print an error message if a storage allocation error ! occurred. ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: CALLED_FROM_WHERE, IER ! .. ! .. Local Scalars .. INTEGER :: I1 CHARACTER (80) :: MSG ! .. ! .. FIRST EXECUTABLE STATEMENT CHECK_STAT ! .. IF (IER/=0) THEN I1 = CALLED_FROM_WHERE MSG = 'A storage allocation error occurred.' CALL XERRDV(MSG,1410,1,0,0,0,0,ZERO,ZERO) MSG = 'The error occurred at location I1.' CALL XERRDV(MSG,1410,2,1,I1,0,0,ZERO,ZERO) END IF RETURN END SUBROUTINE CHECK_STAT !_______________________________________________________________________ SUBROUTINE DVPREPS(NEQ,Y,YH,LDYH,SAVF,EWT,F,JAC) ! .. ! Determine the sparsity structure and allocate the necessary arrays ! for MA28 based sparse solutions. ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: LDYH, NEQ ! .. ! .. Array Arguments .. KPP_REAL, INTENT (INOUT) :: EWT(*), Y(*) KPP_REAL :: SAVF(*) KPP_REAL, INTENT (IN) :: YH(LDYH,*) ! .. ! .. Subroutine Arguments .. EXTERNAL F, JAC ! .. ! .. Local Scalars .. KPP_REAL :: DQ, DYJ, ERWT, FAC, YJ INTEGER :: I, IER, J, JFOUND, K, KMAX, KMIN, KNEW, NP1, NZ CHARACTER (80) :: MSG ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, ALLOCATED, MAX, SIGN ! .. ! .. FIRST EXECUTABLE STATEMENT DVPREPS ! .. NZ_SWAG = MAX(MAX(1000,NZ_SWAG),10*N) NP1 = N + 1 NZ_ALL = NZ_SWAG ! ADDTONNZ = MAX(1000,NZ_SWAG) ADDTONNZ = NZ_SWAG 10 CONTINUE IF (ALLOCATED(IAN)) THEN DEALLOCATE (IAN,JAN,IGP,JGP,FTEMP1,IKEEP28,IW28,ICN,PMAT, & JVECT,STAT=IER) CALL CHECK_STAT(IER,490) IF (ALLOCATED(JMAT)) THEN DEALLOCATE (JMAT,STAT=IER) CALL CHECK_STAT(IER,500) END IF END IF NZ_ALL = NZ_ALL + ADDTONNZ LICN_ALL = ELBOW_ROOM * NZ_ALL LIRN_ALL = ELBOW_ROOM * NZ_ALL IF (LICN_ALL>MAX_ARRAY_SIZE .OR. LIRN_ALL>MAX_ARRAY_SIZE) THEN MSG = 'Maximum array size exceeded. Stopping.' CALL XERRDV(MSG,1420,2,0,0,0,0,ZERO,ZERO) END IF ! Note: ICN may need to be reallocated in DVJACS28. ALLOCATE (IAN(NP1),JAN(LIRN_ALL),IGP(NP1),JGP(N),FTEMP1(N), & IKEEP28(N,5),IW28(N,8),ICN(LICN_ALL),PMAT(LICN_ALL), & JVECT(LIRN_ALL),STAT=IER) CALL CHECK_STAT(IER,510) IF (JSV==1) THEN ALLOCATE (JMAT(NZ_ALL),STAT=IER) CALL CHECK_STAT(IER,520) JMAT(1:NZ_ALL) = ZERO END IF IF (MOSS==0) GOTO 30 IF (ISTATC==3) GOTO 20 ! ISTATE = 1 and MOSS /= 0. ! Perturb Y for structure determination: DO I = 1, N ERWT = ONE/EWT(I) FAC = ONE + ONE/(I+ONE) Y(I) = Y(I) + FAC*SIGN(ERWT,Y(I)) END DO GOTO (60,70) MOSS 20 CONTINUE ! ISTATE = 3 and MOSS /= 0. ! Load Y from YH(*,1): Y(1:N) = YH(1:N,1) GOTO (60,70) MOSS ! MOSS = 0 ! Process user's IA,JA. Add diagonal entries if necessary: 30 CONTINUE IF (IAJA_CALLED) THEN ELSE MSG = 'You have indicated that you wish to supply the' CALL XERRDV(MSG,1430,1,0,0,0,0,ZERO,ZERO) MSG = 'sparsity arrays IA and JA directly but you did' CALL XERRDV(MSG,1430,1,0,0,0,0,ZERO,ZERO) MSG = 'not call SET_IAJA after calling SET_OPTS.' CALL XERRDV(MSG,1430,2,0,0,0,0,ZERO,ZERO) END IF KNEW = 1 KMIN = IA(1) IAN(1) = 1 DO J = 1, N JFOUND = 0 KMAX = IA(J+1) - 1 IF (KMIN>KMAX) GOTO 40 DO K = KMIN, KMAX I = JA(K) IF (I==J) JFOUND = 1 IF (KNEW>NZ_ALL) THEN IF (LP /= 0) THEN MSG = 'NZ_ALL (=I1) is not large enough.' CALL XERRDV(MSG,1440,1,0,0,0,0,ZERO,ZERO) MSG = 'Allocating more space for another try.' CALL XERRDV(MSG,1440,1,1,NZ_ALL,0,0,ZERO,ZERO) END IF GOTO 10 END IF JAN(KNEW) = I KNEW = KNEW + 1 END DO IF (JFOUND==1) GOTO 50 40 IF (KNEW>NZ_ALL) THEN IF (LP /= 0) THEN MSG = 'NZ_ALL (=I1) is not large enough.' CALL XERRDV(MSG,1450,1,0,0,0,0,ZERO,ZERO) MSG = 'Allocating more space for another try.' CALL XERRDV(MSG,1450,1,1,NZ_ALL,0,0,ZERO,ZERO) END IF GOTO 10 END IF JAN(KNEW) = J KNEW = KNEW + 1 50 IAN(J+1) = KNEW KMIN = KMAX + 1 END DO GOTO 90 60 CONTINUE ! MOSS = 1. ! Compute structure from user-supplied Jacobian routine JAC. NZ = 0 CALL JAC(NEQ,TN,Y,IAN,JAN,NZ,PMAT) IF (NZ<=0) THEN MSG = 'Illegal value of NZ from JAC in DVPREPS.' CALL XERRDV(MSG,1460,2,0,0,0,0,ZERO,ZERO) END IF IF (NZ>NZ_ALL) THEN IF (LP /= 0) THEN MSG = 'NZ_ALL (=I1) is not large enough.' CALL XERRDV(MSG,1470,1,0,0,0,0,ZERO,ZERO) MSG = 'Allocating more space for another try.' CALL XERRDV(MSG,1470,1,1,NZ_ALL,0,0,ZERO,ZERO) END IF GOTO 10 END IF CALL JAC(NEQ,TN,Y,IAN,JAN,NZ,PMAT) CALL SET_ICN(N,IAN,ICN) CALL CHECK_DIAG(N,IAN,JAN,ICN) GOTO 90 ! MOSS = 2. ! Compute structure from results of N+1 calls to F. 70 K = 1 IAN(1) = 1 DO I = 1, N ERWT = ONE/EWT(I) FAC = ONE + ONE/(I+ONE) Y(I) = Y(I) + FAC*SIGN(ERWT,Y(I)) END DO CALL F(NEQ,TN,Y,SAVF) NFE = NFE + 1 DO J = 1, N IF (K>NZ_ALL) THEN IF (LP /= 0) THEN MSG = 'NZ_ALL (=I1) is not large enough.' CALL XERRDV(MSG,1480,1,0,0,0,0,ZERO,ZERO) MSG = 'Allocating more space for another try.' CALL XERRDV(MSG,1480,1,1,NZ_ALL,0,0,ZERO,ZERO) END IF GOTO 10 END IF YJ = Y(J) ERWT = ONE/EWT(J) DYJ = SIGN(ERWT,YJ) Y(J) = YJ + DYJ CALL F(NEQ,TN,Y,FTEMP1) NFE = NFE + 1 Y(J) = YJ DO 80 I = 1, N DQ = (FTEMP1(I)-SAVF(I))/DYJ IF ((ABS(DQ)<=SETH) .AND. (I/=J)) GOTO 80 JAN(K) = I K = K + 1 80 END DO IAN(J+1) = K END DO 90 CONTINUE IF (MOSS==0 .OR. ISTATC/=1) GOTO 100 ! If ISTATE = 1 and MOSS /= 0, restore Y from YH. Y(1:N) = YH(1:N,1) 100 NNZ = IAN(NP1) - 1 LENIGP = 0 MAXG = 0 IF (MITER==7) THEN ! Compute grouping of column indices. MAXG = NP1 CALL DGROUP(N,IAN,JAN,MAXG,NGP,IGP,JGP,IKEEP28(1,1), & IKEEP28(1,2),IER) IF (IER/=0) THEN MSG = 'An error occurred in DGROUP.' CALL XERRDV(MSG,1490,2,0,0,0,0,ZERO,ZERO) END IF LENIGP = NGP + 1 END IF IF (USE_JACSP .AND. MITER==7) THEN ! Use Doug Salane's Jacobian routines to determine the column ! grouping; and allocate and initialize the necessary arrays ! for use in DVJACS48. IF (ALLOCATED(INDROWDS)) THEN DEALLOCATE (INDROWDS, INDCOLDS, NGRPDS, IPNTRDS, JPNTRDS, IWADS, & IWKDS, IOPTDS, YSCALEDS, WKDS, FACDS) CALL CHECK_STAT(IER,530) END IF ! We could delete IWADS and use IW28 array. ALLOCATE (INDROWDS(NNZ), INDCOLDS(NNZ), NGRPDS(N+1), IPNTRDS(N+1), & JPNTRDS(N+1), IWADS(6*N), IWKDS(50+N), IOPTDS(5), YSCALEDS(N), & WKDS(3*N), FACDS(N) ,STAT=IER) CALL CHECK_STAT(IER,540) INDROWDS(1:NNZ) = JAN(1:NNZ) CALL SET_ICN(N,IAN,INDCOLDS) CALL CHECK_DIAG(N,IAN,INDROWDS,INDCOLDS) LIWADS = 6 * N CALL DVDSM(N,N,NNZ,INDROWDS,INDCOLDS,NGRPDS,MAXGRPDS,MINGRPDS, & INFODS,IPNTRDS,JPNTRDS,IWADS,LIWADS) IF (INFODS /= 1) THEN MSG = 'An error occurred in subroutine DSM. INFO = I1.' CALL XERRDV(MSG,1500,2,1,INFODS,0,0,ZERO,ZERO) END IF ! For use in DVJACS28: IOPTDS(4) = 0 ! Define the IGP and JGP arrays needed by DVJACS28. CALL DGROUPDS(N,MAXGRPDS,NGRPDS,IGP,JGP) NGP = MAXGRPDS LENIGP = MAXGRPDS + 1 END IF ! Trim the arrays to the final sizes. IF (NZ_ALL>NNZ) THEN NZ_ALL = NNZ MAX_NNZ = MAX(MAX_NNZ,NNZ) LIRN_ALL = ELBOW_ROOM * NNZ ICN(1:NNZ) = JAN(1:NNZ) DEALLOCATE (JAN,STAT=IER) CALL CHECK_STAT(IER,550) ALLOCATE (JAN(LIRN_ALL),STAT=IER) CALL CHECK_STAT(IER,560) JAN(1:NNZ) = ICN(1:NNZ) CALL CHECK_STAT(IER,570) DEALLOCATE (ICN,PMAT,JVECT,STAT=IER) CALL CHECK_STAT(IER,580) IF (ALLOCATED(JMAT)) THEN DEALLOCATE (JMAT,STAT=IER) CALL CHECK_STAT(IER,590) END IF LICN_ALL = ELBOW_ROOM * NNZ ALLOCATE (ICN(LICN_ALL),PMAT(LICN_ALL),JVECT(LIRN_ALL),STAT=IER) CALL CHECK_STAT(IER,600) IF (JSV==1) THEN ALLOCATE (JMAT(NNZ),STAT=IER) CALL CHECK_STAT(IER,610) JMAT(1:NNZ) = ZERO END IF IF (MITER==7) THEN JVECT(1:LENIGP) = IGP(1:LENIGP) DEALLOCATE (IGP,STAT=IER) CALL CHECK_STAT(IER,620) ALLOCATE (IGP(LENIGP),STAT=IER) CALL CHECK_STAT(IER,630) IGP(1:LENIGP) = JVECT(1:LENIGP) END IF END IF IF (SCALE_MATRIX) THEN IF (ALLOCATED(CSCALEX)) THEN DEALLOCATE (CSCALEX,RSCALEX,WSCALEX,STAT=IER) CALL CHECK_STAT(IER,640) ALLOCATE (CSCALEX(N),RSCALEX(N),WSCALEX(N,5),STAT=IER) CALL CHECK_STAT(IER,650) ELSE ALLOCATE (CSCALEX(N),RSCALEX(N),WSCALEX(N,5),STAT=IER) CALL CHECK_STAT(IER,660) END IF END IF IF (LP /= 0) THEN MSG = 'The final DVPRPEPS storage allocations are:' CALL XERRDV(MSG,1510,1,0,0,0,0,ZERO,ZERO) MSG = ' NZ_ALL (=I1):' CALL XERRDV(MSG,1510,1,1,NZ_ALL,0,0,ZERO,ZERO) MSG = ' LIRN_ALL (=I1) and LICN_ALL (=I2):' CALL XERRDV(MSG,1510,1,2,LIRN_ALL,LICN_ALL,0,ZERO,ZERO) END IF RETURN END SUBROUTINE DVPREPS !_______________________________________________________________________ SUBROUTINE DVRENEW(NEQ,Y,SAVF,EWT,F) ! .. ! In the event MA28BD encounters a zero pivot in the LU factorization ! of the iteration matrix due to an out-of-date MA28AD pivot sequence, ! re-calculate the sparsity structure using finite differences. ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: NEQ ! .. ! .. Array Arguments .. KPP_REAL, INTENT (INOUT) :: EWT(*), SAVF(*), Y(*) ! .. ! .. Subroutine Arguments .. EXTERNAL F ! .. ! .. Local Scalars .. KPP_REAL :: DQ, DYJ, ERWT, FAC, YJ INTEGER :: ADDTONZ, I, IER, J, K, KVAL, NP1 CHARACTER (80) :: MSG ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, ALLOCATED, MAX, SIGN ! .. ! .. FIRST EXECUTABLE STATEMENT DVRENEW ! .. ! .. Caution: ! This routine must not be called before DVPREPS has been called. ! ! Note: ! On entry to DVRENEW, the allocated array sizes of arrays that ! may change size are: ! ICN, PMAT = length LICN_ALL ! JAN, JVECT = length LIRN_ALL ! JMAT = length NZ_ALL ! IGP = length LENIGP on first entry; N+1 thereafter ! Check if a numerical Jacobian is being used and stop if ! it is not. IF (MITER /= 7) THEN MSG = 'DVRENEW can be used only if MITER = 7.' CALL XERRDV(MSG,1520,2,0,0,0,0,ZERO,ZERO) END IF ! Save Y and SAVF. IF (.NOT.ALLOCATED(YTEMP)) THEN ALLOCATE (YTEMP(N),DTEMP(N),STAT=IER) CALL CHECK_STAT(IER,670) END IF YTEMP(1:N) = Y(1:N) DTEMP(1:N) = SAVF(1:N) ! Define the amount to be added to the array lengths ! if necessary. NP1 = N + 1 NNZ = IAN(NP1) - 1 ADDTONZ = ELBOW_ROOM * NNZ ! Just change the size of IGP to N+1 if have not already ! done so. IF (SIZE(IGP) /= NP1) THEN DEALLOCATE (IAN,STAT=IER) CALL CHECK_STAT(IER,680) ALLOCATE (IAN(NP1),STAT=IER) CALL CHECK_STAT(IER,690) END IF ! Go to the differencing section to determine the new ! sparsity structure. GOTO 20 10 CONTINUE ! Reallocate the arrays if necessary. IF (KVAL > LIRN_ALL) THEN ! Note: JAN and JVECT may need to be reallocated in DVJACS28. LIRN_ALL = LIRN_ALL + ADDTONZ IF (LIRN_ALL>MAX_ARRAY_SIZE) THEN MSG = 'Maximum array size exceeded. Stopping in DVRENEW.' CALL XERRDV(MSG,1530,2,0,0,0,0,ZERO,ZERO) END IF DEALLOCATE (JAN,JVECT,STAT=IER) CALL CHECK_STAT(IER,700) ALLOCATE (JAN(LIRN_ALL),JVECT(LIRN_ALL),STAT=IER) CALL CHECK_STAT(IER,710) END IF IF (KVAL > LICN_ALL) THEN ! Note: ICN and PMAT may need to be reallocated in DVJACS28. LICN_ALL = LICN_ALL + ADDTONZ IF (LICN_ALL>MAX_ARRAY_SIZE) THEN MSG = 'Maximum array size exceeded. Stopping in DVRENEW.' CALL XERRDV(MSG,1540,2,0,0,0,0,ZERO,ZERO) END IF DEALLOCATE (ICN,PMAT,STAT=IER) CALL CHECK_STAT(IER,720) ALLOCATE (ICN(LICN_ALL),PMAT(LICN_ALL),STAT=IER) CALL CHECK_STAT(IER,730) END IF 20 CONTINUE ! Perturb Y for structure determination: DO I = 1, N ERWT = ONE/EWT(I) FAC = ONE + ONE/(I+ONE) Y(I) = Y(I) + FAC*SIGN(ERWT,Y(I)) END DO ! Compute structure from results of N+1 calls to F. K = 1 IAN(1) = 1 DO I = 1, N ERWT = ONE/EWT(I) FAC = ONE + ONE/(I+ONE) Y(I) = Y(I) + FAC*SIGN(ERWT,Y(I)) END DO CALL F(NEQ,TN,Y,SAVF) NFE = NFE + 1 DO J = 1, N KVAL = K IF (KVAL > LIRN_ALL) THEN IF (LP /= 0) THEN MSG = 'LIRN_ALL (=I1) is not large enough.' CALL XERRDV(MSG,1550,1,0,0,0,0,ZERO,ZERO) MSG = 'Allocating more space for another try.' CALL XERRDV(MSG,1550,1,1,LIRN_ALL,0,0,ZERO,ZERO) END IF GOTO 10 END IF IF (KVAL > LICN_ALL) THEN IF (LP /= 0) THEN MSG = 'LICN_ALL (=I1) is not large enough.' CALL XERRDV(MSG,1560,1,0,0,0,0,ZERO,ZERO) MSG = 'Allocating more space for another try.' CALL XERRDV(MSG,1560,1,1,LICN_ALL,0,0,ZERO,ZERO) END IF GOTO 10 END IF YJ = Y(J) ERWT = ONE/EWT(J) DYJ = SIGN(ERWT,YJ) Y(J) = YJ + DYJ CALL F(NEQ,TN,Y,FTEMP1) NFE = NFE + 1 Y(J) = YJ DO 80 I = 1, N DQ = (FTEMP1(I)-SAVF(I))/DYJ IF ((ABS(DQ)<=SETH) .AND. (I/=J)) GOTO 80 JAN(K) = I K = K + 1 80 END DO IAN(J+1) = K END DO NNZ = IAN(NP1) - 1 IF (NNZ > NZ_ALL .AND. JSV == 1) THEN ! Increase the size of JMAT if necessary. NZ_ALL = NNZ IF (LP /= 0) THEN MSG = 'NZ_ALL (=I1) is not large enough.' CALL XERRDV(MSG,1570,1,0,0,0,0,ZERO,ZERO) MSG = 'Allocating more space for another try.' CALL XERRDV(MSG,1570,1,1,NZ_ALL,0,0,ZERO,ZERO) END IF IF (NZ_ALL>MAX_ARRAY_SIZE) THEN MSG = 'Maximum array size exceeded. Stopping in DVRENEW.' CALL XERRDV(MSG,1580,2,0,0,0,0,ZERO,ZERO) END IF DEALLOCATE (JMAT,STAT=IER) CALL CHECK_STAT(IER,740) ALLOCATE (JMAT(NZ_ALL),STAT=IER) CALL CHECK_STAT(IER,750) JMAT(1:NZ_ALL) = ZERO END IF ! Compute grouping of column indices. LENIGP = 0 MAXG = 0 MAXG = NP1 CALL DGROUP(N,IAN,JAN,MAXG,NGP,IGP,JGP,IKEEP28(1,1), & IKEEP28(1,2),IER) IF (IER/=0) THEN MSG = 'An error occurred in DGROUP.' CALL XERRDV(MSG,1590,2,0,0,0,0,ZERO,ZERO) END IF LENIGP = NGP + 1 ! Restore Y and SAVF. Y(1:N) = YTEMP(1:N) SAVF(1:N) = DTEMP(1:N) RETURN END SUBROUTINE DVRENEW !_______________________________________________________________________ SUBROUTINE DGROUP(N,IA,JA,MAXG,NGRP,IGP,JGP,INCL,JDONE,IER) ! .. ! Construct groupings of the column indices of the Jacobian matrix, ! used in the numerical evaluation of the Jacobian by finite ! differences for sparse solutions. ! .. ! Input: ! N = the order of the matrix ! IA,JA = sparse structure descriptors of the matrix by rows ! MAXG = length of available storage in the IGP array ! INCL and JDONE are working arrays of length N. ! Output: ! NGRP = number of groups ! JGP = array of length N containing the column indices by ! groups ! IGP = pointer array of length NGRP + 1 to the locations ! in JGP of the beginning of each group ! IER = error indicator. IER = 0 if no error occurred, or ! 1 if MAXG was insufficient ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. INTEGER, INTENT (INOUT) :: IER, NGRP INTEGER, INTENT (IN) :: MAXG, N ! .. ! .. Array Arguments .. INTEGER, INTENT (IN) :: IA(*), JA(*) INTEGER, INTENT (INOUT) :: IGP(*), INCL(*), JDONE(*), JGP(*) ! .. ! .. Local Scalars .. INTEGER :: I, J, K, KMAX, KMIN, NCOL, NG ! .. ! .. FIRST EXECUTABLE STATEMENT DGROUP ! .. IER = 0 JDONE(1:N) = 0 NCOL = 1 DO NG = 1, MAXG IGP(NG) = NCOL INCL(1:N) = 0 DO 20 J = 1, N ! Reject column J if it is already in a group. IF (JDONE(J)==1) GOTO 20 KMIN = IA(J) KMAX = IA(J+1) - 1 DO 10 K = KMIN, KMAX ! Reject column J if it overlaps any column already ! in this group. I = JA(K) IF (INCL(I)==1) GOTO 20 10 END DO ! Accept column J into group NG. JGP(NCOL) = J NCOL = NCOL + 1 JDONE(J) = 1 DO K = KMIN, KMAX I = JA(K) INCL(I) = 1 END DO 20 END DO ! Stop if this group is empty (grouping is complete). IF (NCOL==IGP(NG)) GOTO 30 END DO ! Error return if not all columns were chosen (MAXG too small). IF (NCOL<=N) GOTO 40 NG = MAXG 30 NGRP = NG - 1 RETURN 40 IER = 1 RETURN END SUBROUTINE DGROUP !_______________________________________________________________________ SUBROUTINE BGROUP(N,BJA,BINCL,BDONE,ML,MU) ! .. ! Construct groupings of the column indices of the Jacobian ! matrix, used in the numerical evaluation of the Jacobian ! by finite differences for banded solutions when the nonzero ! sub and super diagonals are known. BGROUP is similar to ! DGROUP but it does not require the sparse structure arrays ! and it uses real rather than integer work arrays. ! .. ! Input: ! ! N = the order of the matrix (number of odes) ! BINCL = real working array of length N ! BJA = real working array of length N ! BDONE = real working array of length N ! ML = integer lower bandwidth ! MU = integer upper bandwidth ! ! Output: (PRIVATE information used in DVJAC) ! ! BNGRP = integer number of groups ! BJGP = integer array of length N containing the ! column indices by groups ! BIGP = integer pointer array of length BNGRP + 1 ! to the locations in BJGP of the beginning ! of each group ! ! Note: ! On output: ! For I = 1, ..., BNGRP: ! Start of group I: ! J = BIGP(I) ! Number of columns in group I: ! K = BIGP(I+1) - BIGP(I) ! Columns in group I: ! BJGP(J-1+L), L=1, ..., K ! ! Note: ! The three arrays BJA, BINCL, and BDONE are REAL to avoid the ! necessity to allocate three new INTEGER arrays. BGROUP can ! be called only at an integration start or restart because ! DVODE_F90 work arrays are used for these arrays. ! ! Note: ! The PRIVATE banded information SUBDS, NSUBDS, SUPDS, NSUPS, ! ML, and MU must be defined before calling BGROUP. ! ML = lower bandwidth ! MU = upper bandwidth ! NSUBS = number of strict sub diagonals ! SUBDS(I) = row in which the Ith sub diagonal ! begins, I=1, ..., NSUBS ! NSUPS = number of strict super diagonals ! SUPDS(I) = column in which the Ith super diagonal ! begins, I=1, ..., NSUPS ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: N, ML, MU ! .. ! .. Array Arguments .. KPP_REAL, INTENT (INOUT) :: BINCL(*), BJA(*), BDONE(*) ! .. ! .. Local Scalars .. INTEGER :: I, IBDONE, IBINCL, IER, J, K, KBEGIN, KFINI, & KI, KJ, MAXG, NCOL, NG KPP_REAL :: FUDGE, ONE_PLUS_FUDGE CHARACTER (80) :: MSG ! .. ! .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN, REAL ! .. ! .. FIRST EXECUTABLE STATEMENT BGROUP ! .. ! Storage for the column grouping information. IF (ALLOCATED(BIGP)) THEN DEALLOCATE (BIGP,BJGP,STAT=IER) CALL CHECK_STAT(IER,760) END IF ALLOCATE (BIGP(N+1),BJGP(N),STAT=IER) CALL CHECK_STAT(IER,770) FUDGE = 0.4_dp ONE_PLUS_FUDGE = 1.0_dp + FUDGE MAXG = N + 1 ! BDONE(1:N) = 0 ... BDONE(1:N) = FUDGE NCOL = 1 DO NG = 1, MAXG BIGP(NG) = NCOL ! BINCL(1:N) = 0 ... BINCL(1:N) = FUDGE DO 30 J = 1, N ! Reject column J if it is already in a group. ! IF (BDONE(J) == 1) GOTO 30 ... IBDONE = INT(BDONE(J)) IF (IBDONE == 1) GOTO 30 ! Vertical extent of band = KBEGIN to KFINI. ! KJ = number of nonzeros in column J. ! BJA(K) = K implies nonzero at (k,j). KBEGIN = MAX(J-MU,1) KFINI = MIN(J+ML,N) KJ = 0 ! BJA(1:N) = 0 ... BJA(1:N) = FUDGE ! Locate the row positions of the nonzeros in column J. ! Restrict attention to the band: DO 10 K = KBEGIN, KFINI IF (K < J) THEN IF (NSUPS > 0) THEN DO I = NSUPS, 1, -1 ! KI = SUPDS(I) + J - 1 KI = J + 1 - SUPDS(I) IF (K == KI) THEN KJ = KJ + 1 ! BJA(K) = K ... BJA(K) = REAL(K) + FUDGE END IF END DO END IF ELSEIF (K == J) THEN KJ = KJ + 1 ! BJA(K) = K ... BJA(K) = REAL(K) + FUDGE ELSE IF (NSUBS > 0) THEN DO I = NSUBS, 1, -1 KI = SUBDS(I) + J -1 IF (K == KI) THEN KJ = KJ + 1 ! BJA(K) = K ... BJA(K) = REAL(K) + FUDGE END IF END DO END IF END IF 10 CONTINUE ! At this point BJA contains the row numbers for ! the nonzeros in column J. DO 20 K = KBEGIN, KFINI ! Reject column J if it overlaps any column ! already in this group. ! I = BJA(K) I = INT(BJA(K)) IBINCL = INT(BINCL(I)) ! IF (BINCL(I) == 1 .AND. I == K) GOTO 30 IF (IBINCL == 1 .AND. I == K) GOTO 30 20 END DO ! Accept column J into group NG. BJGP(NCOL) = J NCOL = NCOL + 1 ! BDONE(J) = 1 ... BDONE(J) = ONE_PLUS_FUDGE DO K = 1, N ! IF (I == K) BINCL(I) = 1 ... I = INT(BJA(K)) IF (I == K) BINCL(I) = ONE_PLUS_FUDGE END DO 30 END DO ! Done if this group is empty (grouping is complete). IF (NCOL == BIGP(NG)) GOTO 40 END DO ! Should not get here since MAXG = N + 1. ! Terminal error if not all columns were chosen ! because MAXG too small. IF (NCOL <= N) THEN MSG = 'An impossible error occurred in subroutine BGROUP.' CALL XERRDV(MSG,1600,2,0,0,0,0,ZERO,ZERO) END IF NG = MAXG 40 BNGRP = NG - 1 ! Trim BIGP to it's actual size if necessary. IF (NG < MAXG) THEN ! BJA(1:NG) = BIGP(1:NG) ... DO I = 1, NG BJA(I) = REAL(BIGP(I)) + FUDGE END DO DEALLOCATE (BIGP,STAT=IER) CALL CHECK_STAT(IER,780) ALLOCATE (BIGP(NG),STAT=IER) CALL CHECK_STAT(IER,790) ! BIGP(1:NG) = BJA(1:NG) ... DO I = 1, NG BIGP(I) = INT(BJA(I)) END DO END IF RETURN END SUBROUTINE BGROUP !_______________________________________________________________________ SUBROUTINE BANDED_IAJA(N,ML,MU) ! .. ! Build the sparse structure descriptor arrays for a banded ! matrix if the nonzero diagonals are known. ! .. ! Input: ! ! N = the order of the matrix (number of odes) ! ML = integer lower bandwidth ! MU = integer upper bandwidth ! ! Output: (PRIVATE information used in DVJAC) ! ! IAB = IA descriptor array ! JAB = JA descriptor array ! ! Note: ! The PRIVATE banded information SUBDS, NSUBS, SUPDS, NSUPS, ! ML, and MU must be defined before calling BANDED_IAJA. ! ML = lower bandwidth ! MU = upper bandwidth ! NSUBS = number of strict sub diagonals ! SUBDS(I) = row in which the Ith sub diagonal ! begins, I=1, ..., NSUBS ! NSUPS = number of strict super diagonals ! SUPDS(I) = column in which the Ith super diagonal ! begins, I=1, ..., NSUPS ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: N, ML, MU ! .. ! .. Local Scalars .. INTEGER :: I, IER, J, K, KBEGIN, KFINI, KI, KJ, & NP1, NZBB CHARACTER (80) :: MSG ! .. ! .. Intrinsic Functions .. INTRINSIC ALLOCATED, MAX, MIN ! .. ! .. FIRST EXECUTABLE STATEMENT BANDED_IAJA ! .. ! Check for errors. IF (.NOT.BUILD_IAJA) THEN MSG = 'BANDED_IAJA cannot be called with BUILD_IAJA = .FALSE.' CALL XERRDV(MSG,1610,2,0,0,0,0,ZERO,ZERO) END IF IF (NSUBS < 0) THEN MSG = 'NSUBS < 0 in BANDED_IAJA.' CALL XERRDV(MSG,1620,2,0,0,0,0,ZERO,ZERO) ELSE IF (NSUBS > 0) THEN IF (NSUBS /= SIZE(SUBDS)) THEN MSG = 'The size of the SUBDS array must' CALL XERRDV(MSG,1630,1,0,0,0,0,ZERO,ZERO) MSG = 'equal NSUBS in BANDED_IAJA.' CALL XERRDV(MSG,1630,2,0,0,0,0,ZERO,ZERO) END IF END IF END IF IF (NSUPS < 0) THEN MSG = 'NSUPS < 0 in BANDED_IAJA.' CALL XERRDV(MSG,1640,2,0,0,0,0,ZERO,ZERO) ELSE IF (NSUPS > 0) THEN IF (NSUPS /= SIZE(SUPDS)) THEN MSG = 'The size of the SUPDS array must' CALL XERRDV(MSG,1650,1,0,0,0,0,ZERO,ZERO) MSG = 'equal NSUPS in BANDED_IAJA.' CALL XERRDV(MSG,1650,2,0,0,0,0,ZERO,ZERO) END IF END IF END IF ! Allocate the necessary storage for the descriptor arrays. ! Define the total number of elements in all diagonals. NP1 = N + 1 NZB = (NSUBS + NSUPS + 1) * NP1 - 1 IF (NSUBS /= 0) THEN DO I = 1, NSUBS NZB = NZB - SUBDS(I) END DO END IF IF (NSUPS /= 0) THEN DO I = 1, NSUPS NZB = NZB - SUPDS(I) END DO END IF IF (ALLOCATED(IAB)) THEN DEALLOCATE(IAB,JAB,STAT=IER) CALL CHECK_STAT(IER,800) END IF ALLOCATE(IAB(NP1),JAB(NZB),STAT=IER) CALL CHECK_STAT(IER,810) IAB(1) = 1 NZBB = 0 ! For each column in the matrix... DO J = 1, N ! Vertical extent of band = KBEGIN to KFINI. ! KJ = number of nonzeros in column J. KBEGIN = MAX(J-MU,1) KFINI = MIN(J+ML,N) KJ = 0 ! Locate the row positions of the nonzeros in column J. ! (Restrict attention to the band.) IAB(J+1) = IAB(J) ! For each row in the intersection of the band with ! this column ... DO K = KBEGIN, KFINI ! Does column J intersect a super diagonal at (K,J)? IF (K < J) THEN DO I = NSUPS, 1, -1 KI = J + 1 - SUPDS(I) IF (K == KI) THEN KJ = KJ + 1 IAB(J+1) = IAB(J+1) + 1 NZBB = NZBB + 1 JAB(NZBB) = K GOTO 10 END IF END DO ELSEIF (K == J) THEN ! We are on the main diagonal. KJ = KJ + 1 IAB(J+1) = IAB(J+1) + 1 NZBB = NZBB + 1 JAB(NZBB) = K GOTO 10 ELSE ! Does column J intersect a sub diagonal at (K,J)? DO I = NSUBS, 1, -1 KI = SUBDS(I) + J - 1 IF (K == KI) THEN KJ = KJ + 1 IAB(J+1) = IAB(J+1) + 1 NZBB = NZBB + 1 JAB(NZBB) = K GOTO 10 END IF END DO END IF 10 CONTINUE END DO END DO IF (NZBB /= NZB) THEN MSG = 'NZBB (I1) is not equal to NZB (I2)' CALL XERRDV(MSG,1660,1,0,0,0,0,ZERO,ZERO) MSG = 'in BANDED_IAJA.' CALL XERRDV(MSG,1660,2,2,NZBB,NZB,0,ZERO,ZERO) END IF RETURN END SUBROUTINE BANDED_IAJA !_______________________________________________________________________ SUBROUTINE BANDED_GET_BJNZ(N,ML,MU,JCOL,JNZ,NZJ) ! .. ! Locate the nonzeros in a given column of a sparse banded matrix ! with known diagonals. This is a version of BANDED_IAJA modified ! to do only one column. ! .. ! Input: ! ! N = the order of the matrix (number of odes) ! ML = integer lower bandwidth ! MU = integer upper bandwidth ! JCOL = column number between 1 and N ! JZ = integer array of length N ! ! Output: ! ! JNZ = integer array of length N. If ! JNZ(K) is not 0, there is a ! nonzero at position (K,JCOL) ! NZJ = number of nozeros in column JCOL ! ! Caution: ! No parameter checking is done since this subroutine ! will be called many times. Note that a number of ! PRIVATE parameters must be set before calling this ! subroutine. ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: N, ML, MU, JCOL INTEGER, INTENT (OUT) :: NZJ ! .. ! .. Array Arguments .. INTEGER, INTENT (OUT) :: JNZ(*) ! .. ! .. Local Scalars .. INTEGER :: I, J, K, KBEGIN, KFINI, KI, KJ ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN ! .. ! .. FIRST EXECUTABLE STATEMENT BANDED_GET_BJNZ ! .. JNZ(1:N) = 0 J = JCOL ! Locate the row positions of the nonzeros in column J. ! Vertical extent of band = KBEGIN to KFINI. KBEGIN = MAX(J-MU,1) KFINI = MIN(J+ML,N) ! KJ = number of nonzeros in column J. KJ = 0 ! For each row in the intersection of the band with ! this column ... DO K = KBEGIN, KFINI ! Does column J intersect a super diagonal at (K,J)? IF (K < J) THEN DO I = NSUPS, 1, -1 KI = J + 1 - SUPDS(I) IF (K == KI) THEN KJ = KJ + 1 JNZ(KJ) = K GOTO 10 END IF END DO ELSEIF (K == J) THEN ! We are on the main diagonal. KJ = KJ + 1 JNZ(KJ) = K GOTO 10 ELSE ! Does column J intersect a sub diagonal at (K,J)? DO I = NSUBS, 1, -1 KI = SUBDS(I) + J - 1 IF (K == KI) THEN KJ = KJ + 1 JNZ(KJ) = K GOTO 10 END IF END DO END IF 10 CONTINUE END DO NZJ = KJ RETURN END SUBROUTINE BANDED_GET_BJNZ !_______________________________________________________________________ ! Beginning of Jacobian related routines that use MA28 SUBROUTINE DVNLSS28(Y,YH,LDYH,SAVF,EWT,ACOR,IWM,WM,F,JAC, & NFLAG,ATOL,ITOL) ! .. ! This is the nonlinear system solver for MA28 based sparse solutions. ! .. ! Subroutine DVNLSS28 is a nonlinear system solver, which uses functional ! iteration or a chord (modified Newton) method. For the chord method ! direct linear algebraic system solvers are used. Subroutine DVNLSS28 ! then handles the corrector phase of this integration package. ! Communication with DVNLSS28 is done with the following variables. (For ! more details, please see the comments in the driver subroutine.) ! Y = The dependent variable, a vector of length N, input. ! YH = The Nordsieck (Taylor) array, LDYH by LMAX, input ! and output. On input, it contains predicted values. ! LDYH = A constant >= N, the first dimension of YH, input. ! SAVF = A work array of length N. ! EWT = An error weight vector of length N, input. ! ACOR = A work array of length N, used for the accumulated ! corrections to the predicted y vector. ! WM,IWM = Real and integer work arrays associated with matrix ! operations in chord iteration (MITER /= 0). ! F = Dummy name for user supplied routine for f. ! JAC = Dummy name for user supplied Jacobian routine. ! NFLAG = Input/output flag, with values and meanings as follows: ! INPUT ! 0 first call for this time step. ! -1 convergence failure in previous call to DVNLSS28. ! -2 error test failure in DVSTEP. ! OUTPUT ! 0 successful completion of nonlinear solver. ! -1 convergence failure or singular matrix. ! -2 unrecoverable error in matrix preprocessing ! (cannot occur here). ! -3 unrecoverable error in solution (cannot occur ! here). ! IPUP = Own variable flag with values and meanings as follows: ! 0, do not update the Newton matrix. ! MITER \= 0 update Newton matrix, because it is the ! initial step, order was changed, the error ! test failed, or an update is indicated by ! the scalar RC or step counter NST. ! For more details, see comments in driver subroutine. ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ITOL, LDYH INTEGER, INTENT (INOUT) :: NFLAG ! .. ! .. Array Arguments .. KPP_REAL, INTENT (INOUT) :: ACOR(*), EWT(*), SAVF(*), & WM(*), Y(*), YH(LDYH,*) KPP_REAL, INTENT (IN) :: ATOL(*) INTEGER IWM(*) LOGICAL DUMMY ! .. ! .. Subroutine Arguments .. EXTERNAL F, JAC ! .. ! .. Local Scalars .. KPP_REAL :: ACNRMNEW, CSCALE, DCON, DEL, DELP INTEGER :: I, IERPJ, IERSL, M ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN ! .. ! .. FIRST EXECUTABLE STATEMENT DVNLSS28 ! .. ! Get rid of a couple of needless compiler warning messages. DUMMY = .FALSE. IF (DUMMY) THEN WM(1) = ZERO IWM(1) = 0 END IF ! On the first step, on a change of method order, or after a ! nonlinear convergence failure with NFLAG = -2, set IPUP = MITER ! to force a Jacobian update when MITER /= 0. IF (JSTART==0) NSLP = 0 IF (NFLAG==0) ICF = 0 IF (NFLAG==-2) IPUP = MITER IF ((JSTART==0) .OR. (JSTART==-1)) IPUP = MITER ! If this is functional iteration, set CRATE = 1 and drop ! to 220. IF (MITER==0) THEN CRATE = ONE GOTO 10 END IF ! RC is the ratio of new to old values of the coefficient H/EL(2)=h/l1. ! When RC differs from 1 by more than CCMAX, IPUP is set to MITER ! to force DVJACS28 to be called, if a Jacobian is involved. In any ! case, DVJACS28 is called at least every MSBP steps. DRC = ABS(RC-ONE) IF (DRC>CCMAX .OR. NST>=NSLP+MSBP) IPUP = MITER ! Up to MAXCOR corrector iterations are taken. A convergence test is ! made on the r.m.s. norm of each correction, weighted by the error ! weight vector EWT. The sum of the corrections is accumulated in the ! vector ACOR(i). The YH array is not altered in the corrector loop. 10 M = 0 DELP = ZERO ! Original: ! CALL DCOPY_F90(N,YH(1,1),1,Y,1) CALL DCOPY_F90(N,YH(1:N,1),1,Y(1:N),1) CALL F(N,TN,Y,SAVF) NFE = NFE + 1 IF (BOUNDS) THEN DO I = 1, NDX IF (ABS(YH(IDX(I),1)-LB(I))<=ZERO) SAVF(IDX(I)) = & MAX(SAVF(IDX(I)),ZERO) IF (ABS(YH(IDX(I),1)-UB(I))<=ZERO) SAVF(IDX(I)) = & MIN(SAVF(IDX(I)),ZERO) END DO END IF IF (IPUP<=0) GOTO 20 ! If indicated, the matrix P = I - h*rl1*J is reevaluated and ! preprocessed before starting the corrector iteration. IPUP ! is set to 0 as an indicator that this has been done. CALL DVJACS28(Y,YH,LDYH,EWT,ACOR,SAVF,F,JAC,IERPJ,N, & ATOL,ITOL) IPUP = 0 RC = ONE DRC = ZERO CRATE = ONE NSLP = NST ! If matrix is singular, take error return to force cut in ! step size. IF (IERPJ/=0) GOTO 70 20 ACOR(1:N) = ZERO ! This is a looping point for the corrector iteration. 30 IF (MITER/=0) GOTO 40 ! In the case of functional iteration, update Y directly from ! the result of the last function evaluation. SAVF(1:N) = RL1*(H*SAVF(1:N)-YH(1:N,2)) Y(1:N) = SAVF(1:N) - ACOR(1:N) DEL = DVNORM(N,Y,EWT) Y(1:N) = YH(1:N,1) + SAVF(1:N) CALL DCOPY_F90(N,SAVF,1,ACOR,1) GOTO 50 ! In the case of the chord method, compute the corrector error, ! and solve the linear system with that as right-hand side and ! P as coefficient matrix. The correction is scaled by the factor ! 2/(1+RC) to account for changes in h*rl1 since the last ! DVJACS28 call. 40 Y(1:N) = (RL1*H)*SAVF(1:N) - (RL1*YH(1:N,2)+ACOR(1:N)) CALL DVSOLS28(Y,SAVF,IERSL) NNI = NNI + 1 IF (IERSL>0) GOTO 60 IF (METH==2 .AND. ABS(RC-ONE)>ZERO) THEN CSCALE = TWO/(ONE+RC) CALL DSCAL_F90(N,CSCALE,Y,1) END IF DEL = DVNORM(N,Y,EWT) CALL DAXPY_F90(N,ONE,Y,1,ACOR,1) Y(1:N) = YH(1:N,1) + ACOR(1:N) ! Test for convergence. If M > 0, an estimate of the convergence ! rate constant is stored in CRATE, and this is used in the test. 50 IF (M/=0) CRATE = MAX(CRDOWN*CRATE,DEL/DELP) DCON = DEL*MIN(ONE,CRATE)/TQ(4) IF (DCON<=ONE) GOTO 80 M = M + 1 IF (M==MAXCOR) GOTO 60 IF (M>=2 .AND. DEL>RDIV*DELP) GOTO 60 DELP = DEL CALL F(N,TN,Y,SAVF) NFE = NFE + 1 IF (BOUNDS) THEN DO I = 1, NDX IF (ABS(YH(IDX(I),1)-LB(I))<=ZERO) SAVF(IDX(I)) = & MAX(SAVF(I),ZERO) IF (ABS(YH(IDX(I),1)-UB(I))<=ZERO) SAVF(IDX(I)) = & MIN(SAVF(I),ZERO) END DO END IF GOTO 30 60 IF (MITER==0 .OR. JCUR==1) GOTO 70 ICF = 1 IPUP = MITER GOTO 10 70 CONTINUE NFLAG = -1 ICF = 2 IPUP = MITER RETURN ! Return for successful step. 80 NFLAG = 0 ! Enforce bounds. IF (BOUNDS) THEN CHANGED_ACOR = .FALSE. IF (M==0) THEN ACNRM = DEL ELSE ACNRM = DVNORM(N,ACOR,EWT) END IF IF (MITER/=0) THEN ! Since Y(:) = YH(:,1) + ACOR(:): DO I = 1, NDX IF (Y(IDX(I))UB(I)) THEN CHANGED_ACOR = .TRUE. ACOR(IDX(I)) = UB(I) - YH(IDX(I),1) SAVF(IDX(I)) = ACOR(IDX(I)) END IF END DO ELSE ! Since Y(:) = YH(:,1) + SAVF(:) and ! since CALL DCOPY_F90(N, SAVF, 1, ACOR, 1) ... DO I = 1, NDX IF (Y(IDX(I))UB(IDX(I))) THEN CHANGED_ACOR = .TRUE. ACOR(IDX(I)) = UB(I) - YH(IDX(I),1) END IF END DO END IF IF (CHANGED_ACOR) THEN IF (M==0) THEN ACNRMNEW = DEL ELSE ACNRMNEW = DVNORM(N,ACOR,EWT) END IF ACNRM = MAX(ACNRM,ACNRMNEW) ELSE END IF NFLAG = 0 JCUR = 0 ICF = 0 ELSE ! No projections are required. NFLAG = 0 JCUR = 0 ICF = 0 IF (M==0) ACNRM = DEL IF (M>0) ACNRM = DVNORM(N,ACOR,EWT) END IF RETURN END SUBROUTINE DVNLSS28 !_______________________________________________________________________ SUBROUTINE DVSOLS28(X,TEM,IERSL) ! .. ! Manage the solution of the MA28 based sparse linear system arising ! from a chord iteration. ! .. ! This routine solves the sparse linear system arising from a chord ! iteration. If MITER is 6 or 7, it calls MA28CD to accomplish this. ! Communication with DVSOLS28 uses the following variables: ! X = The right-hand side vector on input, and the solution vector ! on output, of length N. ! TEM (=SAVF(*)) ! IERSL = Output flag. IERSL = 0 if no trouble occurred. ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. INTEGER, INTENT (INOUT) :: IERSL ! .. ! .. Array Arguments .. KPP_REAL, INTENT (INOUT) :: TEM(*), X(*) ! .. ! .. Local Scalars .. INTEGER :: I ! .. ! .. FIRST EXECUTABLE STATEMENT DVSOLS28 ! .. IF (SCALE_MATRIX) THEN DO I = 1, N X(I) = X(I) * RSCALEX(I) END DO END IF IERSL = 0 CALL MA28CD(N,PMAT,LICN_ALL,ICN,IKEEP28,X,TEM,1) MA28CD_CALLS = MA28CD_CALLS + 1 IF (SCALE_MATRIX) THEN DO I = 1, N X(I) = X(I) * CSCALEX(I) END DO END IF RETURN END SUBROUTINE DVSOLS28 !_______________________________________________________________________ SUBROUTINE DVJACS28(Y,YH,LDYH,EWT,FTEMP1,SAVF,F,JAC,IERPJ,N, & ATOL,ITOL) ! .. ! Compute and process P = I - H*RL1*J, where J is an approximation to ! the MA28 based sparse Jacobian. ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. INTEGER, INTENT (INOUT) :: IERPJ INTEGER, INTENT (IN) :: LDYH, N, ITOL ! .. ! .. Array Arguments .. KPP_REAL, INTENT (INOUT) :: EWT(*), FTEMP1(*), SAVF(*), Y(*), YH(LDYH,*) KPP_REAL, INTENT (IN) :: ATOL(*) ! .. ! .. Subroutine Arguments .. EXTERNAL F, JAC ! .. ! .. Local Scalars .. KPP_REAL :: CON, FAC, HRL1, R, R0, SRUR INTEGER :: I, IER, J, JER, JJ, JJ1, JJ2, K, K1, K2, MA28, & MA28SAVE, MB28SAVE, NG, NZ CHARACTER (80) :: MSG ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, EXP, MAX, REAL ! .. ! .. FIRST EXECUTABLE STATEMENT DVJACS28 ! .. IERPJ = 0 ! Structure determination ! Calculate the sparsity structure if this is the first call to ! DVJACS28 with ISTATE = 1 or if it is a continuation call with ! ISTATE = 3. IF (ISTATC==1 .OR. ISTATC==3) THEN CALL DVPREPS(N,Y,YH,LDYH,DTEMP,EWT,F,JAC) ISTATC = 0 END IF JCUR = 0 HRL1 = H*RL1 CON = -HRL1 ! If MA28 = 4 the saved copy of the Jacobian will be used ! to restore PMAT. If MA28 = 1,2,3 the Jacobian will be ! recomputed. If MA28 = 1,2 the JVECT and ICN pointer arrays ! will be defined and MA28AD will be called to decompose ! PMAT. If MA28 = 3 the JVECT pointer array will be defined ! and MA28BD will be called to decompose PMAT using the ICN ! pointer array returned in the last call to MA28AD. MA28 = 4 IF (INEWJ==1 .OR. MB28==0) MA28 = 3 IF (NST>=NSLJ+MSBJ) MA28 = 3 ! IF (ICF==1 .OR. ICF==2) MA28 = 3 IF (ICF==1 .AND. DRC=NSLG+MSBG) MA28 = 2 IF (JSTART==0 .OR. JSTART==-1) MA28 = 1 JSTART = 1 10 IF (MA28<=2) NSLG = NST IF (MA28<=3) NSLJ = NST ! Analytical Sparse Jacobian ! If MITER = 6, call JAC to evaluate J analytically, multiply ! J by CON = -H*EL(1), and add the identity matrix to form P. IF (MITER==6) THEN IF (MA28==4) THEN ! Reuse the saved Jacobian. NZ = IAN(N+1) - 1 PMAT(1:NZ) = CON*JMAT(1:NZ) DO K = 1, NZ IF (JAN(K)==JVECT(K)) PMAT(K) = PMAT(K) + ONE END DO GOTO 90 END IF JCUR = 1 NJE = NJE + 1 IF (MA28==1 .OR. MA28==2) THEN NZ = IAN(N+1) - 1 CALL JAC(N,TN,Y,IAN,JAN,NZ,PMAT) NZ = IAN(N+1) - 1 IF (NZ>NZ_ALL) THEN MSG = 'DVODE_F90-- NZ > NZ_ALL in DVJACS28.' CALL XERRDV(MSG,1670,2,0,0,0,0,ZERO,ZERO) END IF ! Define column pointers for MA28AD. CALL SET_ICN(N,IAN,ICN) CALL CHECK_DIAG(N,IAN,JAN,ICN) PMAT(1:NZ) = CON*PMAT(1:NZ) DO K = 1, NZ IF (JAN(K)==ICN(K)) PMAT(K) = PMAT(K) + ONE END DO GOTO 80 ELSE ! MA28 = 3... NZ = IAN(N+1) - 1 CALL JAC(N,TN,Y,IAN,JAN,NZ,PMAT) NZ = IAN(N+1) - 1 IF (NZ>NZ_ALL) THEN MSG = 'DVODE_F90-- NZ > NZ_ALL in DVJACS28.' CALL XERRDV(MSG,1680,2,0,0,0,0,ZERO,ZERO) END IF ! Define column pointers for MA28AD. CALL SET_ICN(N,IAN,JVECT) CALL CHECK_DIAG(N,IAN,JAN,JVECT) IF (INEWJ/=1) JMAT(1:NZ) = PMAT(1:NZ) PMAT(1:NZ) = CON*PMAT(1:NZ) DO K = 1, NZ IF (JAN(K)==JVECT(K)) PMAT(K) = PMAT(K) + ONE END DO GOTO 90 END IF END IF ! Finite Difference Sparse Jacobian ! If MITER = 7, evaluate J numerically, multiply J by ! CON, and add the identity matrix to form P. IF (MITER==7) THEN IF (MA28==4) THEN ! Reuse the saved constant Jacobian. NZ = IAN(N+1) - 1 PMAT(1:NZ) = CON*JMAT(1:NZ) DO J = 1, N K1 = IAN(J) K2 = IAN(J+1) - 1 DO K = K1, K2 I = JAN(K) IF (I==J) PMAT(K) = PMAT(K) + ONE END DO END DO GOTO 90 ELSE NZ = IAN(N+1) - 1 JCUR = 1 IF (.NOT.(J_IS_CONSTANT.AND.J_HAS_BEEN_COMPUTED)) THEN IF (USE_JACSP) THEN ! Approximate the Jacobian using Doug Salane's JACSP. ! The JPNTRDS and INDROWDS pointer arrays were defined ! in DVPREPS (and altered in DSM). IOPTDS(1) = 2 IOPTDS(2) = 0 IOPTDS(3) = 1 IOPTDS(5) = 0 ! INFORDS(4) was initialized in DVPREPS (and altered in ! the first call to JACSP). LWKDS = 3 * N LIWKDS = 50 + N NRFJACDS = NZ NCFJACDS = 1 ! Set flag to indicate how the YSCALE vector will be ! set for JACSP. LIKE_ORIGINAL_VODE = .FALSE. ! Calculate the YSCALEDS vector for JACSPDV. IF (LIKE_ORIGINAL_VODE) THEN FAC = DVNORM(N,SAVF,EWT) ! JACSPDB multiplies YSCALEDS(*) BY UROUND**0.825: ! R0 = THOU*ABS(H)*UROUND*REAL(N)*FAC R0 = THOU*ABS(H)*REAL(N)*FAC IF (ABS(R0)<=ZERO) R0 = ONE ! SRUR = WM1 DO J = 1, N ! JACSPDB multiplies YSCALEDS(*) BY UROUND**0.825: ! R = MAX(ABS(Y(J)),R0/EWT(J)) R = MAX(ABS(Y(J))/U325,(R0/EWT(J))*U125) YSCALEDS(J) = R END DO ELSE IF (ITOL == 1 .OR. ITOL == 3) THEN DO J = 1, N YSCALEDS(J) = MAX(ABS(Y(J)),ATOL(1),UROUND) END DO ELSE DO J = 1, N YSCALEDS(J) = MAX(ABS(Y(J)),ATOL(J),UROUND) END DO END IF END IF CALL JACSPDB(F,N,TN,Y,SAVF,PMAT(1),NRFJACDS, & YSCALEDS,FACDS,IOPTDS,WKDS,LWKDS,IWKDS,LIWKDS, & MAXGRPDS,NGRPDS,JPNTRDS,INDROWDS) NFE = NFE + IWKDS(7) NJE = NJE + 1 DO NG = 1, MAXGRPDS JJ1 = IGP(NG) JJ2 = IGP(NG+1) - 1 DO JJ = JJ1, JJ2 J = JGP(JJ) K1 = IAN(J) K2 = IAN(J+1) - 1 DO K = K1, K2 I = JAN(K) GOTO (17,17,18) MA28 ! Define the row pointers for MA28AD. 17 JVECT(K) = I ! Define the column pointers for MA28AD. ICN(K) = J GOTO 19 ! Define the column pointers for MA28AD. 18 JVECT(K) = J 19 CONTINUE IF (INEWJ==0) JMAT(K) = PMAT(K) PMAT(K) = CON*PMAT(K) IF (I==J) PMAT(K) = PMAT(K) + ONE END DO END DO END DO NFE = NFE + MAXGRPDS ELSE FAC = DVNORM(N,SAVF,EWT) R0 = THOU*ABS(H)*UROUND*REAL(N)*FAC IF (ABS(R0)<=ZERO) R0 = ONE SRUR = WM1 DO NG = 1, NGP JJ1 = IGP(NG) JJ2 = IGP(NG+1) - 1 DO JJ = JJ1, JJ2 J = JGP(JJ) R = MAX(SRUR*ABS(Y(J)),R0/EWT(J)) Y(J) = Y(J) + R END DO CALL F(N,TN,Y,FTEMP1) NFE = NFE + 1 DO JJ = JJ1, JJ2 J = JGP(JJ) Y(J) = YH(J,1) R = MAX(SRUR*ABS(Y(J)),R0/EWT(J)) FAC = ONE / R K1 = IAN(J) K2 = IAN(J+1) - 1 DO K = K1, K2 I = JAN(K) GOTO (20,20,30) MA28 ! Define row pointers for MA28AD. 20 JVECT(K) = I ! Define column pointers for MA28AD. ICN(K) = J GOTO 40 ! Define column pointers for MA28AD. 30 JVECT(K) = J 40 PMAT(K) = (FTEMP1(I)-SAVF(I)) * FAC IF (INEWJ==0) JMAT(K) = PMAT(K) PMAT(K) = CON*PMAT(K) IF (I==J) PMAT(K) = PMAT(K) + ONE END DO END DO END DO NFE = NFE + NGP NJE = NJE + 1 END IF IF (J_IS_CONSTANT) J_HAS_BEEN_COMPUTED = .TRUE. ELSE ! Do not recompute the constant Jacobian. ! Reuse the saved Jacobian. NZ = IAN(N+1) - 1 PMAT(1:NZ) = CON*JMAT(1:NZ) DO J = 1, N K1 = IAN(J) K2 = IAN(J+1) - 1 DO K = K1, K2 I = JAN(K) IF (I==J) PMAT(K) = PMAT(K) + ONE GOTO (50,50,60) MA28 ! Define row pointers for MA28AD. 50 JVECT(K) = I ! Define column pointers for MA28AD. ICN(K) = J GOTO 70 ! Define column pointers for MA28AD. 60 JVECT(K) = J 70 CONTINUE END DO END DO END IF GOTO (80,80,90) MA28 END IF END IF ! MA28AD does an LU factorization based on a pivotal strategy ! designed to compromise between maintaining sparsity and ! controlling loss of accuracy due to roundoff error. Unless ! magnitudes of Jacobian elements change so as to invalidate ! choice of pivots, MA28AD need only be called at beginning ! of the integration. 80 CONTINUE IF (SCALE_MATRIX) THEN ! MA19AD computes scaling factors for the iteration matrix. CALL MC19AD(N,NZ,PMAT,JAN,ICN,RSCALEX,CSCALEX,WSCALEX) MC19AD_CALLS = MC19AD_CALLS + 1 DO I =1, N RSCALEX(I) = EXP(RSCALEX(I)) CSCALEX(I) = EXP(CSCALEX(I)) END DO DO K = 1, NZ I = JAN(K) J = ICN(K) PMAT(K) = PMAT(K) * RSCALEX(I) * CSCALEX(J) END DO END IF OK_TO_CALL_MA28 = .TRUE. CALL MA28AD(N,NZ,PMAT,LICN_ALL,JAN,LIRN_ALL,ICN,U_PIVOT, & IKEEP28,IW28,FTEMP1,IER) OK_TO_CALL_MA28 = .FALSE. MA28AD_CALLS = MA28AD_CALLS + 1 MA28SAVE = MA28 MB28SAVE = MB28 MB28 = 0 NLU = NLU + 1 MAX_MINIRN = MAX(MAX_MINIRN,MINIRN) MAX_MINICN = MAX(MAX_MINICN,MINICN) ! IER = -1: Numerically singular Jacobian ! IER = -2: Structurally singular Jacobian IF (IER==-1 .OR. IER==-2) IERPJ = 1 IF (IER==-3) THEN ! LIRN_ALL is not large enough. IF (LP /= 0) THEN MSG = 'LIRN_ALL (=I1) is not large enough.' CALL XERRDV(MSG,1690,1,0,0,0,0,ZERO,ZERO) MSG = 'Allocating more space for another try.' CALL XERRDV(MSG,1690,1,1,LIRN_ALL,0,0,ZERO,ZERO) END IF ! Allocate more space for JAN and JVECT and try again. LIRN_ALL = LIRN_ALL + MAX(MAX(1000,ELBOW_ROOM*NZ_SWAG),10*N) LIRN_ALL = MAX(LIRN_ALL,(11*MINIRN)/10) IF (LIRN_ALL>MAX_ARRAY_SIZE) THEN MSG = 'Maximum array size exceeded. Stopping.' CALL XERRDV(MSG,1700,2,0,0,0,0,ZERO,ZERO) END IF DEALLOCATE (JAN,STAT=JER) CALL CHECK_STAT(JER,820) ALLOCATE (JAN(LIRN_ALL),STAT=JER) CALL CHECK_STAT(JER,830) IF (MITER==7) THEN JAN(1:NZ) = JVECT(1:NZ) END IF DEALLOCATE (JVECT,STAT=JER) CALL CHECK_STAT(JER,840) ALLOCATE (JVECT(LIRN_ALL),STAT=JER) CALL CHECK_STAT(JER,850) IF (MITER==7) THEN JVECT(1:NZ) = JAN(1:NZ) END IF MA28 = MA28SAVE MB28 = MB28SAVE NLU = NLU - 1 ! Since PMAT has changed, it must be restored: IF (J_IS_CONSTANT) J_HAS_BEEN_COMPUTED = .FALSE. GOTO 10 END IF IF (IER==-4 .OR. IER==-5 .OR. IER==-6) THEN ! LICN_ALL is not large enough. IF (LP /= 0) THEN MSG = 'LICN_ALL (=I1) is not large enough.' CALL XERRDV(MSG,1710,1,0,0,0,0,ZERO,ZERO) MSG = 'Allocating more space for another try.' CALL XERRDV(MSG,1710,1,1,LICN_ALL,0,0,ZERO,ZERO) END IF ! Allocate more space for JAN and JVECT and try again. LICN_ALL = LICN_ALL + MAX(MAX(1000,ELBOW_ROOM*NZ_SWAG),10*N) LICN_ALL = MAX(LICN_ALL,(11*MINICN)/10) IF (LICN_ALL>MAX_ARRAY_SIZE) THEN MSG = 'Maximum array size exceeded. Stopping.' CALL XERRDV(MSG,1720,2,0,0,0,0,ZERO,ZERO) END IF DEALLOCATE (PMAT,ICN,STAT=JER) CALL CHECK_STAT(JER,860) ALLOCATE (PMAT(LICN_ALL),ICN(LICN_ALL),STAT=JER) PMAT(1:LICN_ALL) = ZERO CALL CHECK_STAT(JER,870) IF (MITER==7) THEN JAN(1:NZ) = JVECT(1:NZ) END IF MA28 = MA28SAVE MB28 = MB28SAVE NLU = NLU - 1 IF (J_IS_CONSTANT) J_HAS_BEEN_COMPUTED = .FALSE. GOTO 10 END IF IF (MITER/=7) RETURN JAN(1:NZ) = JVECT(1:NZ) RETURN ! MA28BD uses the pivot sequence generated by an earlier call ! to MA28AD to factor a new matrix of the same structure. 90 CONTINUE IF (SCALE_MATRIX) THEN DO K =1, NZ I = JAN(K) J = JVECT(K) PMAT(K) = PMAT(K) * RSCALEX(I) * CSCALEX(J) END DO END IF CALL MA28BD(N,NZ,PMAT,LICN_ALL,JAN,JVECT,ICN,IKEEP28,IW28, & FTEMP1,IER) MA28BD_CALLS = MA28BD_CALLS + 1 MB28 = 1 NLU = NLU + 1 ! IER = -2 : The matrix is numerically singular. The MA28AD ! pivot sequence leads to a zero pivot, that is, ! to one for which the ratio of it to the smallest ! element in the row is less than EPS. ! IER = -13: The matrix is structurally singular. IF (REDO_PIVOT_SEQUENCE) THEN ! Force MA28AD to calculate a new pivot sequence. IF (IER/=-13 .AND. IER/=-2 .AND. IER<=0) RETURN IF (IER==-2) MA28 = 1 IF (IER==-13) MA28 = 1 IF (J_IS_CONSTANT) J_HAS_BEEN_COMPUTED = .FALSE. ELSE IF (IER==-2) IERPJ = 1 IF (IER/=-13 .AND. IER<=0) RETURN IF (IER==-13) MA28 = 1 IF (J_IS_CONSTANT) J_HAS_BEEN_COMPUTED = .FALSE. END IF IF (IER>0) MA28 = 2 IF (IER==-13 .AND. MITER==7 .AND. MOSS==2) THEN ! Recompute the sparsity structure. CALL DVRENEW(N,Y,SAVF,EWT,F) IF (J_IS_CONSTANT) J_HAS_BEEN_COMPUTED = .FALSE. END IF GOTO 10 END SUBROUTINE DVJACS28 ! End of Jacobian related routines that use MA28 !_______________________________________________________________________ SUBROUTINE SET_ICN(N,IA,ICN) ! .. ! Define the column locations of nonzero elements for a sparse ! matrix. ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: N ! .. ! .. Array Arguments .. INTEGER, INTENT (IN) :: IA(*) INTEGER, INTENT (INOUT) :: ICN(*) ! .. ! .. Local Scalars .. INTEGER :: J, KMAX, KMIN ! .. ! .. FIRST EXECUTABLE STATEMENT SET_ICN ! .. KMIN = 1 DO J = 1, N KMAX = IA(J+1) - 1 ICN(KMIN:KMAX) = J KMIN = KMAX + 1 END DO END SUBROUTINE SET_ICN !_______________________________________________________________________ SUBROUTINE CHECK_DIAG(N,IA,JA,ICN) ! .. ! Check that the diagonal is included in the sparse matrix ! description arrays. ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: N ! .. ! .. Array Arguments .. INTEGER, INTENT (IN) :: IA(*), ICN(*), JA(*) ! .. ! .. Local Scalars .. INTEGER :: J, K, KMAX, KMIN CHARACTER (80) :: MSG ! .. ! .. FIRST EXECUTABLE STATEMENT CHECK_DIAG ! .. KMIN = 1 DO J = 1, N KMAX = IA(J+1) - 1 DO K = KMIN, KMAX IF (JA(K)==ICN(K)) GOTO 10 END DO MSG = 'In CHECK_DIAG, the diagonal is not present.' CALL XERRDV(MSG,1730,2,0,0,0,0,ZERO,ZERO) 10 CONTINUE KMIN = KMAX + 1 END DO END SUBROUTINE CHECK_DIAG !_______________________________________________________________________ SUBROUTINE DVCHECK(JOB,G,NEQ,Y,YH,NYH,G0,G1,GX,IRT) ! .. ! Check for the presence of a root in the vicinity of the current T, ! in a manner depending on the input flag JOB, and call DVROOTS to ! locate the root as precisely as possible. ! .. ! This subroutine is essentially DRCHEK from LSODAR. ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. INTEGER, INTENT (INOUT) :: IRT INTEGER, INTENT (IN) :: JOB, NEQ, NYH ! .. ! .. Array Arguments .. KPP_REAL, INTENT (INOUT) :: G0(*), G1(*), GX(*), Y(*), YH(NYH,*) ! .. ! .. Subroutine Arguments .. EXTERNAL G ! .. ! .. Local Scalars .. KPP_REAL :: HMING, T1, TEMP1, TEMP2, X INTEGER :: I, IFLAG, JFLAG LOGICAL :: ZROOT ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SIGN ! .. ! In addition to variables described previously, DVCHECK ! uses the following for communication: ! JOB = integer flag indicating type of call: ! JOB = 1 means the problem is being initialized, and DVCHECK ! is to look for a root at or very near the initial T. ! JOB = 2 means a continuation call to the solver was just ! made, and DVCHECK is to check for a root in the ! relevant part of the step last taken. ! JOB = 3 means a successful step was just taken, and DVCHECK ! is to look for a root in the interval of the step. ! G0 = array of length NG, containing the value of g at T = T0ST. ! G0 is input for JOB >= 2, and output in all cases. ! G1,GX = arrays of length NG for work space. ! IRT = completion flag: ! IRT = 0 means no root was found. ! IRT = -1 means JOB = 1 and a root was found too near to T. ! IRT = 1 means a legitimate root was found (JOB = 2 or 3). ! On return, T0ST is the root location, and Y is the ! corresponding solution vector. ! T0ST = value of T at one endpoint of interval of interest. Only ! roots beyond T0ST in the direction of integration are sought. ! T0ST is input if JOB >= 2, and output in all cases. ! T0ST is updated by DVCHECK, whether a root is found or not. ! TLAST = last value of T returned by the solver (input only). ! TOUTC = copy of TOUT(input only). ! IRFND = input flag showing whether the last step taken had a root. ! IRFND = 1 if it did, = 0 if not. ! ITASKC = copy of ITASK (input only). ! NGC = copy of NG (input only). ! .. ! .. FIRST EXECUTABLE STATEMENT DVCHECK ! .. IRT = 0 JROOT(1:NGC) = 0 HMING = (ABS(TN)+ABS(H))*UROUND*HUN GOTO (10,30,80) JOB ! Evaluate g at initial T, and check for zero values. 10 CONTINUE T0ST = TN CALL G(NEQ,T0ST,Y,NGC,G0) NGE = 1 ZROOT = .FALSE. DO I = 1, NGC IF (ABS(G0(I))<=ZERO) ZROOT = .TRUE. END DO IF (.NOT.ZROOT) GOTO 20 ! g has a zero at T. Look at g at T + (small increment). ! TEMP1 = SIGN(HMING, H) ! T0ST = T0ST + TEMP1 ! TEMP2 = TEMP1 / H TEMP2 = MAX(HMING/ABS(H),TENTH) TEMP1 = TEMP2*H T0ST = T0ST + TEMP1 Y(1:N) = Y(1:N) + TEMP2*YH(1:N,2) CALL G(NEQ,T0ST,Y,NGC,G0) NGE = NGE + 1 ZROOT = .FALSE. DO I = 1, NGC IF (ABS(G0(I))<=ZERO) ZROOT = .TRUE. END DO IF (.NOT.ZROOT) GOTO 20 ! g has a zero at T and also close to T. Take error return. IRT = -1 RETURN 20 CONTINUE RETURN 30 CONTINUE IF (IRFND==0) GOTO 70 ! If a root was found on the previous step, evaluate G0 = g(T0ST). CALL DVINDY_CORE(T0ST,0,YH,NYH,Y,IFLAG) IF (BOUNDS) THEN DO I = 1, NDX Y(IDX(I)) = MAX(Y(IDX(I)),LB(I)) Y(IDX(I)) = MIN(Y(IDX(I)),UB(I)) END DO END IF CALL G(NEQ,T0ST,Y,NGC,G0) NGE = NGE + 1 ZROOT = .FALSE. DO I = 1, NGC IF (ABS(G0(I))<=ZERO) ZROOT = .TRUE. END DO IF (.NOT.ZROOT) GOTO 70 ! g has a zero at T0ST. Look at g at T + (small increment). TEMP1 = SIGN(HMING,H) T0ST = T0ST + TEMP1 IF ((T0ST-TN)*HZERO) GOTO 60 JROOT(I) = 1 ZROOT = .TRUE. 60 END DO IF (.NOT.ZROOT) GOTO 70 ! g has a zero at T0ST and also close to T0ST. Return root. IRT = 1 RETURN ! G0 has no zero components. Proceed to check relevant interval. 70 IF (ABS(TN-TLAST)<=ZERO) GOTO 130 80 CONTINUE ! Set T1 to TN or TOUTC, whichever comes first, and get g at T1. IF (ITASKC==2 .OR. ITASKC==3 .OR. ITASKC==5) GOTO 90 IF ((TOUTC-TN)*H>=ZERO) GOTO 90 T1 = TOUTC IF ((T1-T0ST)*H<=ZERO) GOTO 130 CALL DVINDY_CORE(T1,0,YH,NYH,Y,IFLAG) IF (BOUNDS) THEN DO I = 1, NDX Y(IDX(I)) = MAX(Y(IDX(I)),LB(I)) Y(IDX(I)) = MIN(Y(IDX(I)),UB(I)) END DO END IF GOTO 100 90 T1 = TN DO I = 1, N Y(I) = YH(I,1) END DO 100 CALL G(NEQ,T1,Y,NGC,G1) NGE = NGE + 1 ! Call DVROOTS to search for root in interval from T0ST to T1. JFLAG = 0 110 CONTINUE CALL DVROOTS(NGC,HMING,JFLAG,T0ST,T1,G0,G1,GX,X) IF (JFLAG>1) GOTO 120 CALL DVINDY_CORE(X,0,YH,NYH,Y,IFLAG) IF (BOUNDS) THEN DO I = 1, NDX Y(IDX(I)) = MAX(Y(IDX(I)),LB(I)) Y(IDX(I)) = MIN(Y(IDX(I)),UB(I)) END DO END IF CALL G(NEQ,X,Y,NGC,GX) NGE = NGE + 1 GOTO 110 120 T0ST = X CALL DCOPY_F90(NGC,GX,1,G0,1) IF (JFLAG==4) GOTO 130 ! Found a root. Interpolate to X and return. CALL DVINDY_CORE(X,0,YH,NYH,Y,IFLAG) IF (BOUNDS) THEN DO I = 1, NDX Y(IDX(I)) = MAX(Y(IDX(I)),LB(I)) Y(IDX(I)) = MIN(Y(IDX(I)),UB(I)) END DO END IF IRT = 1 RETURN 130 CONTINUE RETURN END SUBROUTINE DVCHECK !_______________________________________________________________________ SUBROUTINE DVROOTS(NG,HMIN,JFLAG,X0,X1,G0,G1,GX,X) ! .. ! Perform root finding for DVODE_F90. ! .. ! This is essentially subroutine DROOTS from LSODAR. ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. KPP_REAL, INTENT (IN) :: HMIN KPP_REAL, INTENT (INOUT) :: X, X0, X1 INTEGER, INTENT (INOUT) :: JFLAG INTEGER, INTENT (IN) :: NG ! .. ! .. Array Arguments .. KPP_REAL, INTENT (INOUT) :: G0(NG), G1(NG), GX(NG) ! .. ! .. Local Scalars .. KPP_REAL :: T2, TMAX INTEGER :: I, IMXOLD, NXLAST LOGICAL :: SGNCHG, XROOT, ZROOT ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, SIGN ! .. ! This subroutine finds the leftmost root of a set of arbitrary ! functions gi(x) (i = 1,...,NG) in an interval (X0,X1). Only roots ! of odd multiplicity (i.e. changes of sign of the gi) are found. ! Here the sign of X1 - X0 is arbitrary, but is constant for a given ! problem, and 'leftmost' means nearest to X0.The values of the ! vector-valued function g(x) = (gi, i=1...NG) are communicated ! through the call sequence of DVROOTS. The method used is the ! Illinois algorithm. ! Reference: ! Kathie L. Hiebert and Lawrence F. Shampine, Implicitly Defined ! Output Points for Solutions of ODEs, Sandia Report SAND/80-0180, ! February 1980. ! Description of parameters. ! NG = number of functions gi, or the number of components of ! the vector valued function g(x). Input only. ! HMIN = resolution parameter in X. Input only. When a root is ! found, it is located only to within an error of HMIN in X. ! Typically, HMIN should be set to something on the order of ! 100 * UROUND * MAX(ABS(X0),ABS(X1)), ! where UROUND is the unit roundoff of the machine. ! JFLAG = integer flag for input and output communication. ! On input, set JFLAG = 0 on the first call for the problem, ! and leave it unchanged until the problem is completed. ! (The problem is completed when JFLAG >= 2 on return.) ! On output, JFLAG has the following values and meanings: ! JFLAG = 1 means DVROOTS needs a value of g(x). Set GX = g(X) ! and call DVROOTS again. ! JFLAG = 2 means a root has been found. The root is ! at X, and GX contains g(X). (Actually, X is the ! rightmost approximation to the root on an interval ! (X0,X1) of size HMIN or less.) ! JFLAG = 3 means X = X1 is a root, with one or more of the gi ! being zero at X1 and no sign changes in (X0,X1). ! GX contains g(X) on output. ! JFLAG = 4 means no roots (of odd multiplicity) were ! found in (X0,X1) (no sign changes). ! X0,X1 = endpoints of the interval where roots are sought. ! X1 and X0 are input when JFLAG = 0 (first call), and ! must be left unchanged between calls until the problem is ! completed. X0 and X1 must be distinct, but X1 - X0 may be ! of either sign. However, the notion of 'left' and 'right' ! will be used to mean nearer to X0 or X1, respectively. ! When JFLAG >= 2 on return, X0 and X1 are output, and ! are the endpoints of the relevant interval. ! G0,G1 = arrays of length NG containing the vectors g(X0) and g(X1), ! respectively. When JFLAG = 0, G0 and G1 are input and ! none of the G0(i) should be zero. ! When JFLAG >= 2 on return, G0 and G1 are output. ! GX = array of length NG containing g(X). GX is input ! when JFLAG = 1, and output when JFLAG >= 2. ! X = independent variable value. Output only. ! When JFLAG = 1 on output, X is the point at which g(x) ! is to be evaluated and loaded into GX. ! When JFLAG = 2 or 3, X is the root. ! When JFLAG = 4, X is the right endpoint of the interval, X1. ! JROOT = integer array of length NG. Output only. ! When JFLAG = 2 or 3, JROOT indicates which components ! of g(x) have a root at X. JROOT(i) is 1 if the i-th ! component has a root, and JROOT(i) = 0 otherwise. ! .. ! .. FIRST EXECUTABLE STATEMENT DVROOTS ! .. IF (JFLAG==1) GOTO 90 ! JFLAG /= 1. Check for change in sign of g or zero at X1. IMAX = 0 TMAX = ZERO ZROOT = .FALSE. DO 20 I = 1, NG IF (ABS(G1(I))>ZERO) GOTO 10 ZROOT = .TRUE. GOTO 20 ! At this point, G0(i) has been checked and cannot be zero. 10 IF (ABS(SIGN(ONE,G0(I))-SIGN(ONE,G1(I)))<=ZERO) GOTO 20 T2 = ABS(G1(I)/(G1(I)-G0(I))) IF (T2<=TMAX) GOTO 20 TMAX = T2 IMAX = I 20 END DO IF (IMAX>0) GOTO 30 SGNCHG = .FALSE. GOTO 40 30 SGNCHG = .TRUE. 40 IF (.NOT.SGNCHG) GOTO 200 ! There is a sign change. Find the first root in the interval. XROOT = .FALSE. NXLAST = 0 LAST = 1 ! Repeat until the first root in the interval is found. Loop point. 50 CONTINUE IF (XROOT) GOTO 170 IF (NXLAST==LAST) GOTO 60 ALPHA = ONE GOTO 80 60 IF (LAST==0) GOTO 70 ALPHA = HALF*ALPHA GOTO 80 70 ALPHA = TWO*ALPHA 80 X2 = X1 - (X1-X0)*G1(IMAX)/(G1(IMAX)-ALPHA*G0(IMAX)) ! IF ((ABS(X2 - X0) < HMIN) .AND. (ABS(X1 - X0) > TEN * & ! HMIN)) X2 = X0 + PT1 * (X1 - X0) ! If X2 is too close to X0 or X1, adjust it inward, ! by a fractional distance that is between 0.1 and 0.5. IF (ABS(X2-X0)ZERO) GOTO 100 ZROOT = .TRUE. GOTO 110 ! Neither G0(i) nor GX(i) can be zero at this point. 100 IF (ABS(SIGN(ONE,G0(I))-SIGN(ONE,GX(I)))<=ZERO) GOTO 110 T2 = ABS(GX(I)/(GX(I)-G0(I))) IF (T2<=TMAX) GOTO 110 TMAX = T2 IMAX = I 110 END DO IF (IMAX>0) GOTO 120 SGNCHG = .FALSE. IMAX = IMXOLD GOTO 130 120 SGNCHG = .TRUE. 130 NXLAST = LAST IF (.NOT.SGNCHG) GOTO 140 ! Sign change between X0 and X2, so replace X1 with X2. X1 = X2 CALL DCOPY_F90(NG,GX,1,G1,1) LAST = 1 XROOT = .FALSE. GOTO 160 140 IF (.NOT.ZROOT) GOTO 150 ! Zero value at X2 and no sign change in (X0,X2), so X2 is a root. X1 = X2 CALL DCOPY_F90(NG,GX,1,G1,1) XROOT = .TRUE. GOTO 160 ! No sign change between X0 and X2. Replace X0 with X2. 150 CONTINUE CALL DCOPY_F90(NG,GX,1,G0,1) X0 = X2 LAST = 0 XROOT = .FALSE. 160 IF (ABS(X1-X0)<=HMIN) XROOT = .TRUE. GOTO 50 ! Return with X1 as the root. Set JROOT. Set X = X1 and GX = G1. 170 JFLAG = 2 X = X1 CALL DCOPY_F90(NG,G1,1,GX,1) DO 190 I = 1, NG JROOT(I) = 0 IF (ABS(G1(I))>ZERO) GOTO 180 JROOT(I) = 1 GOTO 190 180 IF (ABS(SIGN(ONE,G0(I))-SIGN(ONE,G1(I)))>ZERO) JROOT(I) = 1 190 END DO RETURN ! No sign change in the interval. Check for zero at right endpoint. 200 IF (.NOT.ZROOT) GOTO 210 ! Zero value at X1 and no sign change in (X0,X1). Return JFLAG = 3. X = X1 CALL DCOPY_F90(NG,G1,1,GX,1) DO I = 1, NG JROOT(I) = 0 IF (ABS(G1(I))<=ZERO) JROOT(I) = 1 END DO JFLAG = 3 RETURN ! No sign changes in this interval. Set X = X1, return JFLAG = 4. 210 CALL DCOPY_F90(NG,G1,1,GX,1) X = X1 JFLAG = 4 RETURN END SUBROUTINE DVROOTS !_______________________________________________________________________ SUBROUTINE DVNRDP(Y,IYDIM,NEQN,NQ) ! .. ! Retract the Nordsieck array (undo prediction). ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. INTEGER :: IYDIM, NEQN, NQ ! .. ! .. Array Arguments .. KPP_REAL :: Y(*) ! .. ! .. Local Scalars .. INTEGER :: I, J, J1, J2 ! .. ! .. FIRST EXECUTABLE STATEMENT DVNRDP ! .. DO J1 = 1, NQ DO J2 = J1, NQ J = (NQ+J1) - J2 DO I = 1, NEQN ! Original: ! Y(I,J) = Y(I,J) + Y(I,J+1) Y(I+(J-1)*IYDIM) = Y(I+(J-1)*IYDIM) + Y(I+J*IYDIM) END DO END DO END DO RETURN END SUBROUTINE DVNRDP !_______________________________________________________________________ SUBROUTINE DVNRDN(Y,IYDIM,NEQN,NQ) ! .. ! Apply the Nordsieck array (predict). ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. INTEGER :: IYDIM, NEQN, NQ ! .. ! .. Array Arguments .. KPP_REAL :: Y(*) ! .. ! .. Local Scalars .. INTEGER :: I, J, J1, J2 ! .. ! .. FIRST EXECUTABLE STATEMENT DVNRDN ! .. DO J1 = 1, NQ DO J2 = J1, NQ J = (NQ+J1) - J2 DO I = 1, NEQN ! Original: ! Y(I,J) = Y(I,J) - Y(I,J+1) Y(I+(J-1)*IYDIM) = Y(I+(J-1)*IYDIM) - Y(I+J*IYDIM) END DO END DO END DO RETURN END SUBROUTINE DVNRDN !_______________________________________________________________________ SUBROUTINE DVNRDS(Y,IYDIM,NEQN,L,RH) ! .. ! Scale the Nordsieck array. ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. KPP_REAL :: RH INTEGER :: IYDIM, L, NEQN ! .. ! .. Array Arguments .. KPP_REAL :: Y(*) ! .. ! .. Local Scalars .. KPP_REAL :: R1 INTEGER :: I, J ! .. ! .. FIRST EXECUTABLE STATEMENT DVNRDS ! .. R1 = ONE DO J = 2, L R1 = R1*RH DO I = 1, NEQN ! Original: ! Y(I,J) = Y(I,J)*R1 Y(I+(J-1)*IYDIM) = Y(I+(J-1)*IYDIM)*R1 END DO END DO RETURN END SUBROUTINE DVNRDS !_______________________________________________________________________ SUBROUTINE RELEASE_ARRAYS ! .. ! Deallocate any allocated arrays and determine how much storage was ! used (not called by DVODE_F90). ! .. IMPLICIT NONE ! .. ! .. Local Scalars .. INTEGER :: IER, II, IR CHARACTER (80) :: MSG ! .. ! .. Intrinsic Functions .. INTRINSIC ALLOCATED, SIZE ! .. !_______________________________________________________________________ ! *****MA48 build change point. Insert these statements. ! INTEGER INFO ! INTEGER ISIZE ! COMMON /MA48SIZE/ ISIZE !_______________________________________________________________________ ! .. ! .. FIRST EXECUTABLE STATEMENT RELEASE_ARRAYS ! .. IR = 0 IF (ALLOCATED(ACOR)) THEN IR = IR + SIZE(ACOR) DEALLOCATE (ACOR,STAT=IER) CALL CHECK_STAT(IER,880) END IF IF (ALLOCATED(CSCALEX)) THEN IR = IR + SIZE(CSCALEX) + SIZE(RSCALEX) + SIZE(WSCALEX) DEALLOCATE (CSCALEX,RSCALEX,WSCALEX,STAT=IER) CALL CHECK_STAT(IER,890) END IF IF (ALLOCATED(DTEMP)) THEN IR = IR + SIZE(DTEMP) DEALLOCATE (DTEMP,STAT=IER) CALL CHECK_STAT(IER,900) END IF IF (ALLOCATED(EWT)) THEN IR = IR + SIZE(EWT) DEALLOCATE (EWT,STAT=IER) CALL CHECK_STAT(IER,910) END IF IF (ALLOCATED(FACDS)) THEN IR = IR + SIZE(FACDS) DEALLOCATE (FACDS,STAT=IER) CALL CHECK_STAT(IER,920) END IF IF (ALLOCATED(FPTEMP)) THEN IR = IR + SIZE(FPTEMP) DEALLOCATE (FPTEMP,STAT=IER) CALL CHECK_STAT(IER,930) END IF IF (ALLOCATED(FTEMP)) THEN IR = IR + SIZE(FTEMP) DEALLOCATE (FTEMP,STAT=IER) CALL CHECK_STAT(IER,940) END IF IF (ALLOCATED(FTEMP1)) THEN IR = IR + SIZE(FTEMP1) DEALLOCATE (FTEMP1,STAT=IER) CALL CHECK_STAT(IER,950) END IF IF (ALLOCATED(G0)) THEN IR = IR + SIZE(G0) DEALLOCATE (G0,STAT=IER) CALL CHECK_STAT(IER,960) END IF IF (ALLOCATED(G1)) THEN IR = IR + SIZE(G1) DEALLOCATE (G1,STAT=IER) CALL CHECK_STAT(IER,970) END IF IF (ALLOCATED(GX)) THEN IR = IR + SIZE(GX) DEALLOCATE (GX,STAT=IER) CALL CHECK_STAT(IER,980) END IF IF (ALLOCATED(JMAT)) THEN IR = IR + SIZE(JMAT) DEALLOCATE (JMAT,STAT=IER) CALL CHECK_STAT(IER,990) END IF IF (ALLOCATED(LB)) THEN IR = IR + SIZE(LB) DEALLOCATE (LB,STAT=IER) CALL CHECK_STAT(IER,1000) END IF IF (ALLOCATED(UB)) THEN IR = IR + SIZE(UB) DEALLOCATE (UB,STAT=IER) CALL CHECK_STAT(IER,1000) END IF IF (ALLOCATED(PMAT)) THEN IR = IR + SIZE(PMAT) DEALLOCATE (PMAT,STAT=IER) CALL CHECK_STAT(IER,1010) END IF IF (ALLOCATED(RWORK)) THEN IR = IR + SIZE(RWORK) DEALLOCATE (RWORK,STAT=IER) CALL CHECK_STAT(IER,1020) END IF IF (ALLOCATED(SAVF)) THEN IR = IR + SIZE(SAVF) DEALLOCATE (SAVF,STAT=IER) CALL CHECK_STAT(IER,1030) END IF IF (ALLOCATED(YMAX)) THEN IR = IR + SIZE(YMAX) DEALLOCATE (YMAX,STAT=IER) CALL CHECK_STAT(IER,1040) END IF IF (ALLOCATED(WM)) THEN IR = IR + SIZE(WM) DEALLOCATE (WM,STAT=IER) CALL CHECK_STAT(IER,1050) END IF IF (ALLOCATED(YHNQP2)) THEN IR = IR + SIZE(YHNQP2) DEALLOCATE (YHNQP2,STAT=IER) CALL CHECK_STAT(IER,1060) END IF IF (ALLOCATED(YHTEMP)) THEN IR = IR + SIZE(YHTEMP) DEALLOCATE (YHTEMP,STAT=IER) CALL CHECK_STAT(IER,1070) END IF IF (ALLOCATED(YMAX)) THEN IR = IR + SIZE(YMAX) DEALLOCATE (YMAX,STAT=IER) CALL CHECK_STAT(IER,1080) END IF IF (ALLOCATED(YNNEG)) THEN IR = IR + SIZE(YNNEG) DEALLOCATE (YNNEG,STAT=IER) CALL CHECK_STAT(IER,1090) END IF IF (ALLOCATED(YSCALEDS)) THEN IR = IR + SIZE(YSCALEDS) DEALLOCATE (YSCALEDS,STAT=IER) CALL CHECK_STAT(IER,1100) END IF IF (ALLOCATED(YTEMP)) THEN IR = IR + SIZE(YTEMP) DEALLOCATE (YTEMP,STAT=IER) CALL CHECK_STAT(IER,1110) END IF IF (ALLOCATED(WKDS)) THEN IR = IR + SIZE(WKDS) DEALLOCATE (WKDS,STAT=IER) CALL CHECK_STAT(IER,1120) END IF II = 0 IF (ALLOCATED(BIGP)) THEN II = II + SIZE(BIGP) DEALLOCATE (BIGP,STAT=IER) CALL CHECK_STAT(IER,1130) END IF IF (ALLOCATED(BJGP)) THEN II = II + SIZE(BJGP) DEALLOCATE (BJGP,STAT=IER) CALL CHECK_STAT(IER,1140) END IF IF (ALLOCATED(IA)) THEN II = II + SIZE(IA) DEALLOCATE (IA,STAT=IER) CALL CHECK_STAT(IER,1150) END IF IF (ALLOCATED(IAB)) THEN II = II + SIZE(IAB) DEALLOCATE (IAB,STAT=IER) CALL CHECK_STAT(IER,1160) END IF IF (ALLOCATED(IAN)) THEN II = II + SIZE(IAN) DEALLOCATE (IAN,STAT=IER) CALL CHECK_STAT(IER,1170) END IF IF (ALLOCATED(ICN)) THEN II = II + SIZE(ICN) DEALLOCATE (ICN,STAT=IER) CALL CHECK_STAT(IER,1180) END IF IF (ALLOCATED(IDX)) THEN II = II + SIZE(IDX) DEALLOCATE (IDX,STAT=IER) CALL CHECK_STAT(IER,1190) END IF IF (ALLOCATED(IGP)) THEN II = II + SIZE(IGP) DEALLOCATE (IGP,STAT=IER) CALL CHECK_STAT(IER,1200) END IF IF (ALLOCATED(IKEEP28)) THEN II = II + SIZE(IKEEP28,1)*SIZE(IKEEP28,2) DEALLOCATE (IKEEP28,STAT=IER) CALL CHECK_STAT(IER,1210) END IF IF (ALLOCATED(INDCOLDS)) THEN II = II + SIZE(INDCOLDS) DEALLOCATE (INDCOLDS,STAT=IER) CALL CHECK_STAT(IER,1220) END IF IF (ALLOCATED(INDROWDS)) THEN II = II + SIZE(INDROWDS) DEALLOCATE (INDROWDS,STAT=IER) CALL CHECK_STAT(IER,1230) END IF IF (ALLOCATED(IOPTDS)) THEN II = II + SIZE(IOPTDS) DEALLOCATE (IOPTDS,STAT=IER) CALL CHECK_STAT(IER,1240) END IF IF (ALLOCATED(IPNTRDS)) THEN II = II + SIZE(IPNTRDS) DEALLOCATE (IPNTRDS,STAT=IER) CALL CHECK_STAT(IER,1250) END IF IF (ALLOCATED(IWADS)) THEN II = II + SIZE(IWADS) DEALLOCATE (IWADS,STAT=IER) CALL CHECK_STAT(IER,1260) END IF IF (ALLOCATED(IWKDS)) THEN II = II + SIZE(IWKDS) DEALLOCATE (IWKDS,STAT=IER) CALL CHECK_STAT(IER,1270) END IF IF (ALLOCATED(IWORK)) THEN II = II + SIZE(IWORK) DEALLOCATE (IWORK,STAT=IER) CALL CHECK_STAT(IER,1280) END IF IF (ALLOCATED(IW28)) THEN II = II + SIZE(IW28,1)*SIZE(IW28,2) DEALLOCATE (IW28,STAT=IER) CALL CHECK_STAT(IER,1290) END IF IF (ALLOCATED(JA)) THEN II = II + SIZE(JA) DEALLOCATE (JA,STAT=IER) CALL CHECK_STAT(IER,1300) END IF IF (ALLOCATED(JAB)) THEN II = II + SIZE(JAB) DEALLOCATE (JAB,STAT=IER) CALL CHECK_STAT(IER,1310) END IF IF (ALLOCATED(JAN)) THEN II = II + SIZE(JAN) DEALLOCATE (JAN,STAT=IER) CALL CHECK_STAT(IER,1320) END IF IF (ALLOCATED(JATEMP)) THEN II = II + SIZE(JATEMP) DEALLOCATE (JATEMP,STAT=IER) CALL CHECK_STAT(IER,1330) END IF IF (ALLOCATED(JGP)) THEN II = II + SIZE(JGP) DEALLOCATE (JGP,STAT=IER) CALL CHECK_STAT(IER,1340) END IF IF (ALLOCATED(JPNTRDS)) THEN II = II + SIZE(JPNTRDS) DEALLOCATE (JPNTRDS,STAT=IER) CALL CHECK_STAT(IER,1350) END IF IF (ALLOCATED(JROOT)) THEN II = II + SIZE(JROOT) DEALLOCATE (JROOT,STAT=IER) CALL CHECK_STAT(IER,1360) END IF IF (ALLOCATED(JVECT)) THEN II = II + SIZE(JVECT) DEALLOCATE (JVECT,STAT=IER) CALL CHECK_STAT(IER,1370) END IF IF (ALLOCATED(NGRPDS)) THEN II = II + SIZE(NGRPDS) DEALLOCATE (NGRPDS,STAT=IER) CALL CHECK_STAT(IER,1380) END IF IF (ALLOCATED(SUBDS)) THEN II = II + SIZE(SUBDS) DEALLOCATE (SUBDS,STAT=IER) CALL CHECK_STAT(IER,1390) END IF IF (ALLOCATED(SUPDS)) THEN II = II + SIZE(SUPDS) DEALLOCATE (SUPDS,STAT=IER) CALL CHECK_STAT(IER,1400) END IF !_______________________________________________________________________ ! *****MA48 build change point. Insert these statements. ! IF (MA48_WAS_USED) THEN ! CALL MA48_FINALIZE(FACTORS,CONTROL,INFO) ! IF (INFO /= 0) THEN ! MSG = 'The call to MA48_FINALIZE FAILED.' ! CALL XERRDV(MSG,1740,1,1,II,0,0,ZERO,ZERO) ! END IF ! MSG = 'Size of MA48 deallocated arrays (I1) = ' ! CALL XERRDV(MSG,1750,1,1,ISIZE,0,0,ZERO,ZERO) ! END IF !_______________________________________________________________________ ! Print the amount of storage used. MSG = 'I1 = Total length of REAL arrays used.' CALL XERRDV(MSG,1760,1,1,IR,0,0,ZERO,ZERO) MSG = 'I1 = Total length of INTEGER arrays used.' CALL XERRDV(MSG,1760,1,1,II,0,0,ZERO,ZERO) ! In case DVODE_F90 is subsequently called: OPTS_CALLED = .FALSE. RETURN END SUBROUTINE RELEASE_ARRAYS ! End of DVODE_F90 subroutines !_______________________________________________________________________ ! Beginning of LINPACK and BLAS subroutines SUBROUTINE DGEFA_F90(A,LDA,N,IPVT,INFO) ! .. ! Factor a matrix using Gaussian elimination. ! .. ! DGEFA_F90 factors a real(wp) matrix by Gaussian elimination. ! DGEFA_F90 is usually called by DGECO, but it can be called ! directly with a saving in time if RCOND is not needed. ! (Time for DGECO) = (1 + 9/N)*(Time for DGEFA_F90). ! On Entry ! A REAL(KIND=WP)(LDA, N) ! the matrix to be factored. ! LDA INTEGER ! the leading dimension of the array A. ! N INTEGER ! the order of the matrix A. ! On Return ! A an upper triangular matrix and the multipliers ! which were used to obtain it. ! The factorization can be written A = L*U where ! L is a product of permutation and unit lower ! triangular matrices and U is upper triangular. ! IPVT INTEGER(N) ! an integer vector of pivot indices. ! INFO INTEGER ! = 0 normal value. ! = K if U(K,K) == 0.0. This is not an error ! condition for this subroutine, but it does ! indicate that DGESL_F90 or DGEDI will divide ! by zero if called. Use RCOND in DGECO for a ! reliable indication of singularity. ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. INTEGER, INTENT (INOUT) :: INFO INTEGER, INTENT (IN) :: LDA, N ! .. ! .. Array Arguments .. KPP_REAL, INTENT (INOUT) :: A(LDA,*) INTEGER, INTENT (INOUT) :: IPVT(*) ! .. ! .. Local Scalars .. KPP_REAL :: T INTEGER :: J, K, KP1, L, NM1 ! .. ! .. Intrinsic Functions .. INTRINSIC ABS ! .. ! .. FIRST EXECUTABLE STATEMENT DGEFA_F90 ! .. INFO = 0 NM1 = N - 1 IF (NM1<1) GOTO 50 DO K = 1, NM1 KP1 = K + 1 ! Find L = pivot index. ! Original: ! L = IDAMAX_F90(N-K+1,A(K,K),1) + K - 1 L = IDAMAX_F90(N-K+1,A(K:N,K),1) + K - 1 IPVT(K) = L ! Zero pivot implies this column already triangularized. ! IF (A(L, K) == ZERO) GOTO 40 IF (ABS(A(L,K))<=ZERO) GOTO 30 ! Interchange if necessary. IF (L==K) GOTO 10 T = A(L,K) A(L,K) = A(K,K) A(K,K) = T 10 CONTINUE ! Compute multipliers. T = -ONE/A(K,K) ! Original: ! CALL DSCAL_F90(N-K,T,A(K+1,K),1) CALL DSCAL_F90(N-K,T,A(K+1:N,K),1) ! Row elimination with column indexing. DO J = KP1, N T = A(L,J) IF (L==K) GOTO 20 A(L,J) = A(K,J) A(K,J) = T 20 CONTINUE ! Original: ! CALL DAXPY_F90(N-K,T,A(K+1,K),1,A(K+1,J),1) CALL DAXPY_F90(N-K,T,A(K+1:N,K),1,A(K+1:N,J),1) END DO GOTO 40 30 CONTINUE INFO = K 40 CONTINUE END DO 50 CONTINUE IPVT(N) = N ! IF (A(N, N) == ZERO) INFO = N IF (ABS(A(N,N))<=ZERO) INFO = N RETURN END SUBROUTINE DGEFA_F90 !_______________________________________________________________________ SUBROUTINE DGESL_F90(A,LDA,N,IPVT,B,JOB) ! .. ! Solve the real system A*X=B or TRANS(A)*X=B using the factors ! computed by DGECO or DGEFA_F90. ! .. ! DGESL_F90 solves the real(wp) system ! A * X = B or TRANS(A) * X = B ! using the factors computed by DGECO or DGEFA_F90. ! On Entry ! A REAL(KIND=WP)(LDA, N) ! the output from DGECO or DGEFA_F90. ! LDA INTEGER ! the leading dimension of the array A. ! N INTEGER ! the order of the matrix A. ! IPVT INTEGER(N) ! the pivot vector from DGECO or DGEFA_F90. ! B REAL(KIND=WP)(N) ! the right hand side vector. ! JOB INTEGER ! = 0 to solve A*X = B, ! = nonzero to solve TRANS(A)*X = B where ! TRANS(A)is the transpose. ! On Return ! B the solution vector X. ! Error Condition ! A division by zero will occur if the input factor contains a ! zero on the diagonal. Technically this indicates singularity ! but it is often caused by improper arguments or improper ! setting of LDA. It will not occur if the subroutines are ! called correctly and if DGECO has set RCOND > 0.0 or ! DGEFA_F90 has set INFO == 0. ! To compute INVERSE(A) * C where C is a matrix ! with P columns ! CALL DGECO(A,LDA,N,IPVT,RCOND,Z) ! IF (RCOND is too small) GOTO ! DO J = 1, P ! CALL DGESL_F90(A,LDA,N,IPVT,C(1,J),0) ! END DO ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: JOB, LDA, N ! .. ! .. Array Arguments .. KPP_REAL, INTENT (INOUT) :: A(LDA,*), B(*) INTEGER, INTENT (INOUT) :: IPVT(*) ! .. ! .. Local Scalars .. KPP_REAL :: T INTEGER :: K, KB, L, NM1 ! .. ! .. FIRST EXECUTABLE STATEMENT DGESL_F90 ! .. NM1 = N - 1 IF (JOB/=0) GOTO 30 ! JOB = 0, solve A*X = B. ! First solve L*Y = B. IF (NM1<1) GOTO 20 DO K = 1, NM1 L = IPVT(K) T = B(L) IF (L==K) GOTO 10 B(L) = B(K) B(K) = T 10 CONTINUE ! Original: ! CALL DAXPY_F90(N-K,T,A(K+1,K),1,B(K+1),1) CALL DAXPY_F90(N-K,T,A(K+1:N,K),1,B(K+1:N),1) END DO 20 CONTINUE ! Now solve U*X = Y. DO KB = 1, N K = N + 1 - KB B(K) = B(K)/A(K,K) T = -B(K) ! Original: ! CALL DAXPY_F90(K-1,T,A(1,K),1,B(1),1) CALL DAXPY_F90(K-1,T,A(1:K-1,K),1,B(1:K-1),1) END DO GOTO 60 30 CONTINUE ! JOB /= 0, solve TRANS(A)*X = B. ! First solve TRANS(U)*Y = B. DO K = 1, N T = DDOT_F90(K-1,A(1,K),1,B(1),1) B(K) = (B(K)-T)/A(K,K) END DO ! Now solve TRANS(L)*X = Y. IF (NM1<1) GOTO 50 DO KB = 1, NM1 K = N - KB B(K) = B(K) + DDOT_F90(N-K,A(K+1,K),1,B(K+1),1) L = IPVT(K) IF (L==K) GOTO 40 T = B(L) B(L) = B(K) B(K) = T 40 CONTINUE END DO 50 CONTINUE 60 CONTINUE RETURN END SUBROUTINE DGESL_F90 !_______________________________________________________________________ SUBROUTINE DGBFA_F90(ABD,LDA,N,ML,MU,IPVT,INFO) ! .. ! Factor a banded matrix using Gaussian elimination. ! .. ! DGBFA_F90 factors a real(wp) band matrix by elimination. ! DGBFA_F90 is usually called by DGBCO, but it can be called ! directly with a saving in time if RCOND is not needed. ! On Entry ! ABD REAL(KIND=WP)(LDA, N) ! contains the matrix in band storage. The columns ! of the matrix are stored in the columns of ABD and ! the diagonals of the matrix are stored in rows ! ML+1 through 2*ML+MU+1 of ABD. ! See the comments below for details. ! LDA INTEGER ! the leading dimension of the array ABD. ! LDA must be >= 2*ML + MU + 1. ! N INTEGER ! the order of the original matrix. ! ML INTEGER ! number of diagonals below the main diagonal. ! 0 <= ML < N. ! MU INTEGER ! number of diagonals above the main diagonal. ! 0 <= MU < N. ! More efficient if ML <= MU. ! On Return ! ABD an upper triangular matrix in band storage and ! the multipliers which were used to obtain it. ! The factorization can be written A = L*U where ! L is a product of permutation and unit lower ! triangular matrices and U is upper triangular. ! IPVT INTEGER(N) ! an integer vector of pivot indices. ! INFO INTEGER ! = 0 normal value. ! = K if U(K,K) == 0.0. This is not an error ! condition for this subroutine, but it does ! indicate that DGBSL_F90 will divide by zero ! if called. Use RCOND in DGBCO for a reliable ! indication of singularity. ! Band Storage ! If A is a band matrix, the following program segment ! will set up the input. ! ML = (band width below the diagonal) ! MU = (band width above the diagonal) ! M = ML + MU + 1 ! DO J = 1, N ! I1 = MAX(1, J-MU) ! I2 = MIN(N, J+ML) ! DO 10 I = I1, I2 ! K = I - J + M ! ABD(K,J) = A(I,J) ! END DO ! END DO ! This uses rows ML+1 through 2*ML+MU+1 of ABD. ! In addition, the first ML rows in ABD are used for ! elements generated during the triangularization. ! The total number of rows needed in ABD is 2*ML+MU+1. ! The ML+MU by ML+MU upper left triangle and the ! ML by ML lower right triangle are not referenced. ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. INTEGER, INTENT (INOUT) :: INFO INTEGER, INTENT (IN) :: LDA, ML, MU, N ! .. ! .. Array Arguments .. KPP_REAL, INTENT (INOUT) :: ABD(LDA,*) INTEGER, INTENT (INOUT) :: IPVT(*) ! .. ! .. Local Scalars .. KPP_REAL :: T INTEGER :: I0, J, J0, J1, JU, JZ, K, KP1, L, LM, M, MM, NM1 ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN ! .. ! .. FIRST EXECUTABLE STATEMENT DGBFA_F90 ! .. M = ML + MU + 1 INFO = 0 ! Zero initial fill-in columns. J0 = MU + 2 J1 = MIN(N,M) - 1 IF (J1N) GOTO 20 IF (ML<1) GOTO 20 ABD(1:ML,JZ) = ZERO 20 CONTINUE ! Find L = pivot index. LM = MIN(ML,N-K) ! Original: ! L = IDAMAX_F90(LM+1,ABD(M,K),1) + M - 1 L = IDAMAX_F90(LM+1,ABD(M:M+LM,K),1) + M - 1 IPVT(K) = L + K - M ! Zero pivot implies this column already triangularized. ! IF (ABD(L, K) == ZERO) GOTO 100 IF (ABS(ABD(L,K))<=ZERO) GOTO 60 ! Interchange if necessary. IF (L==M) GOTO 30 T = ABD(L,K) ABD(L,K) = ABD(M,K) ABD(M,K) = T 30 CONTINUE ! Compute multipliers. T = -ONE/ABD(M,K) ! Original: ! CALL DSCAL_F90(LM,T,ABD(M+1,K),1) CALL DSCAL_F90(LM,T,ABD(M+1:M+LM,K),1) ! Row elimination with column indexing. JU = MIN(MAX(JU,MU+IPVT(K)),N) MM = M IF (JU 0.0 ! or DGBFA_F90 has set INFO == 0 . ! To compute INVERSE(A) * C where C is a matrix ! with P columns ! CALL DGBCO(ABD,LDA,N,ML,MU,IPVT,RCOND,Z) ! IF (RCOND is too small) GOTO ... ! DO J = 1, P ! CALL DGBSL_F90(ABD,LDA,N,ML,MU,IPVT,C(1,J),0) ! END DO ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: JOB, LDA, ML, MU, N ! .. ! .. Array Arguments .. KPP_REAL, INTENT (INOUT) :: ABD(LDA,*), B(*) INTEGER, INTENT (INOUT) :: IPVT(*) ! .. ! .. Local Scalars .. KPP_REAL :: T INTEGER :: K, KB, L, LA, LB, LM, M, NM1 ! .. ! .. Intrinsic Functions .. INTRINSIC MIN ! .. ! .. FIRST EXECUTABLE STATEMENT DGBSL_F90 ! .. M = MU + ML + 1 NM1 = N - 1 IF (JOB/=0) GOTO 30 ! JOB = 0, solve A*X = B. ! First solve L*Y = B. IF (ML==0) GOTO 20 IF (NM1<1) GOTO 20 DO K = 1, NM1 LM = MIN(ML,N-K) L = IPVT(K) T = B(L) IF (L==K) GOTO 10 B(L) = B(K) B(K) = T 10 CONTINUE ! Original: ! CALL DAXPY_F90(LM,T,ABD(M+1,K),1,B(K+1),1) CALL DAXPY_F90(LM,T,ABD(M+1:M+LM,K),1,B(K+1:K+LM),1) END DO 20 CONTINUE ! Now solve U*X = Y. DO KB = 1, N K = N + 1 - KB B(K) = B(K)/ABD(M,K) LM = MIN(K,M) - 1 LA = M - LM LB = K - LM T = -B(K) ! Original: ! CALL DAXPY_F90(LM,T,ABD(LA,K),1,B(LB),1) CALL DAXPY_F90(LM,T,ABD(LA:LA+LM-1,K),1,B(LB:LB+LM-1),1) END DO GOTO 60 30 CONTINUE ! JOB /= 0, solve TRANS(A)*X = B. ! First solve TRANS(U)*Y = B. DO K = 1, N LM = MIN(K,M) - 1 LA = M - LM LB = K - LM ! Original: ! T = DDOT_F90(LM,ABD(LA,K),1,B(LB),1) T = DDOT_F90(LM,ABD(LA:LA+LM-1,K),1,B(LB:LB+LM-1),1) B(K) = (B(K)-T)/ABD(M,K) END DO ! Now solve TRANS(L)*X = Y. IF (ML==0) GOTO 50 IF (NM1<1) GOTO 50 DO KB = 1, NM1 K = N - KB LM = MIN(ML,N-K) ! Original: ! B(K) = B(K) + DDOT_F90(LM,ABD(M+1,K),1,B(K+1),1) B(K) = B(K) + DDOT_F90(LM,ABD(M+1:M+LM,K),1,B(K+1:K+LM),1) L = IPVT(K) IF (L==K) GOTO 40 T = B(L) B(L) = B(K) B(K) = T 40 CONTINUE END DO 50 CONTINUE 60 CONTINUE RETURN END SUBROUTINE DGBSL_F90 !_______________________________________________________________________ SUBROUTINE DAXPY_F90(N,DA,DX,INCX,DY,INCY) ! .. ! Compute a constant times a vector plus a vector. ! .. ! Description of Parameters ! Input: ! N - number of elements in input vector(s) ! DA - real(wp) scalar multiplier ! DX - real(wp) vector with N elements ! INCX - storage spacing between elements of DX ! DY - real(wp) vector with N elements ! INCY - storage spacing between elements of DY ! Output: ! DY - real(wp) result (unchanged if N <= 0) ! Overwrite real(wp) DY with real(wp) DA*DX + DY. ! For I = 0 to N-1, replace DY(LY+I*INCY) with ! DA*DX(LX+I*INCX) + DY(LY+I*INCY), ! where LX = 1 if INCX >= 0, else LX = 1+(1-N)*INCX, ! and LY is defined in a similar way using INCY. ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. KPP_REAL, INTENT (IN) :: DA INTEGER, INTENT (IN) :: INCX, INCY, N ! .. ! .. Array Arguments .. KPP_REAL, INTENT (IN) :: DX(*) KPP_REAL, INTENT (INOUT) :: DY(*) ! .. ! .. Local Scalars .. INTEGER :: I, IX, IY, M, MP1, NS ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MOD ! .. ! .. FIRST EXECUTABLE STATEMENT DAXPY_F90 ! .. ! IF (N <= 0 .OR. DA == ZERO) RETURN IF (N<=0 .OR. ABS(DA)<=ZERO) RETURN ! IF (INCX==INCY) IF (INCX-1) 10, 20, 40 IF (INCX == INCY) THEN IF (INCX < 1) THEN GOTO 10 ELSEIF (INCX == 1) THEN GOTO 20 ELSE GOTO 40 END IF END IF ! Code for unequal or nonpositive increments. 10 IX = 1 IY = 1 IF (INCX<0) IX = (-N+1)*INCX + 1 IF (INCY<0) IY = (-N+1)*INCY + 1 DO I = 1, N DY(IY) = DY(IY) + DA*DX(IX) IX = IX + INCX IY = IY + INCY END DO RETURN ! Code for both increments equal to 1. ! Clean-up loop so remaining vector length is a multiple of 4. 20 M = MOD(N,4) IF (M==0) GOTO 30 DY(1:M) = DY(1:M) + DA*DX(1:M) IF (N<4) RETURN 30 MP1 = M + 1 DO I = MP1, N, 4 DY(I) = DY(I) + DA*DX(I) DY(I+1) = DY(I+1) + DA*DX(I+1) DY(I+2) = DY(I+2) + DA*DX(I+2) DY(I+3) = DY(I+3) + DA*DX(I+3) END DO RETURN ! Code for equal, positive, non-unit increments. 40 NS = N*INCX DO I = 1, NS, INCX DY(I) = DA*DX(I) + DY(I) END DO RETURN END SUBROUTINE DAXPY_F90 !_______________________________________________________________________ SUBROUTINE DCOPY_F90(N,DX,INCX,DY,INCY) ! .. ! Copy a vector to another vector. ! .. ! Description of Parameters ! Input: ! N - number of elements in input vector(s) ! DX - real(wp) vector with N elements ! INCX - storage spacing between elements of DX ! DY - real(wp) vector with N elements ! INCY - storage spacing between elements of DY ! Output: ! DY - copy of vector DX(unchanged if N <= 0) ! Copy real(wp) DX to real(wp) DY. ! For I = 0 to N-1, copy DX(LX+I*INCX) to DY(LY+I*INCY), ! where LX = 1 if INCX >= 0, else LX = 1+(1-N)*INCX, ! and LY is defined in a similar way using INCY. ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: INCX, INCY, N ! .. ! .. Array Arguments .. KPP_REAL, INTENT (IN) :: DX(*) KPP_REAL, INTENT (INOUT) :: DY(*) ! .. ! .. Local Scalars .. INTEGER :: I, IX, IY, M, MP1, NS ! .. ! .. Intrinsic Functions .. INTRINSIC MOD ! .. ! .. FIRST EXECUTABLE STATEMENT DCOPY_F90 ! .. IF (N<=0) RETURN ! IF (INCX==INCY) IF (INCX-1) 10, 20, 40 IF (INCX == INCY) THEN IF (INCX < 1) THEN GOTO 10 ELSEIF (INCX == 1) THEN GOTO 20 ELSE GOTO 40 END IF END IF ! Code for unequal or nonpositive increments. 10 IX = 1 IY = 1 IF (INCX<0) IX = (-N+1)*INCX + 1 IF (INCY<0) IY = (-N+1)*INCY + 1 DO I = 1, N DY(IY) = DX(IX) IX = IX + INCX IY = IY + INCY END DO RETURN ! Code for both increments equal to 1. ! Clean-up loop so remaining vector length is a multiple of 7. 20 M = MOD(N,7) IF (M==0) GOTO 30 DO I = 1, M DY(I) = DX(I) END DO IF (N<7) RETURN 30 MP1 = M + 1 DO I = MP1, N, 7 DY(I) = DX(I) DY(I+1) = DX(I+1) DY(I+2) = DX(I+2) DY(I+3) = DX(I+3) DY(I+4) = DX(I+4) DY(I+5) = DX(I+5) DY(I+6) = DX(I+6) END DO RETURN ! Code for equal, positive, non-unit increments. 40 NS = N*INCX DO I = 1, NS, INCX DY(I) = DX(I) END DO RETURN END SUBROUTINE DCOPY_F90 !_______________________________________________________________________ FUNCTION DDOT_F90(N,DX,INCX,DY,INCY) ! .. ! Compute the inner product of two vectors. ! .. ! Description of Parameters ! Input: ! N - number of elements in input vector(s) ! DX - real(wp) vector with N elements ! INCX - storage spacing between elements of DX ! DY - real(wp) vector with N elements ! INCY - storage spacing between elements of DY ! Output: ! DDOT_F90 - real(wp) dot product (zero if N <= 0) ! Returns the dot product of real(wp) DX and DY. ! DDOT_F90 = sum for I = 0 to N-1 of DX(LX+I*INCX) * DY(LY+I*INCY), ! where LX = 1 if INCX >= 0, else LX = 1+(1-N)*INCX, and LY is ! defined in a similar way using INCY. ! .. IMPLICIT NONE ! .. ! .. Function Return Value .. KPP_REAL :: DDOT_F90 ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: INCX, INCY, N ! .. ! .. Array Arguments .. KPP_REAL, INTENT (IN) :: DX(*), DY(*) ! .. ! .. Local Scalars .. INTEGER :: I, IX, IY, M, MP1, NS ! .. ! .. Intrinsic Functions .. INTRINSIC MOD ! .. ! .. FIRST EXECUTABLE STATEMENT DDOT_F90 ! .. DDOT_F90 = ZERO IF (N<=0) RETURN ! IF (INCX==INCY) IF (INCX-1) 10, 20, 40 IF (INCX == INCY) THEN IF (INCX < 1) THEN GOTO 10 ELSEIF (INCX == 1) THEN GOTO 20 ELSE GOTO 40 END IF END IF ! Code for unequal or nonpositive increments. 10 IX = 1 IY = 1 IF (INCX<0) IX = (-N+1)*INCX + 1 IF (INCY<0) IY = (-N+1)*INCY + 1 DO I = 1, N DDOT_F90 = DDOT_F90 + DX(IX)*DY(IY) IX = IX + INCX IY = IY + INCY END DO RETURN ! Code for both increments equal to 1. ! Clean-up loop so remaining vector length is a multiple of 5. 20 M = MOD(N,5) IF (M==0) GOTO 30 DO I = 1, M DDOT_F90 = DDOT_F90 + DX(I)*DY(I) END DO IF (N<5) RETURN 30 MP1 = M + 1 DO I = MP1, N, 5 DDOT_F90 = DDOT_F90 + DX(I)*DY(I) + DX(I+1)*DY(I+1) + & DX(I+2)*DY(I+2) + DX(I+3)*DY(I+3) + DX(I+4)*DY(I+4) END DO RETURN ! Code for equal, positive, non-unit increments. 40 NS = N*INCX DO I = 1, NS, INCX DDOT_F90 = DDOT_F90 + DX(I)*DY(I) END DO RETURN END FUNCTION DDOT_F90 !_______________________________________________________________________ SUBROUTINE DSCAL_F90(N,DA,DX,INCX) ! .. ! Multiply a vector by a constant. ! .. ! Description of Parameters ! Input: ! N - number of elements in input vector(s) ! DA - real(wp) scale factor ! DX - real(wp) vector with N elements ! INCX - storage spacing between elements of DX ! Output: ! DX - real(wp) result (unchanged if N <= 0) ! Replace real(wp) DX by real(wp) DA*DX. ! For I = 0 to N-1, replace DX(IX+I*INCX) with DA * DX(IX+I*INCX), ! where IX = 1 if INCX >= 0, else IX = 1+(1-N)*INCX. ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. KPP_REAL, INTENT (IN) :: DA INTEGER, INTENT (IN) :: INCX, N ! .. ! .. Array Arguments .. KPP_REAL, INTENT (INOUT) :: DX(*) ! .. ! .. Local Scalars .. INTEGER :: I, IX, M, MP1 ! .. ! .. Intrinsic Functions .. INTRINSIC MOD ! .. ! .. FIRST EXECUTABLE STATEMENT DSCAL_F90 ! .. IF (N<=0) RETURN IF (INCX==1) GOTO 10 ! Code for increment not equal to 1. IX = 1 IF (INCX<0) IX = (-N+1)*INCX + 1 DO I = 1, N DX(IX) = DA*DX(IX) IX = IX + INCX END DO RETURN ! Code for increment equal to 1. ! Clean-up loop so remaining vector length is a multiple of 5. 10 M = MOD(N,5) IF (M==0) GOTO 20 DX(1:M) = DA*DX(1:M) IF (N<5) RETURN 20 MP1 = M + 1 DO I = MP1, N, 5 DX(I) = DA*DX(I) DX(I+1) = DA*DX(I+1) DX(I+2) = DA*DX(I+2) DX(I+3) = DA*DX(I+3) DX(I+4) = DA*DX(I+4) END DO RETURN END SUBROUTINE DSCAL_F90 !_______________________________________________________________________ FUNCTION IDAMAX_F90(N,DX,INCX) ! .. ! Find the smallest index of that component of a vector ! having the maximum magnitude. ! .. ! Description of Parameters ! Input: ! N - number of elements in input vector(s) ! DX - real(wp) vector with N elements ! INCX - storage spacing between elements of DX ! Output: ! IDAMAX_F90 - smallest index (zero if N <= 0) ! Find smallest index of maximum magnitude of real(wp) DX. ! IDAMAX_F90 = first I, I = 1 to N, to maximize ! ABS(DX(IX+(I-1)*INCX)), where IX = 1 if INCX >= 0, ! else IX = 1+(1-N)*INCX. ! .. IMPLICIT NONE ! .. ! .. Function Return Value .. INTEGER :: IDAMAX_F90 ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: INCX, N ! .. ! .. Array Arguments .. KPP_REAL, INTENT (IN) :: DX(*) ! .. ! .. Local Scalars .. KPP_REAL :: DMAX, XMAG INTEGER :: I, IX ! .. ! .. Intrinsic Functions .. INTRINSIC ABS ! .. ! .. FIRST EXECUTABLE STATEMENT IDAMAX_F90 ! .. IDAMAX_F90 = 0 IF (N<=0) RETURN IDAMAX_F90 = 1 IF (N==1) RETURN IF (INCX==1) GOTO 10 ! Code for increments not equal to 1. IX = 1 IF (INCX<0) IX = (-N+1)*INCX + 1 DMAX = ABS(DX(IX)) IX = IX + INCX DO I = 2, N XMAG = ABS(DX(IX)) IF (XMAG>DMAX) THEN IDAMAX_F90 = I DMAX = XMAG END IF IX = IX + INCX END DO RETURN ! Code for increments equal to 1. 10 DMAX = ABS(DX(1)) DO I = 2, N XMAG = ABS(DX(I)) IF (XMAG>DMAX) THEN IDAMAX_F90 = I DMAX = XMAG END IF END DO RETURN END FUNCTION IDAMAX_F90 ! End of LINPACK and BLAS subroutines !_______________________________________________________________________ ! Beginning of MA28 subroutines ! THIS IS A FORTRAN 90 TRANSLATION OF HSL'S F77 MA28. IT IS INTENDED ! ONLY FOR USE IN CONJUNCTION WITH THE ODE SOLVER DVODE_F90 AND IS ! NOT FUNCTIONAL IN A STANDALONE MANNER. PLEASE NOTE THAT MA28 IS NOT ! PUBLIC DOMAIN SOFTWARE BUT HAS BEEN MADE AVAILABLE TO THE NUMERICAL ! ANALYSIS COMMUNITY BY HARWELL. FOR OTHER USE PLEASE CONTACT HARWELL ! AT HTTP://WWW.HSL-LIBRARY.COM OR CONTACT HSL@HYPROTECH.COM IF YOU ! WISH TO SOLVE GENERAL SPARSE LINEAR SYSTEMS. IF YOU FIND A BUG OR ! ENCOUNTER A PROBLEM WITH THE USE OF MA28 WITH DVODE.F90, PLEASE ! CONTACT ONE OF THE AUTHORS OF DVODE_F90: ! G.D. Byrne (gbyrne@wi.rr.com) ! S. Thompson, thompson@radford.edu ! NUMEROUS CHANGES WERE MADE IN CONNECTION WITH DVODE_F90 USAGE. THESE ! INCLUDE USING METCALF'S CONVERTER TO TRANSLATE THE ORIGINAL f77 CODE ! TO F90, MOVING INITIALIZATIONS TO THE DVODE_F90 PRIVATE SECTION, ! ELIMINATION OF HOLLERITHS IN FORMAT STATEMENTS, ELIMINATION OF ! BLOCKDATA, CHANGES IN ARITHMETICAL OPERATOR SYNTAX, AND CONVERSION ! TO UPPER CASE. THIS VERSION OF MA28 IS INTENDED ONLY FOR USE WITH ! DVODE_F90. PLEASE DO NOT MODIFY IT FOR ANY OTHER PURPOSE. IF YOU ! HAVE LICENSED ACCESS TO THE HSL LIBRARY, AN ALTERNATE VERSION OF ! DVODE_F90 BASED ON THE SUCCESSOR TO MA28, MA48, IS AVAILABLE FROM ! THE AUTHORS. PLEASE NOTE THAT THE ALTERNATE VERSION OF DVODE_F90 ! IS NOT SELF CONTAINED SINCE MA48 IS NOT DISTRIBUTED WITH DVODE_F90. !****************************************************************** ! *****MA28 COPYRIGHT NOTICE***** ! COPYRIGHT (C) 2001 COUNCIL FOR THE CENTRAL LABORATORY ! OF THE RESEARCH COUNCILS ! ALL RIGHTS RESERVED. ! NONE OF THE COMMENTS IN THIS COPYRIGHT NOTICE BETWEEN THE LINES ! OF ASTERISKS SHALL BE REMOVED OR ALTERED IN ANY WAY. ! THIS PACKAGE IS INTENDED FOR COMPILATION WITHOUT MODIFICATION, ! SO MOST OF THE EMBEDDED COMMENTS HAVE BEEN REMOVED. ! ALL USE IS SUBJECT TO LICENCE. IF YOU NEED FURTHER CLARIFICATION, ! PLEASE SEE HTTP://WWW.HSL-LIBRARY.COM OR CONTACT HSL@HYPROTECH.COM ! PLEASE NOTE THAT: ! 1. THE PACKAGES MAY ONLY BE USED FOR THE PURPOSES SPECIFIED IN THE ! LICENCE AGREEMENT AND MUST NOT BE COPIED BY THE LICENSEE FOR ! USE BY ANY OTHER PERSONS. USE OF THE PACKAGES IN ANY COMMERCIAL ! APPLICATION SHALL BE SUBJECT TO PRIOR WRITTEN AGREEMENT BETWEEN ! HYPROTECH UK LIMITED AND THE LICENSEE ON SUITABLE TERMS AND ! CONDITIONS, WHICH WILL INCLUDE FINANCIAL CONDITIONS. ! 2. ALL INFORMATION ON THE PACKAGE IS PROVIDED TO THE LICENSEE ON ! THE UNDERSTANDING THAT THE DETAILS THEREOF ARE CONFIDENTIAL. ! 3. ALL PUBLICATIONS ISSUED BY THE LICENSEE THAT INCLUDE RESULTS ! OBTAINED WITH THE HELP OF ONE OR MORE OF THE PACKAGES SHALL ! ACKNOWLEDGE THE USE OF THE PACKAGES. THE LICENSEE WILL NOTIFY ! HSL@HYPROTECH.COM OR HYPROTECH UK LIMITED OF ANY SUCH PUBLICATION. ! 4. THE PACKAGES MAY BE MODIFIED BY OR ON BEHALF OF THE LICENSEE ! FOR SUCH USE IN RESEARCH APPLICATIONS BUT AT NO TIME SHALL SUCH ! PACKAGES OR MODIFICATIONS THEREOF BECOME THE PROPERTY OF THE ! LICENSEE. THE LICENSEE SHALL MAKE AVAILABLE FREE OF CHARGE TO THE ! COPYRIGHT HOLDER FOR ANY PURPOSE ALL INFORMATION RELATING TO ! ANY MODIFICATION. ! 5. NEITHER COUNCIL FOR THE CENTRAL LABORATORY OF THE RESEARCH ! COUNCILS NOR HYPROTECH UK LIMITED SHALL BE LIABLE FOR ANY ! DIRECT OR CONSEQUENTIAL LOSS OR DAMAGE WHATSOEVER ARISING OUT OF ! THE USE OF PACKAGES BY THE LICENSEE. !****************************************************************** SUBROUTINE MA28AD(N,NZ,A,LICN,IRN,LIRN,ICN,U,IKEEP,IW,W,IFLAG) ! .. ! This subroutine performs the LU factorization of A. ! .. ! The parameters are as follows: ! N Order of matrix. Not altered by subroutine. ! NZ Number of non-zeros in input matrix. Not altered by subroutine. ! A Array of length LICN. Holds non-zeros of matrix ! on entry and non-zeros of factors on exit. Reordered by ! MA20AD and MC23AD and altered by MA30AD. ! LICN Length of arrays A and ICN. Not altered by subroutine. ! IRN Array of length LIRN. Holds row indices on input. ! Used as workspace by MA30AD to hold column orientation of ! matrix. ! LIRN Length of array IRN. Not altered by the subroutine. ! ICN Array of length LICN. Holds column indices on entry ! and column indices of decomposed matrix on exit. Reordered ! by MA20AD and MC23AD and altered by MA30AD. ! U Variable set by user to control bias towards numeric or ! sparsity pivoting. U = 1.0 gives partial pivoting ! while U = 0. does not check multipliers at all. Values of U ! greater than one are treated as one while negative values ! are treated as zero. Not altered by subroutine. ! IKEEP Array of length 5*N used as workspace by MA28AD. ! (See later comments.) It is not required to be set on entry ! and, on exit, it contains information about the decomposition. ! It should be preserved between this call and subsequent calls ! to MA28BD or MA30CD. ! IKEEP(I,1),I = 1,N holds the total length of the part of row ! I in the diagonal block. ! Row IKEEP(I,2),I = 1,N of the input matrix is the Ith row in ! pivot order. ! Column IKEEP(I,3),I = 1,N of the input matrix is the Ith ! Column in pivot order. ! IKEEP(I,4),I = 1,N holds the length of the part of row I in ! the L part of the LU decomposition. ! IKEEP(I,5),I = 1,N holds the length of the part of row I in ! the off-diagonal blocks. If there is only one diagonal block, ! IKEEP(1,5) will be set to -1. ! IW Array of length 8*N. If the option NSRCH <= N is used, then ! the length of array IW can be reduced to 7*N. ! W Array length N. Used by MC24AD both as workspace and to return ! growth estimate in W(1). The use of this array by MA28AD is ! thus optional depending on logical variable GROW. ! IFLAG Variable used as error flag by subroutine. A positive or ! zero value on exit indicates success. Possible negative ! values are -1 through -14. ! Private Variable Information. ! LP, MP Default value 6 (line printer). Unit number for error ! messages and duplicate element warning, respectively. ! NLP, MLP INTEGER. Unit number for messages from MA30AD and ! MC23AD. Set by MA28AD to the value of LP. ! LBLOCK Logical variable with default value .TRUE. If .TRUE., ! MC23AD is used to first permute the matrix to block lower ! triangular form. ! GROW Logical variable with default value .TRUE. If .TRUE., then ! an estimate of the increase in size of matrix elements during ! LU decomposition is given by MC24AD. ! EPS, RMIN, RESID. Variables not referenced by MA28AD. ! IRNCP, ICNCP INTEGER. Set to number of compresses on arrays IRN ! and ICN/A, respectively. ! MINIRN, MINICN INTEGER. Minimum length of arrays IRN and ICN/A, ! respectively, for success on future runs. ! IRANK INTEGER. Estimated rank of matrix. ! MIRNCP, MICNCP, MIRANK, MIRN, MICN INTEGER. Variables used to ! communicate between MA30FD and MA28FD values of ! abovenamed variables with somewhat similar names. ! ABORT1, ABORT2 LOGICAL. Variables with default value .TRUE. ! If .FALSE., then decomposition will be performed even ! if the matrix is structurally or numerically singular, ! respectively. ! ABORTA, ABORTB LOGICAL. Variables used to communicate values ! of ABORT1 and ABORT2 to MA30AD. ! ABORT Logical variable used to communicate value of ABORT1 ! to MC23AD. ! ABORT3 Logical variable. Not referenced by MA28AD. ! IDISP Array of length 2. Used to communicate information ! on decomposition between this call to MA28AD and subsequent ! calls to MA28BD and MA30CD. On exit, IDISP(1) and ! IDISP(2) indicate position in arrays A and ICN of the ! first and last elements in the LU decomposition of the ! diagonal blocks, respectively. ! NUMNZ Structural rank of matrix. ! NUM Number of diagonal blocks. ! LARGE Size of largest diagonal block. ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. KPP_REAL :: U INTEGER :: IFLAG, LICN, LIRN, N, NZ ! .. ! .. Array Arguments .. KPP_REAL :: A(LICN), W(N) INTEGER :: ICN(LICN), IKEEP(N,5), IRN(LIRN), IW(N,8) ! .. ! .. Local Scalars .. KPP_REAL :: UPRIV INTEGER :: I, I1, IEND, II, J, J1, J2, JAY, JJ, KNUM, LENGTH, MOVE, & NEWJ1, NEWPOS CHARACTER (80) :: MSG ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX ! .. ! .. FIRST EXECUTABLE STATEMENT MA28AD ! .. ! Check that this call was made from DVODE_F90 and, if not, stop. IF (.NOT.OK_TO_CALL_MA28) THEN MSG = 'This version of MA28 may be used only in conjunction with DVODE_F90.' CALL XERRDV(MSG,1770,1,0,0,0,0,ZERO,ZERO) MSG = 'Please refer to the following HSL copyright notice for MA28.' CALL XERRDV(MSG,1770,1,0,0,0,0,ZERO,ZERO) MSG = '****************************************************************** ' CALL XERRDV(MSG,1770,1,0,0,0,0,ZERO,ZERO) MSG = ' *****MA28 COPYRIGHT NOTICE***** ' CALL XERRDV(MSG,1770,1,0,0,0,0,ZERO,ZERO) MSG = ' COPYRIGHT (C) 2001 COUNCIL FOR THE CENTRAL LABORATORY ' CALL XERRDV(MSG,1770,1,0,0,0,0,ZERO,ZERO) MSG = ' OF THE RESEARCH COUNCILS ' CALL XERRDV(MSG,1770,1,0,0,0,0,ZERO,ZERO) MSG = ' ALL RIGHTS RESERVED. ' CALL XERRDV(MSG,1770,1,0,0,0,0,ZERO,ZERO) MSG = ' NONE OF THE COMMENTS IN THIS COPYRIGHT NOTICE BETWEEN THE LINES ' CALL XERRDV(MSG,1770,1,0,0,0,0,ZERO,ZERO) MSG = ' OF ASTERISKS SHALL BE REMOVED OR ALTERED IN ANY WAY. ' CALL XERRDV(MSG,1770,1,0,0,0,0,ZERO,ZERO) MSG = ' THIS PACKAGE IS INTENDED FOR COMPILATION WITHOUT MODIFICATION, ' CALL XERRDV(MSG,1770,1,0,0,0,0,ZERO,ZERO) MSG = ' SO MOST OF THE EMBEDDED COMMENTS HAVE BEEN REMOVED. ' CALL XERRDV(MSG,1770,1,0,0,0,0,ZERO,ZERO) MSG = ' ALL USE IS SUBJECT TO LICENCE. IF YOU NEED FURTHER CLARIFICATION, ' CALL XERRDV(MSG,1770,1,0,0,0,0,ZERO,ZERO) MSG = ' PLEASE SEE HTTP://WWW.HSL-LIBRARY.COM OR CONTACT HSL@HYPROTECH.COM ' CALL XERRDV(MSG,1770,1,0,0,0,0,ZERO,ZERO) MSG = ' PLEASE NOTE THAT: ' CALL XERRDV(MSG,1770,1,0,0,0,0,ZERO,ZERO) MSG = ' 1. THE PACKAGES MAY ONLY BE USED FOR THE PURPOSES SPECIFIED IN THE ' CALL XERRDV(MSG,1770,1,0,0,0,0,ZERO,ZERO) MSG = ' LICENCE AGREEMENT AND MUST NOT BE COPIED BY THE LICENSEE FOR ' CALL XERRDV(MSG,1770,1,0,0,0,0,ZERO,ZERO) MSG = ' USE BY ANY OTHER PERSONS. USE OF THE PACKAGES IN ANY COMMERCIAL ' CALL XERRDV(MSG,1770,1,0,0,0,0,ZERO,ZERO) MSG = ' APPLICATION SHALL BE SUBJECT TO PRIOR WRITTEN AGREEMENT BETWEEN ' CALL XERRDV(MSG,1770,1,0,0,0,0,ZERO,ZERO) MSG = ' HYPROTECH UK LIMITED AND THE LICENSEE ON SUITABLE TERMS AND ' CALL XERRDV(MSG,1770,1,0,0,0,0,ZERO,ZERO) MSG = ' CONDITIONS, WHICH WILL INCLUDE FINANCIAL CONDITIONS. ' CALL XERRDV(MSG,1770,1,0,0,0,0,ZERO,ZERO) MSG = ' 2. ALL INFORMATION ON THE PACKAGE IS PROVIDED TO THE LICENSEE ON ' CALL XERRDV(MSG,1770,1,0,0,0,0,ZERO,ZERO) MSG = ' THE UNDERSTANDING THAT THE DETAILS THEREOF ARE CONFIDENTIAL. ' CALL XERRDV(MSG,1770,1,0,0,0,0,ZERO,ZERO) MSG = ' 3. ALL PUBLICATIONS ISSUED BY THE LICENSEE THAT INCLUDE RESULTS ' CALL XERRDV(MSG,1770,1,0,0,0,0,ZERO,ZERO) MSG = ' OBTAINED WITH THE HELP OF ONE OR MORE OF THE PACKAGES SHALL ' CALL XERRDV(MSG,1770,1,0,0,0,0,ZERO,ZERO) MSG = ' ACKNOWLEDGE THE USE OF THE PACKAGES. THE LICENSEE WILL NOTIFY ' CALL XERRDV(MSG,1770,1,0,0,0,0,ZERO,ZERO) MSG = ' HSL@HYPROTECH.COM OR HYPROTECH UK LIMITED OF ANY SUCH PUBLICATION. ' CALL XERRDV(MSG,1770,1,0,0,0,0,ZERO,ZERO) MSG = ' 4. THE PACKAGES MAY BE MODIFIED BY OR ON BEHALF OF THE LICENSEE ' CALL XERRDV(MSG,1770,1,0,0,0,0,ZERO,ZERO) MSG = ' FOR SUCH USE IN RESEARCH APPLICATIONS BUT AT NO TIME SHALL SUCH ' CALL XERRDV(MSG,1770,1,0,0,0,0,ZERO,ZERO) MSG = ' PACKAGES OR MODIFICATIONS THEREOF BECOME THE PROPERTY OF THE ' CALL XERRDV(MSG,1770,1,0,0,0,0,ZERO,ZERO) MSG = ' LICENSEE. THE LICENSEE SHALL MAKE AVAILABLE FREE OF CHARGE TO THE ' CALL XERRDV(MSG,1770,1,0,0,0,0,ZERO,ZERO) MSG = ' COPYRIGHT HOLDER FOR ANY PURPOSE ALL INFORMATION RELATING TO ' CALL XERRDV(MSG,1770,1,0,0,0,0,ZERO,ZERO) MSG = ' ANY MODIFICATION. ' CALL XERRDV(MSG,1770,1,0,0,0,0,ZERO,ZERO) MSG = ' 5. NEITHER COUNCIL FOR THE CENTRAL LABORATORY OF THE RESEARCH ' CALL XERRDV(MSG,1770,1,0,0,0,0,ZERO,ZERO) MSG = ' COUNCILS NOR HYPROTECH UK LIMITED SHALL BE LIABLE FOR ANY ' CALL XERRDV(MSG,1770,1,0,0,0,0,ZERO,ZERO) MSG = ' DIRECT OR CONSEQUENTIAL LOSS OR DAMAGE WHATSOEVER ARISING OUT OF ' CALL XERRDV(MSG,1770,1,0,0,0,0,ZERO,ZERO) MSG = ' THE USE OF PACKAGES BY THE LICENSEE. ' CALL XERRDV(MSG,1770,1,0,0,0,0,ZERO,ZERO) MSG = '****************************************************************** ' CALL XERRDV(MSG,1770,2,0,0,0,0,ZERO,ZERO) END IF ! Some initialization and transfer of information between ! common blocks (see earlier comments). IFLAG = 0 ABORTA = ABORT1 ABORTB = ABORT2 ABORT = ABORT1 MLP = LP NLP = LP TOL1 = TOL LBIG1 = LBIG NSRCH1 = NSRCH ! UPRIV private copy of U is used in case it is outside ! range zero to one and is thus altered by MA30AD. UPRIV = U ! Simple data check on input variables and array dimensions. IF (N>0) GOTO 10 IFLAG = -8 IF (LP/=0) WRITE (LP,90000) N GOTO 170 10 IF (NZ>0) GOTO 20 IFLAG = -9 IF (LP/=0) WRITE (LP,90001) NZ GOTO 170 20 IF (LICN>=NZ) GOTO 30 IFLAG = -10 IF (LP/=0) WRITE (LP,90002) LICN GOTO 170 30 IF (LIRN>=NZ) GOTO 40 IFLAG = -11 IF (LP/=0) WRITE (LP,90003) LIRN GOTO 170 ! Data check to see if all indices lie between 1 and N. 40 DO 50 I = 1, NZ IF (IRN(I)>0 .AND. IRN(I)<=N .AND. ICN(I)>0 .AND. ICN(I)<=N) & GOTO 50 IF (IFLAG==0 .AND. LP/=0) WRITE (LP,90004) IFLAG = -12 IF (LP/=0) WRITE (LP,90005) I, A(I), IRN(I), ICN(I) 50 END DO IF (IFLAG<0) GOTO 180 ! Sort matrix into row order. CALL MC20AD(N,NZ,A,ICN,IW(1,1),IRN,0) ! Part of IKEEP is used here as a work-array. IKEEP(I,2) is ! the last row to have a non-zero in column I. IKEEP(I,3) ! is the off-set of column I from the start of the row. IKEEP(1:N,2) = 0 IKEEP(1:N,1) = 0 ! Check for duplicate elements summing any such entries ! and printing a warning message on unit MP. ! MOVE is equal to the number of duplicate elements found. MOVE = 0 ! The loop also calculates the largest element in the matrix, ! THEMAX. THEMAX = ZERO ! J1 is position in arrays of first non-zero in row. J1 = IW(1,1) DO 90 I = 1, N IEND = NZ + 1 IF (I/=N) IEND = IW(I+1,1) LENGTH = IEND - J1 IF (LENGTH==0) GOTO 90 J2 = IEND - 1 NEWJ1 = J1 - MOVE DO 80 JJ = J1, J2 J = ICN(JJ) THEMAX = MAX(THEMAX,ABS(A(JJ))) IF (IKEEP(J,2)==I) GOTO 70 ! First time column has ocurred in current row. IKEEP(J,2) = I IKEEP(J,3) = JJ - MOVE - NEWJ1 IF (MOVE==0) GOTO 80 ! Shift necessary because of previous duplicate element. NEWPOS = JJ - MOVE A(NEWPOS) = A(JJ) ICN(NEWPOS) = ICN(JJ) GOTO 80 ! Duplicate element. 70 MOVE = MOVE + 1 LENGTH = LENGTH - 1 JAY = IKEEP(J,3) + NEWJ1 IF (MP/=0) WRITE (MP,90006) I, J, A(JJ) A(JAY) = A(JAY) + A(JJ) THEMAX = MAX(THEMAX,ABS(A(JAY))) 80 END DO IKEEP(I,1) = LENGTH J1 = IEND 90 END DO ! KNUM is actual number of non-zeros in matrix with any multiple ! entries counted only once. KNUM = NZ - MOVE IF (.NOT.LBLOCK) GOTO 100 ! Perform block triangularisation. CALL MC23AD(N,ICN,A,LICN,IKEEP(1,1),IDISP,IKEEP(1,2),IKEEP(1,3), & IKEEP(1,5),IW(1,3),IW) IF (IDISP(1)>0) GOTO 130 IFLAG = -7 IF (IDISP(1)==-1) IFLAG = -1 IF (LP/=0) WRITE (LP,90007) GOTO 170 ! Block triangularization not requested. ! Move structure to end of data arrays in preparation for MA30AD. ! Also set LENOFF(1) to -1 and set permutation arrays. 100 DO I = 1, KNUM II = KNUM - I + 1 NEWPOS = LICN - I + 1 ICN(NEWPOS) = ICN(II) A(NEWPOS) = A(II) END DO IDISP(1) = 1 IDISP(2) = LICN - KNUM + 1 DO I = 1, N IKEEP(I,2) = I IKEEP(I,3) = I END DO IKEEP(1,5) = -1 130 IF (LBIG) BIG1 = THEMAX IF (NSRCH<=N) GOTO 140 ! Perform LU decomposition on diagonal blocks. CALL MA30AD(N,ICN,A,LICN,IKEEP(1,1),IKEEP(1,4),IDISP,IKEEP(1,2), & IKEEP(1,3),IRN,LIRN,IW(1,2),IW(1,3),IW(1,4),IW(1,5),IW(1,6),IW(1,7), & IW(1,8),IW,UPRIV,IFLAG) GOTO 150 ! This call if used if NSRCH has been set less than or equal to N. ! In this case, two integer work arrays of length can be saved. 140 CALL MA30AD(N,ICN,A,LICN,IKEEP(1,1),IKEEP(1,4),IDISP,IKEEP(1,2), & IKEEP(1,3),IRN,LIRN,IW(1,2),IW(1,3),IW(1,4),IW(1,5),IW,IW,IW(1,6),IW,& UPRIV,IFLAG) ! Transfer private variable information. !150 MINIRN = MAX(MIRN,NZ) ! MINICN = MAX(MICN,NZ) 150 MINIRN = MAX(MINIRN,NZ) MINICN = MAX(MINICN,NZ) ! IRNCP = MIRNCP ! ICNCP = MICNCP ! IRANK = MIRANK ! NDROP = NDROP1 IF (LBIG) BIG = BIG1 IF (IFLAG>=0) GOTO 160 IF (LP/=0) WRITE (LP,90008) GOTO 170 ! Reorder off-diagonal blocks according to pivot permutation. 160 I1 = IDISP(1) - 1 IF (I1/=0) CALL MC22AD(N,ICN,A,I1,IKEEP(1,5),IKEEP(1,2), & IKEEP(1,3),IW,IRN) I1 = IDISP(1) IEND = LICN - I1 + 1 ! Optionally calculate element growth estimate. IF (GROW) CALL MC24AD(N,ICN,A(I1),IEND,IKEEP,IKEEP(1,4),W) ! Increment growth estimate by original maximum element. IF (GROW) W(1) = W(1) + THEMAX IF (GROW .AND. N>1) W(2) = THEMAX ! Set flag if the only error is due to duplicate elements. IF (IFLAG>=0 .AND. MOVE/=0) IFLAG = -14 GOTO 180 170 IF (LP/=0) WRITE (LP,90009) 180 RETURN 90000 FORMAT (' N is out of range = ',I10) 90001 FORMAT (' NZ is non positive = ',I10) 90002 FORMAT (' LICN is too small = ',I10) 90003 FORMAT (' LIRN is too small = ',I10) 90004 FORMAT (' Error return from MA28AD because indices found out', & ' of range') 90005 FORMAT (1X,I6,'The element with value ',1P,D22.14, & ' is out of range with indices ',I8,',',I8) 90006 FORMAT (' Duplicate element in position ',I8,',',I8,' with value ',1P, & D22.14) 90007 FORMAT (' Error return from MC23AD') 90008 FORMAT (' Error return from MA30AD') 90009 FORMAT (' Error return from MA28AD') END SUBROUTINE MA28AD !_______________________________________________________________________ SUBROUTINE MA28BD(N,NZ,A,LICN,IVECT,JVECT,ICN,IKEEP,IW,W,IFLAG) ! .. ! This subroutine factorizes a matrix of a similar sparsity ! pattern to that previously factorized by MA28AD. ! .. ! The parameters are as follows: ! N Order of matrix. Not altered by subroutine. ! NZ Number of non-zeros in input matrix. Not ! altered by subroutine. ! A Array of length LICN. Holds non-zeros of ! matrix on entry and non-zeros of factors on exit. ! Reordered by MA28DD and altered by MA30BD. ! LICN Length of arrays A and ICN. Not altered by ! subroutine. ! IVECT, JVECT Arrays of length NZ. Hold row and column ! indices of non-zeros, respectively. Not altered ! by subroutine. ! ICN Array of length LICN. Same array as output ! from MA28AD. Unchanged by MA28BD. ! IKEEP Array of length 5*N. Same array as output ! from MA28AD. Unchanged by MA28BD. ! IW Array length 5*N. Used as workspace by ! MA28DD and MA30BD. ! W Array of length N. Used as workspace by ! MA28DD, MA30BD and (optionally) MC24AD. ! IFLAG Integer used as error flag, with positive ! or zero value indicating success. ! Private Variable Information. ! Unless otherwise stated private variables are as in MA28AD. ! Those variables referenced by MA28BD are mentioned below. ! LP, MP Integers used as in MA28AD as unit number for error ! and warning messages, respectively. ! NLP Integer variable used to give value of LP to MA30ED. ! EPS MA30BD will output a positive value ! for IFLAG if any modulus of the ratio of pivot element ! to the largest element in its row (U part only) is less ! than EPS (unless EPS is greater than 1.0 when no action ! takes place). ! RMIN Variable equal to the value of this minimum ratio in ! cases where EPS is less than or equal to 1.0. ! MEPS,MRMIN Variables used by the subroutine to communicate between ! MA28FD and MA30GD. ! IDISP Integer array of length 2. The same as that used by ! MA28AD. Unchanged by MA28BD. ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. INTEGER :: IFLAG, LICN, N, NZ ! .. ! .. Array Arguments .. KPP_REAL :: A(LICN), W(N) INTEGER :: ICN(LICN), IKEEP(N,5), IVECT(NZ), IW(N,5), JVECT(NZ) ! .. ! .. Local Scalars .. INTEGER :: I1, IDUP, IEND ! .. ! .. FIRST EXECUTABLE STATEMENT MA28BD ! .. ! Check to see if elements were dropped in previous MA28AD call. IF (NDROP==0) GOTO 10 IFLAG = -15 IF (LP/=0) WRITE (LP,90000) IFLAG, NDROP GOTO 70 10 IFLAG = 0 MEPS = EPS NLP = LP ! Simple data check on variables. IF (N>0) GOTO 20 IFLAG = -11 IF (LP/=0) WRITE (LP,90001) N GOTO 60 20 IF (NZ>0) GOTO 30 IFLAG = -10 IF (LP/=0) WRITE (LP,90002) NZ GOTO 60 30 IF (LICN>=NZ) GOTO 40 IFLAG = -9 IF (LP/=0) WRITE (LP,90003) LICN GOTO 60 40 CALL MA28DD(N,A,LICN,IVECT,JVECT,NZ,ICN,IKEEP(1,1),IKEEP(1,4), & IKEEP(1,5),IKEEP(1,2),IKEEP(1,3),IW(1,3),IW,W(1),IFLAG) ! THEMAX is largest element in matrix. THEMAX = W(1) IF (LBIG) BIG1 = THEMAX ! IDUP equals one if there were duplicate elements, zero otherwise. IDUP = 0 IF (IFLAG==(N+1)) IDUP = 1 IF (IFLAG<0) GOTO 60 ! Perform row Gauss elimination on the structure received from MA28DD. CALL MA30BD(N,ICN,A,LICN,IKEEP(1,1),IKEEP(1,4),IDISP,IKEEP(1,2), & IKEEP(1,3),W,IW,IFLAG) ! Transfer private variable information. IF (LBIG) BIG1 = BIG ! RMIN = MRMIN IF (IFLAG>=0) GOTO 50 IFLAG = -2 IF (LP/=0) WRITE (LP,90004) GOTO 60 ! Optionally calculate the growth parameter. 50 I1 = IDISP(1) IEND = LICN - I1 + 1 IF (GROW) CALL MC24AD(N,ICN,A(I1),IEND,IKEEP,IKEEP(1,4),W) ! Increment estimate by largest element in input matrix. IF (GROW) W(1) = W(1) + THEMAX IF (GROW .AND. N>1) W(2) = THEMAX ! Set flag if the only error is due to duplicate elements. IF (IDUP==1 .AND. IFLAG>=0) IFLAG = -14 GOTO 70 60 IF (LP/=0) WRITE (LP,90005) 70 RETURN 90000 FORMAT (' Error return from MA28BD with IFLAG = ',I4/I7, & ' Entries dropped from structure by MA28AD') 90001 FORMAT (' N is out of range = ',I10) 90002 FORMAT (' NZ is non positive = ',I10) 90003 FORMAT (' LICN is too small = ',I10) 90004 FORMAT (' Error return from MA30BD') 90005 FORMAT (' + Error return from MA28BD') END SUBROUTINE MA28BD !_______________________________________________________________________ SUBROUTINE MA28DD(N,A,LICN,IVECT,JVECT,NZ,ICN,LENR,LENRL,LENOFF, & IP,IQ,IW1,IW,W1,IFLAG) ! .. ! This subroutine need never be called by the user directly. It sorts ! the user's matrix into the structure of the decomposed form and checks ! for the presence of duplicate entries or non-zeros lying outside the ! sparsity pattern of the decomposition. It also calculates the largest ! element in the input matrix. ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. KPP_REAL :: W1 INTEGER :: IFLAG, LICN, N, NZ ! .. ! .. Array Arguments .. KPP_REAL :: A(LICN) INTEGER :: ICN(LICN), IP(N), IQ(N), IVECT(NZ), IW(N,2), IW1(N,3), & JVECT(NZ), LENOFF(N), LENR(N), LENRL(N) ! .. ! .. Local Scalars .. KPP_REAL :: AA INTEGER :: I, IBLOCK, IDISP2, IDUMMY, II, INEW, IOLD, J1, J2, JCOMP, & JDUMMY, JJ, JNEW, JOLD, MIDPT LOGICAL :: BLOCKL ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, IABS, MAX ! .. ! .. FIRST EXECUTABLE STATEMENT MA28DD ! .. BLOCKL = LENOFF(1) >= 0 ! IW1(I,3) is set to the block in which row I lies and the ! inverse permutations to IP and IQ are set in IW1(:,1) and ! IW1(:,2), respectively. ! Pointers to beginning of the part of row I in diagonal and ! off-diagonal blocks are set in IW(I,2) and IW(I,1), ! respectively. IBLOCK = 1 IW(1,1) = 1 IW(1,2) = IDISP(1) DO 10 I = 1, N IW1(I,3) = IBLOCK IF (IP(I)<0) IBLOCK = IBLOCK + 1 II = IABS(IP(I)+0) ! II = IABS(IP(I)) IW1(II,1) = I JJ = IQ(I) JJ = IABS(JJ) IW1(JJ,2) = I IF (I==1) GOTO 10 IF (BLOCKL) IW(I,1) = IW(I-1,1) + LENOFF(I-1) IW(I,2) = IW(I-1,2) + LENR(I-1) 10 END DO ! Place each non-zero in turn into its correct location in ! the A/ICN array. IDISP2 = IDISP(2) DO 170 I = 1, NZ ! Necessary to avoid reference to unassigned element of ICN. IF (I>IDISP2) GOTO 20 IF (ICN(I)<0) GOTO 170 20 IOLD = IVECT(I) JOLD = JVECT(I) AA = A(I) ! This is a dummy loop for following a chain of interchanges. ! It will be executed NZ TIMES in total. DO IDUMMY = 1, NZ ! Perform some validity checks on IOLD and JOLD. IF (IOLD<=N .AND. IOLD>0 .AND. JOLD<=N .AND. JOLD>0) GOTO 30 IF (LP/=0) WRITE (LP,90000) I, A(I), IOLD, JOLD IFLAG = -12 GOTO 180 30 INEW = IW1(IOLD,1) JNEW = IW1(JOLD,2) ! Are we in a valid block and is it diagonal or off-diagonal? ! IF (IW1(INEW,3)-IW1(JNEW,3)) 40, 60, 50 !40 IFLAG = -13 IF (IW1(INEW,3)-IW1(JNEW,3) == 0) GOTO 60 IF (IW1(INEW,3)-IW1(JNEW,3) > 0) GOTO 50 IFLAG = -13 IF (LP/=0) WRITE (LP,90001) IOLD, JOLD GOTO 180 50 J1 = IW(INEW,1) J2 = J1 + LENOFF(INEW) - 1 GOTO 110 ! Element is in diagonal block. 60 J1 = IW(INEW,2) IF (INEW>JNEW) GOTO 70 J2 = J1 + LENR(INEW) - 1 J1 = J1 + LENRL(INEW) GOTO 110 70 J2 = J1 + LENRL(INEW) ! Binary search of ordered list. Element in L part of row. DO 100 JDUMMY = 1, N MIDPT = (J1+J2)/2 JCOMP = IABS(ICN(MIDPT)+0) ! JCOMP = IABS(ICN(MIDPT)) ! IF (JNEW-JCOMP) 80, 130, 90 !80 J2 = MIDPT IF (JNEW-JCOMP == 0) GOTO 130 IF (JNEW-JCOMP > 0) GOTO 90 J2 = MIDPT GOTO 100 90 J1 = MIDPT 100 END DO IFLAG = -13 IF (LP/=0) WRITE (LP,90002) IOLD, JOLD GOTO 180 ! Linear search. Element in L part of row or off-diagonal blocks. 110 DO MIDPT = J1, J2 IF (IABS(ICN(MIDPT)+0)==JNEW) GOTO 130 ! IF (IABS(ICN(MIDPT))==JNEW) GOTO 130 END DO IFLAG = -13 IF (LP/=0) WRITE (LP,90002) IOLD, JOLD GOTO 180 ! Equivalent element of ICN is in position MIDPT. 130 IF (ICN(MIDPT)<0) GOTO 160 IF (MIDPT>NZ .OR. MIDPT<=I) GOTO 150 W1 = A(MIDPT) A(MIDPT) = AA AA = W1 IOLD = IVECT(MIDPT) JOLD = JVECT(MIDPT) ICN(MIDPT) = -ICN(MIDPT) END DO 150 A(MIDPT) = AA ICN(MIDPT) = -ICN(MIDPT) GOTO 170 160 A(MIDPT) = A(MIDPT) + AA ! Set flag for duplicate elements. iflag = n + 1 170 END DO ! Reset ICN array and zero elements in LU but not in A. ! Also calculate the maximum element of A. 180 W1 = ZERO DO 200 I = 1, IDISP2 IF (ICN(I)<0) GOTO 190 A(I) = ZERO GOTO 200 190 ICN(I) = -ICN(I) W1 = MAX(W1,ABS(A(I))) 200 END DO RETURN 90000 FORMAT (' Element ',I6,' with value ',D22.14,' has indices ',I8, & ','/I8,' indices out of range') 90001 FORMAT (' Non-zero ',I7,',',I6,' in zero off-diagonal',' block') 90002 FORMAT (' Element ',I6,',',I6,' was not in LU pattern') END SUBROUTINE MA28DD !_______________________________________________________________________ SUBROUTINE MA28CD(N,A,LICN,ICN,IKEEP,RHS,W,MTYPE) ! .. ! This subroutine uses the factors from MA28AD or MA28BD to solve a ! system of equations without iterative refinement. ! .. ! The parameters are: ! N Order of matrix. Not altered by subroutine. ! A array of length LICN. the same array as ! was used in the most recent call to MA28AD or MA28BD. ! LICN Length of arrays A and ICN. Not altered by subroutine. ! ICN Array of length LICN. Same array as output from ! MA28AD. Unchanged by MA30CD. ! IKEEP Array of length 5*N. Same array as output from ! MA28AD. Unchanged by MA30CD. ! RHS Array of length N. On entry, it holds the ! right hand side, on exit, the solution vector. ! W Array of length N. Used as workspace by MA30CD. ! MTYPE Integer used to tell MA30CD to solve the direct ! equation (MTYPE = 1) or its transpose (MTYPE /= 1). ! Private Variable Information. ! Unless otherwise stated private variables are as in MA28AD. ! Those variables referenced by MA30CD are mentioned below. ! RESID Variable which returns maximum residual of ! equations where pivot was zero. ! MRESID Variable used by MA30CD to communicate between ! MA28FD and MA30HD. ! IDISP Integer array of length 2. The same as that used ! by MA28AD. Unchanged by MA28BD. ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. INTEGER :: LICN, MTYPE, N ! .. ! .. Array Arguments .. KPP_REAL :: A(LICN), RHS(N), W(N) INTEGER :: ICN(LICN), IKEEP(N,5) ! .. ! .. FIRST EXECUTABLE STATEMENT MA28CD ! .. ! This call performs the solution of the set of equations. CALL MA30CD(N,ICN,A,LICN,IKEEP(1,1),IKEEP(1,4),IKEEP(1,5),IDISP, & IKEEP(1,2),IKEEP(1,3),RHS,W,MTYPE) ! Transfer private variable information. RESID = MRESID RETURN END SUBROUTINE MA28CD !_______________________________________________________________________ SUBROUTINE MA28ID(N,NZ,AORG,IRNORG,ICNORG,LICN,A,ICN,IKEEP,RHS, & X,R,W,MTYPE,PREC,IFLAG) ! .. ! This subroutine uses the factors from an earlier call to MA28AD or ! MA28BD to solve the system of equations with iterative refinement. ! .. ! The parameters are: ! N Order of the matrix. Not altered by the subroutine. ! NZ Number of entries in the original matrix. Not altered by ! the subroutine. ! For this entry the original matrix must have been saved in ! AORG, IRNORG, ICNORG where entry AORG(K) is in row IRNORG(K) ! and column ICNORG(K),K = 1,...,NZ. Information about the ! factors of A is communicated to this subroutine via the ! parameters LICN, A, ICN and IKEEP where: ! AORG Array of length NZ. Not altered by MA28ID. ! IRNORG Array of length NZ. Not altered by MA28ID. ! ICNORG Array of length NZ. Not altered by MA28ID. ! LICN Length of arrays A and ICN. Not altered by the subroutine. ! A Array of length LICN. It must be unchanged since the ! last call to MA28AD or MA28BD. Not altered by the ! subroutine. ! ICN, IKEEP are the arrays (of lengths LICN and 5*N, respectively) ! of the same names as in the previous all to MA28AD. They ! should be unchanged since this earlier call and they are ! not altered by MA28ID. ! The other parameters are as follows: ! RHS Array of length N. The user must set RHS(I) to contain ! the value of the Ith component of the right hand side. ! Not altered by MA28ID. ! X Array of length N. If an initial guess of the solution ! is given (ISTART equal to 1), then the user must set X(I) ! to contain the value of the Ith component of the estimated ! solution. On exit, X(I) contains the Ith component of the ! solution vector. ! R Array of length N. It need not be set on entry. On exit, ! R(I) contains the Ith component of an estimate of the error ! if MAXIT is greater than 0. ! W Array of length N. Used as workspace by MA28ID. ! MTYPE Must be set to determine whether MA28ID will solve A*X = RHS ! (MTYPE = 1) or AT*X = RHS (MTYPE /= 1). Not altered by MA28ID. ! PREC Should be set by the user to the relative accuracy required. ! The iterative refinement will terminate if the magnitude of ! the largest component of the estimated error relative to the ! largest component in the solution is less than PREC. ! Not altered by MA28ID. ! IFLAG Diagnostic flag which will be set to zero on successful ! exit from MA28ID. Otherwise it will have a non-zero value. ! The non-zero value IFLAG can have on exit from MA28ID are ! -16 indicating that more than MAXIT iteartions are required. ! -17 indicating that more convergence was too slow. ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. KPP_REAL :: PREC INTEGER :: IFLAG, LICN, MTYPE, N, NZ ! .. ! .. Array Arguments .. KPP_REAL :: A(LICN), AORG(NZ), R(N), RHS(N), W(N), X(N) INTEGER :: ICN(LICN), ICNORG(NZ), IKEEP(N,5), IRNORG(NZ) ! .. ! .. Local Scalars .. KPP_REAL :: CONVER, D, DD INTEGER :: I, ITERAT, NCOL, NROW ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX ! .. ! .. FIRST EXECUTABLE STATEMENT MA28ID ! .. ! Initialization of NOITER, ERRMAX, and IFLAG. NOITER = 0 ERRMAX = ZERO IFLAG = 0 ! Jump if a starting vector has been supplied by the user. IF (ISTART==1) GOTO 20 ! Make a copy of the right-hand side vector. X(1:N) = RHS(1:N) ! Find the first solution. CALL MA28CD(N,A,LICN,ICN,IKEEP,X,W,MTYPE) ! Stop the computations if MAXIT = 0. 20 IF (MAXIT==0) GOTO 160 ! Calculate the max-norm of the first solution. DD = 0.0 DO I = 1, N DD = MAX(DD,ABS(X(I))) END DO DXMAX = DD ! Begin the iterative process. DO 120 ITERAT = 1, MAXIT D = DD ! Calculate the residual vector. R(1:N) = RHS(1:N) IF (MTYPE==1) GOTO 60 DO I = 1, NZ NROW = IRNORG(I) NCOL = ICNORG(I) R(NCOL) = R(NCOL) - AORG(I)*X(NROW) END DO GOTO 80 ! MTYPE = 1. 60 DO I = 1, NZ NROW = IRNORG(I) NCOL = ICNORG(I) R(NROW) = R(NROW) - AORG(I)*X(NCOL) END DO 80 DRES = 0.0 ! Find the max-norm of the residual vector. DO I = 1, N DRES = MAX(DRES,ABS(R(I))) END DO ! Stop the calculations if the max-norm of ! the residual vector is zero. ! IF (DRES == 0.0) GOTO 150 IF (ABS(DRES)<=ZERO) GOTO 150 ! Calculate the correction vector. NOITER = NOITER + 1 CALL MA28CD(N,A,LICN,ICN,IKEEP,R,W,MTYPE) ! Find the max-norm of the correction vector. DD = 0.0 DO I = 1, N DD = MAX(DD,ABS(R(I))) END DO ! Check the convergence. IF (DD>D*CGCE .AND. ITERAT>=2) GOTO 130 IF (ABS((DXMAX*TEN+DD)-(DXMAX*TEN))<=ZERO) GOTO 140 ! Attempt to improve the solution. DXMAX = 0.0 DO I = 1, N X(I) = X(I) + R(I) DXMAX = MAX(DXMAX,ABS(X(I))) END DO ! Check the stopping criterion. IF (DD= 0 or IFLAG = -14) give the minimum size of IRN ! and A/ICN, respectively which would enable a successful run on ! an identical matrix. On an exit with IFLAG equal to -5, MINICN ! gives the minimum value of ICN for success on subsequent runs on ! an identical matrix. In the event of failure with IFLAG = -6,-4, ! -3,-2, OR -1, then MINICN and MINIRN give the minimum value of ! LICN and LIRN, respectively which would be required for a ! successful decomposition up to the point at which the failure ! occurred. ! IRANK Integer variable which gives an upper bound on the rank of ! the matrix. ! ABORT1 is a logical variable with default value .TRUE. If ABORT1 is ! set to .FALSE., then MA28AD will decompose structurally singular ! matrices (including rectangular ones). ! ABORT2 is a logical variable with default value .TRUE. If ABORT2 is ! set to .FALSE., then MA28AD will decompose numerically singular ! matrices. ! IDISP is an integer array of length 2. On output from MA28AD, The ! indices of the diagonal blocks of the factors lie in positions ! IDISP(1) to IDISP(2) of A/ICN. This array must be preserved ! between a call to MA28AD and subsequent calls to MA28BD, ! MA30CD or MA28ID. ! TOL If set to a positive value, then any non-zero whose modulus is ! less than TOL will be dropped from the factorization. The ! factorization will then require less storage but will be ! inaccurate. After a run of MA28AD with TOL positive it is not ! possible to use MA28BD and the user is recommended to use ! MA28ID to obtain the solution. The default value for TOL is 0.0. ! THEMAX On exit from MA28AD, THEMAX will hold the largest entry of ! the original matrix. ! BIG If LBIG has been set to .TRUE., BIG will hold the largest entry ! encountered during the factorization by MA28AD or MA28BD. ! DXMAX On exit from MA28ID, DXMAX will be set to the largest component ! of the solution. ! ERRMAX If MAXIT is positive, ERRMAX will be set to the largest ! component in the estimate of the error. ! DRES On exit from MA28ID, if MAXIT is positive, DRES will be set to ! the largest component of the residual. ! CGCE Used by MA28ID to check the convergence rate. If the ratio of ! successive corrections is not less than CGCE, then we terminate ! since the convergence rate is adjudged too slow. ! NDROP If TOL has been set positive on exit from MA28AD, NDROP will ! hold the number of entries dropped from the data structure. ! MAXIT Maximum number of iterations performed by MA28ID. Default = 16. ! NOITER Set by MA28ID to the number of iterative refinement iterations ! actually used. ! NSRCH If NSRCH is set to a value less than N, then a different pivot ! option will be employed by MA28AD. This may result in different ! fill-in and execution time for MA28AD. If NSRCH is less than or ! equal to N, the workspace array IW can be reduced in length. The ! default value for NSRCH is 32768. ! ISTART If ISTART is set to a value other than zero, then the user ! must supply an estimate of the solution to MA28ID. The default ! value for istart is zero. ! LBIG If LBIG is set to .TRUE., the value of the largest element ! encountered in the factorization by MA28AD or MA28BD is returned ! in BIG. Setting LBIG to .TRUE. will increase the time for MA28AD ! marginally and that for MA28BD by about 20%. The default value ! for LBIG is .FALSE. !_______________________________________________________________________ SUBROUTINE MA30AD(NN,ICN,A,LICN,LENR,LENRL,IDISP,IP,IQ,IRN,LIRN, & LENC,IFIRST,LASTR,NEXTR,LASTC,NEXTC,IPTR,IPC,U,IFLAG) ! .. ! If the user requires a more convenient data interface then the ! MA28 package should be used. The MA28 subroutines call the MA30 ! subroutines after checking the user's input data and optionally ! using MC23AD to permute the matrix to block triangular form. ! This package of subroutines (MA30AD, MA30BD, MA30CD, and MA30DD) ! performs operations pertinent to the solution of a general ! sparse N by N system of linear equations (i.e., solve ! AX = B). Structually singular matrices are permitted including ! those with row or columns consisting entirely of zeros (i.e., ! including rectangular matrices). It is assumed that the ! non-zeros of the matrix A do not differ widely in size. If ! necessary a prior call of the scaling subroutine MA19AD may be ! made. ! A discussion of the design of these subroutines is given by Duff ! and Reid (ACM TRANS MATH SOFTWARE 5 PP 18-35, 1979(CSS 48)) while ! fuller details of the implementation are given in duff (HARWELL ! REPORT AERE-R 8730, 1977). The additional pivoting option in ! ma30ad and the use of drop tolerances (see private variables for ! MA30ID) were added to the package after joint work with Reid, ! Schaumburg, Wasniewski and Zlatev (Duff, Reid, Schaumburg, ! Wasniewski and Zlatev, HARWELL REPORT CSS 135, 1983). ! MA30AD performs the LU decomposition of the diagonal blocks of ! the permutation PAQ of a sparse matrix A, where input permutations ! P1 and Q1 are used to define the diagonal blocks. There may be ! non-zeros in the off-diagonal blocks but they are unaffected by ! MA30AD. P and P1 differ only within blocks as do Q and Q1. The ! permutations P1 and Q1 may be found by calling MC23AD or the ! matrix may be treated as a single block by using P1 = Q1 = I. The ! matrix non-zeros should be held compactly by rows, although it ! should be noted that the user can supply the matrix by columns ! to get the LU decomposition of A transpose. ! This description should also be consulted for further information ! on most of the parameters of MA30BD and MA30CD. ! The parameters are: ! N is an integer variable which must be set by the user to the order ! of the matrix. It is not altered by MA30AD. ! ICN is an integer array of length LICN. Positions IDISP(2) to ! LICN must be set by the user to contain the column indices of ! the non-zeros in the diagonal blocks of P1*A*Q1. Those belonging ! to a single row must be contiguous but the ordering of column ! indices with each row is unimportant. The non-zeros of row I ! precede those of row I+1,I = 1,...,N-1 and no wasted space is ! allowed between the rows. On output the column indices of the ! LU decomposition of PAQ are held in positions IDISP(1) to ! IDISP(2), the rows are in pivotal order, and the column indices ! of the L Part of each row are in pivotal order and precede those ! of U. Again there is no wasted space either within a row or ! between the rows. ICN(1) to ICN(IDISP(1)-1), are neither ! required nor altered. If MC23AD has been called, these will hold ! information about the off-diagonal blocks. ! A Array of length LICN whose entries IDISP(2) to LICN must be set ! by the user to the values of the non-zero entries of the matrix ! in the order indicated by ICN. On output A will hold the LU ! factors of the matrix where again the position in the matrix ! is determined by the corresponding values in ICN. ! A(1) to A(IDISP(1)-1) are neither required nor altered. ! LICN is an integer variable which must be set by the user to the ! length of arrays ICN and A. It must be big enough for A and ICN ! to hold all the non-zeros of L and U and leave some "elbow ! room". It is possible to calculate a minimum value for LICN by ! a preliminary run of MA30AD. The adequacy of the elbow room ! can be judged by the size of the private variable ICNCP. ! It is not altered by MA30AD. ! LENR is an integer array of length N. On input, LENR(I) should ! equal the number of non-zeros in row I,I = 1,...,N of the ! diagonal blocks of P1*A*Q1. On output, LENR(I) will equal the ! total number of non-zeros in row I of L and row I of U. ! LENRL is an integer array of length N. On output from MA30AD, ! LENRL(I) will hold the number of non-zeros in row I of L. ! IDISP is an integer array of length 2. The user should set IDISP(1) ! to be the first available position in A/ICN for the LU ! decomposition while IDISP(2) is set to the position in A/ICN of ! the first non-zero in the diagonal blocks of P1*A*Q1. On output, ! IDISP(1) will be unaltered while IDISP(2) will be set to the ! position in A/ICN of the last non-zero of the LU decomposition. ! IP is an integer array of length N which holds a permutation of ! the integers 1 to N. On input to MA30AD, the absolute value of ! IP(I) must be set to the row of A which is row I of P1*A*Q1. A ! negative value for IP(I) indicates that row I is at the end of a ! diagonal block. On output from MA30AD, IP(I) indicates the row ! of A which is the Ith row in PAQ. IP(I) will still be negative ! for the last row of each block (except the last). ! IQ is an integer array of length N which again holds a ! permutation of the integers 1 to N. On input to MA30AD, IQ(J) ! must be set to the column of A which is column J of P1*A*Q1. On ! output from MA30AD, the absolute value of IQ(J) indicates the ! column of A which is the Jth in PAQ. For rows, I say, in which ! structural or numerical singularity is detected IQ(I) is ! negated. ! IRN is an integer array of length LIRN used as workspace by ! MA30AD. ! LIRN is an integer variable. It should be greater than the ! largest number of non-zeros in a diagonal block of P1*A*Q1 but ! need not be as large as LICN. It is the length of array IRN and ! should be large enough to hold the active part of any block, ! plus some "elbow room", the a posteriori adequacy of which can ! be estimated by examining the size of private variable ! IRNCP. ! LENC, FIRST, LASTR, NEXTR, LASTC, NEXTC are all integer arrays of ! length N which are used as workspace by MA30AD. If NSRCH is ! set to a value less than or equal to N, then arrays LASTC and ! NEXTC are not referenced by MA30AD and so can be dummied in ! the call to MA30AD. ! IPTR, IPC are integer arrays of length N which are used as ! workspace by MA30AD. ! U is a real(kind=wp) variable which should be set by the user ! to a value between 0. and 1.0. If less than zero it is reset ! to zero and if its value is 1.0 or greater it is reset to ! 0.9999 (0.999999999 in D version). It determines the balance ! between pivoting for sparsity and for stability, values near ! zero emphasizing sparsity and values near one emphasizing ! stability. We recommend U = 0.1 as a posible first trial value. ! The stability can be judged by a later call to MC24AD or by ! setting LBIG to .TRUE. ! IFLAG is an integer variable. It will have a non-negative value ! if MA30AD is successful. Negative values indicate error ! conditions while positive values indicate that the matrix has ! been successfully decomposed but is singular. For each non-zero ! value, an appropriate message is output on unit LP. Possible ! non-zero values for IFLAG are ! -1 THe matrix is structurally singular with rank given by IRANK ! in private variables for MA30FD. ! +1 If, however, the user wants the LU decomposition of a ! structurally singular matrix and sets the private variable ! ABORT1 to .FALSE., then, in the event of singularity and a ! successful decomposition, Iflag is returned with the value +1 ! and no message is output. ! -2 The matrix is numerically singular (it may also be structurally ! singular) with estimated rank given by IRANK in private variables ! for MA30FD. ! +2 THE user can choose to continue the decomposition even when a ! zero pivot is encountered by setting private variable ! ABORT2 TO .FALSE. If a singularity is encountered, IFLAG will ! then return with a value of +2, and no message is output if ! the decomposition has been completed successfully. ! -3 LIRN has not been large enough to continue with the ! decomposition. If the stage was zero then private variable ! MINIRN gives the length sufficient to start the decomposition on ! this block. FOr a successful decomposition on this block the ! user should make LIRN slightly (say about N/2) greater than this ! value. ! -4 LICN is not large enough to continue with the decomposition. ! -5 The decomposition has been completed but some of the LU factors ! have been discarded to create enough room in A/ICN to continue ! the decomposition. The variable MINICN in private variables for ! MA30FD. Then gives the size that LICN should be to enable the ! factorization to be successful. If the user sets private ! variable ABORT3 to .TRUE., then the subroutine will exit ! immediately instead of destroying any factors and continuing. ! -6 Both LICN and LIRN are too small. Termination has been caused ! by lack of space in IRN (see error IFLAG = -3), but already ! some of the LU factors in A/ICN have been lost (see error ! IFLAG = -5). MINICN gives the minimum amount of space ! required in A/ICN for decomposition up to this point. ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. KPP_REAL :: U INTEGER :: IFLAG, LICN, LIRN, NN ! .. ! .. Array Arguments .. KPP_REAL :: A(LICN) INTEGER :: ICN(LICN), IDISP(2), IFIRST(NN), IP(NN), IPC(NN), & IPTR(NN), IQ(NN), IRN(LIRN), LASTC(NN), LASTR(NN), & LENC(NN), LENR(NN), LENRL(NN), NEXTC(NN), NEXTR(NN) ! .. ! .. Local Scalars .. KPP_REAL :: AANEW, AMAX, ANEW, AU, PIVR, PIVRAT, SCALE INTEGER :: COLUPD, DISPC, I, I1, I2, IACTIV, IBEG, IDISPC, & IDROP, IDUMMY, IEND, IFILL, IFIR, II, III, IJFIR, IJP1, & IJPOS, ILAST, INDROW, IOP, IPIV, IPOS, IROWS, ISING, ISRCH,& ISTART, ISW, ISW1, ITOP, J, J1, J2, JBEG, JCOST, JCOUNT, & JDIFF, JDUMMY, JEND, JJ, JMORE, JNEW, JNPOS, JOLD, JPIV, & JPOS, JROOM, JVAL, JZER, JZERO, K, KCOST, KDROP, L, LC, & LENPIV, LENPP, LL, LR, MOREI, MSRCH, N, NBLOCK, NC, NNM1, & NR, NUM, NZ, NZ2, NZCOL, NZMIN, NZPC, NZROW, OLDEND, & OLDPIV, PIVEND, PIVOT, PIVROW, ROWI ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, IABS, MAX, MIN ! .. ! .. FIRST EXECUTABLE STATEMENT MA30AD ! .. MSRCH = NSRCH NDROP = 0 LNPIV(1:10) = 0 LPIV(1:10) = 0 MAPIV = 0 MANPIV = 0 IAVPIV = 0 IANPIV = 0 KOUNTL = 0 MINIRN = 0 MINICN = IDISP(1) - 1 MOREI = 0 IRANK = NN IRNCP = 0 ICNCP = 0 IFLAG = 0 ! Reset U if necessary. U = MIN(U,UMAX) ! IBEG is the position of the next pivot row after elimination ! step using it. U = MAX(U,ZERO) IBEG = IDISP(1) ! IACTIV is the position of the first entry in the active part ! of A/ICN. IACTIV = IDISP(2) ! NZROW is current number of non-zeros in active and unprocessed ! part of row file ICN. NZROW = LICN - IACTIV + 1 MINICN = NZROW + MINICN ! Count the number of diagonal blocks and set up pointers to the ! beginnings of the rows. NUM is the number of diagonal blocks. NUM = 1 IPTR(1) = IACTIV IF (NN==1) GOTO 30 NNM1 = NN - 1 DO I = 1, NNM1 IF (IP(I)<0) NUM = NUM + 1 IPTR(I+1) = IPTR(I) + LENR(I) END DO ! ILAST is the last row in the previous block. 30 ILAST = 0 ! *********************************************** ! **** LU decomposition of block NBLOCK **** ! *********************************************** ! Each pass through this loop performs LU decomposition on one ! of the diagonal blocks. DO 1070 NBLOCK = 1, NUM ISTART = ILAST + 1 DO IROWS = ISTART, NN IF (IP(IROWS)<0) GOTO 50 END DO IROWS = NN 50 ILAST = IROWS ! N is the number of rows in the current block. ! ISTART is the index of the first row in the current block. ! ILAST is the index of the last row in the current block. ! IACTIV is the position of the first entry in the block. ! ITOP is the position of the last entry in the block. N = ILAST - ISTART + 1 IF (N/=1) GOTO 100 ! Code for dealing WITH 1x1 block. LENRL(ILAST) = 0 ISING = ISTART IF (LENR(ILAST)/=0) GOTO 60 ! Block is structurally singular. IRANK = IRANK - 1 ISING = -ISING IF (IFLAG/=2 .AND. IFLAG/=-5) IFLAG = 1 IF (.NOT.ABORT1) GOTO 90 IDISP(2) = IACTIV IFLAG = -1 IF (LP/=0) WRITE (LP,90000) ! RETURN GOTO 1190 60 SCALE = ABS(A(IACTIV)) IF (ABS(SCALE)<=ZERO) GOTO 70 IF (LBIG) BIG = MAX(BIG,SCALE) GOTO 80 70 ISING = -ISING IRANK = IRANK - 1 IPTR(ILAST) = 0 IF (IFLAG/=-5) IFLAG = 2 IF (.NOT.ABORT2) GOTO 80 IDISP(2) = IACTIV IFLAG = -2 IF (LP/=0) WRITE (LP,90001) GOTO 1190 80 A(IBEG) = A(IACTIV) ICN(IBEG) = ICN(IACTIV) IACTIV = IACTIV + 1 IPTR(ISTART) = 0 IBEG = IBEG + 1 NZROW = NZROW - 1 90 LASTR(ISTART) = ISTART IPC(ISTART) = -ISING GOTO 1070 ! Non-trivial block. 100 ITOP = LICN IF (ILAST/=NN) ITOP = IPTR(ILAST+1) - 1 ! Set up column oriented storage. LENRL(ISTART:ILAST) = 0 LENC(ISTART:ILAST) = 0 IF (ITOP-IACTIVJ2) GOTO 160 DO JJ = J1, J2 J = ICN(JJ) IPOS = IPC(J) - 1 IRN(IPOS) = INDROW IPC(J) = IPOS END DO 160 END DO ! DISPC is the lowest indexed active location in the column file. DISPC = IPC(ISTART) NZCOL = LIRN - DISPC + 1 MINIRN = MAX(NZCOL,MINIRN) NZMIN = 1 ! Initialize array IFIRST. IFIRST(I) = +/- K indicates that ! row/col K has I non-zeros. If IFIRST(I) = 0, there is no ! row or column with I non-zeros. IFIRST(1:N) = 0 ! Compute ordering of row and column counts. ! First run through columns (from column N to column 1). DO 190 JJ = ISTART, ILAST J = ILAST - JJ + ISTART NZ = LENC(J) IF (NZ/=0) GOTO 180 IPC(J) = 0 GOTO 190 180 IF (NSRCH<=NN) GOTO 190 ISW = IFIRST(NZ) IFIRST(NZ) = -J LASTC(J) = 0 NEXTC(J) = -ISW ISW1 = IABS(ISW) IF (ISW/=0) LASTC(ISW1) = J 190 END DO ! Now run through rows (again from N to 1). DO 220 II = ISTART, ILAST I = ILAST - II + ISTART NZ = LENR(I) IF (NZ/=0) GOTO 200 IPTR(I) = 0 LASTR(I) = 0 GOTO 220 200 ISW = IFIRST(NZ) IFIRST(NZ) = I IF (ISW>0) GOTO 210 NEXTR(I) = 0 LASTR(I) = ISW GOTO 220 210 NEXTR(I) = ISW LASTR(I) = LASTR(ISW) LASTR(ISW) = I 220 END DO ! ********************************************** ! **** Start of main elimination loop **** ! ********************************************** DO 1050 PIVOT = ISTART, ILAST ! First find the pivot using MARKOWITZ criterion with ! stability control. ! JCOST is the Markowitz cost of the best pivot so far. ! This pivot is in row IPIV and column JPIV. NZ2 = NZMIN JCOST = N*N ! Examine rows/columns in order of ascending count. DO L = 1, 2 PIVRAT = ZERO ISRCH = 1 LL = L ! A pass with L equal to 2 is only performed in the ! case of singularity. DO 340 NZ = NZ2, N IF (JCOST<=(NZ-1)**2) GOTO 430 IJFIR = IFIRST(NZ) ! IF (IJFIR) 240, 230, 250 !230 IF (LL==1) NZMIN = NZ + 1 IF (IJFIR < 0) GOTO 240 IF (IJFIR > 0) GOTO 250 IF (LL==1) NZMIN = NZ + 1 GOTO 340 240 LL = 2 IJFIR = -IJFIR GOTO 300 250 LL = 2 ! Scan rows with NZ non-zeros. DO IDUMMY = 1, N IF (JCOST<=(NZ-1)**2) GOTO 430 IF (ISRCH>MSRCH) GOTO 430 IF (IJFIR==0) GOTO 290 ! Row IJFIR is now examined. I = IJFIR IJFIR = NEXTR(I) ! First calculate multiplier threshold level. AMAX = ZERO J1 = IPTR(I) + LENRL(I) J2 = IPTR(I) + LENR(I) - 1 DO JJ = J1, J2 AMAX = MAX(AMAX,ABS(A(JJ))) END DO AU = AMAX*U ISRCH = ISRCH + 1 ! Scan row for possible pivots. DO 270 JJ = J1, J2 IF (ABS(A(JJ))<=AU .AND. L==1) GOTO 270 J = ICN(JJ) KCOST = (NZ-1)*(LENC(J)-1) IF (KCOST>JCOST) GOTO 270 PIVR = ZERO IF (ABS(AMAX)>ZERO) PIVR = ABS(A(JJ))/AMAX IF (KCOST==JCOST .AND. (PIVR<=PIVRAT .OR. NSRCH>NN+1)) & GOTO 270 ! Best pivot so far is found. JCOST = KCOST IJPOS = JJ IPIV = I JPIV = J IF (MSRCH>NN+1 .AND. JCOST<=(NZ-1)**2) GOTO 430 PIVRAT = PIVR 270 END DO END DO ! Columns with NZ non-zeros now examined. 290 IJFIR = IFIRST(NZ) IJFIR = -LASTR(IJFIR) 300 IF (JCOST<=NZ*(NZ-1)) GOTO 430 IF (MSRCH<=NN) GOTO 340 DO 330 IDUMMY = 1, N IF (IJFIR==0) GOTO 340 J = IJFIR IJFIR = NEXTC(IJFIR) I1 = IPC(J) I2 = I1 + NZ - 1 ! Scan column J. DO 320 II = I1, I2 I = IRN(II) KCOST = (NZ-1)*(LENR(I)-LENRL(I)-1) IF (KCOST>=JCOST) GOTO 320 ! Pivot has best Markowitz count so far. Now ! check its suitability on numeric grounds by ! examining the other non-zeros in its row. J1 = IPTR(I) + LENRL(I) J2 = IPTR(I) + LENR(I) - 1 ! We need a stability check on singleton columns ! because of possible problems with ! underdetermined systems. AMAX = ZERO DO JJ = J1, J2 AMAX = MAX(AMAX,ABS(A(JJ))) IF (ICN(JJ)==J) JPOS = JJ END DO IF (ABS(A(JPOS))<=AMAX*U .AND. L==1) GOTO 320 JCOST = KCOST IPIV = I JPIV = J IJPOS = JPOS IF (ABS(AMAX)>ZERO) PIVRAT = ABS(A(JPOS))/AMAX IF (JCOST<=NZ*(NZ-1)) GOTO 430 320 END DO 330 END DO 340 END DO ! In the event of singularity, we must make sure all ! rows and columns are tested. MSRCH = N ! Matrix is numerically or structurally singular. Which ! it is will be diagnosed later. IRANK = IRANK - 1 END DO ! Assign rest of rows and columns to ordering array. ! Matrix is structurally singular. IF (IFLAG/=2 .AND. IFLAG/=-5) IFLAG = 1 IRANK = IRANK - ILAST + PIVOT + 1 IF (.NOT.ABORT1) GOTO 360 IDISP(2) = IACTIV IFLAG = -1 IF (LP/=0) WRITE (LP,90000) GOTO 1190 360 K = PIVOT - 1 DO 400 I = ISTART, ILAST IF (LASTR(I)/=0) GOTO 400 K = K + 1 LASTR(I) = K IF (LENRL(I)==0) GOTO 390 MINICN = MAX(MINICN,NZROW+IBEG-1+MOREI+LENRL(I)) IF (IACTIV-IBEG>=LENRL(I)) GOTO 370 CALL MA30DD(A,ICN,IPTR(ISTART),N,IACTIV,ITOP,.TRUE.) ! Check now to see if MA30DD has created enough ! available space. IF (IACTIV-IBEG>=LENRL(I)) GOTO 370 ! Create more space by destroying previously created ! LU factors. MOREI = MOREI + IBEG - IDISP(1) IBEG = IDISP(1) IF (LP/=0) WRITE (LP,90002) IFLAG = -5 IF (ABORT3) GOTO 1160 370 J1 = IPTR(I) J2 = J1 + LENRL(I) - 1 IPTR(I) = 0 DO JJ = J1, J2 A(IBEG) = A(JJ) ICN(IBEG) = ICN(JJ) ICN(JJ) = 0 IBEG = IBEG + 1 END DO NZROW = NZROW - LENRL(I) 390 IF (K==ILAST) GOTO 410 400 END DO 410 K = PIVOT - 1 DO 420 I = ISTART, ILAST IF (IPC(I)/=0) GOTO 420 K = K + 1 IPC(I) = K IF (K==ILAST) GOTO 1060 420 END DO ! The pivot has now been found in position (IPIV,JPIV) ! in location IJPOS in row file. ! Update column and row ordering arrays to correspond ! with removal of the active part of the matrix. 430 ISING = PIVOT IF (ABS(A(IJPOS))>ZERO) GOTO 440 ! Numerical singularity is recorded here. ISING = -ISING IF (IFLAG/=-5) IFLAG = 2 IF (.NOT.ABORT2) GOTO 440 IDISP(2) = IACTIV IFLAG = -2 IF (LP/=0) WRITE (LP,90001) GOTO 1190 440 OLDPIV = IPTR(IPIV) + LENRL(IPIV) OLDEND = IPTR(IPIV) + LENR(IPIV) - 1 ! Changes to column ordering. IF (NSRCH<=NN) GOTO 470 COLUPD = NN + 1 LENPP = OLDEND - OLDPIV + 1 IF (LENPP<4) LPIV(1) = LPIV(1) + 1 IF (LENPP>=4 .AND. LENPP<=6) LPIV(2) = LPIV(2) + 1 IF (LENPP>=7 .AND. LENPP<=10) LPIV(3) = LPIV(3) + 1 IF (LENPP>=11 .AND. LENPP<=15) LPIV(4) = LPIV(4) + 1 IF (LENPP>=16 .AND. LENPP<=20) LPIV(5) = LPIV(5) + 1 IF (LENPP>=21 .AND. LENPP<=30) LPIV(6) = LPIV(6) + 1 IF (LENPP>=31 .AND. LENPP<=50) LPIV(7) = LPIV(7) + 1 IF (LENPP>=51 .AND. LENPP<=70) LPIV(8) = LPIV(8) + 1 IF (LENPP>=71 .AND. LENPP<=100) LPIV(9) = LPIV(9) + 1 IF (LENPP>=101) LPIV(10) = LPIV(10) + 1 MAPIV = MAX(MAPIV,LENPP) IAVPIV = IAVPIV + LENPP DO 460 JJ = OLDPIV, OLDEND J = ICN(JJ) LC = LASTC(J) NC = NEXTC(J) NEXTC(J) = -COLUPD IF (JJ/=IJPOS) COLUPD = J IF (NC/=0) LASTC(NC) = LC IF (LC==0) GOTO 450 NEXTC(LC) = NC GOTO 460 450 NZ = LENC(J) ISW = IFIRST(NZ) IF (ISW>0) LASTR(ISW) = -NC IF (ISW<0) IFIRST(NZ) = -NC 460 END DO ! Changes to row ordering. 470 I1 = IPC(JPIV) I2 = I1 + LENC(JPIV) - 1 DO 490 II = I1, I2 I = IRN(II) LR = LASTR(I) NR = NEXTR(I) IF (NR/=0) LASTR(NR) = LR IF (LR<=0) GOTO 480 NEXTR(LR) = NR GOTO 490 480 NZ = LENR(I) - LENRL(I) IF (NR/=0) IFIRST(NZ) = NR IF (NR==0) IFIRST(NZ) = LR 490 END DO ! Move pivot to position LENRL+1 in pivot row and move pivot ! row to the beginning of the available storage. The L part ! and the pivot in the old copy of the pivot row is nullified ! while, in the strictly upper triangular part, the column ! indices, J say, are overwritten by the corresponding entry ! of IQ (IQ(J)) and IQ(J) is set to the negative of the ! displacement of the column index from the pivot entry. IF (OLDPIV==IJPOS) GOTO 500 AU = A(OLDPIV) A(OLDPIV) = A(IJPOS) A(IJPOS) = AU ICN(IJPOS) = ICN(OLDPIV) ICN(OLDPIV) = JPIV ! Check to see if there is space immediately available in ! A/ICN to hold new copy of pivot row. 500 MINICN = MAX(MINICN,NZROW+IBEG-1+MOREI+LENR(IPIV)) IF (IACTIV-IBEG>=LENR(IPIV)) GOTO 510 CALL MA30DD(A,ICN,IPTR(ISTART),N,IACTIV,ITOP,.TRUE.) OLDPIV = IPTR(IPIV) + LENRL(IPIV) OLDEND = IPTR(IPIV) + LENR(IPIV) - 1 ! Check now to see if MA30DD has created enough ! available space. IF (IACTIV-IBEG>=LENR(IPIV)) GOTO 510 ! Create more space by destroying previously created ! LU factors. MOREI = MOREI + IBEG - IDISP(1) IBEG = IDISP(1) IF (LP/=0) WRITE (LP,90002) IFLAG = -5 IF (ABORT3) GOTO 1160 IF (IACTIV-IBEG>=LENR(IPIV)) GOTO 510 ! There is still not enough room in A/ICN. IFLAG = -4 GOTO 1160 ! Copy pivot row and set up IQ array. 510 IJPOS = 0 J1 = IPTR(IPIV) DO JJ = J1, OLDEND A(IBEG) = A(JJ) ICN(IBEG) = ICN(JJ) IF (IJPOS/=0) GOTO 520 IF (ICN(JJ)==JPIV) IJPOS = IBEG ICN(JJ) = 0 GOTO 530 520 K = IBEG - IJPOS J = ICN(JJ) ICN(JJ) = IQ(J) IQ(J) = -K 530 IBEG = IBEG + 1 END DO IJP1 = IJPOS + 1 PIVEND = IBEG - 1 LENPIV = PIVEND - IJPOS NZROW = NZROW - LENRL(IPIV) - 1 IPTR(IPIV) = OLDPIV + 1 IF (LENPIV==0) IPTR(IPIV) = 0 ! Remove pivot row (including pivot) from column ! oriented file. DO JJ = IJPOS, PIVEND J = ICN(JJ) I1 = IPC(J) LENC(J) = LENC(J) - 1 ! I2 is last position in new column. I2 = IPC(J) + LENC(J) - 1 IF (I2ZERO) AU = -A(JJ)/A(IJPOS) IF (LBIG) BIG = MAX(BIG,ABS(AU)) A(JJ) = A(J1) A(J1) = AU ICN(JJ) = ICN(J1) ICN(J1) = JPIV LENRL(I) = LENRL(I) + 1 GOTO 590 580 END DO ! JUMP if pivot row is a singleton. 590 IF (LENPIV==0) GOTO 880 ! Now perform necessary operations on rest of non-pivot ! row I. ROWI = J1 + 1 IOP = 0 ! Jump if all the pivot row causes fill-in. IF (ROWI>IEND) GOTO 670 ! Perform operations on current non-zeros in row I. ! Innermost loop. LENPP = IEND - ROWI + 1 IF (LENPP<4) LNPIV(1) = LNPIV(1) + 1 IF (LENPP>=4 .AND. LENPP<=6) LNPIV(2) = LNPIV(2) + 1 IF (LENPP>=7 .AND. LENPP<=10) LNPIV(3) = LNPIV(3) + 1 IF (LENPP>=11 .AND. LENPP<=15) LNPIV(4) = LNPIV(4) + 1 IF (LENPP>=16 .AND. LENPP<=20) LNPIV(5) = LNPIV(5) + 1 IF (LENPP>=21 .AND. LENPP<=30) LNPIV(6) = LNPIV(6) + 1 IF (LENPP>=31 .AND. LENPP<=50) LNPIV(7) = LNPIV(7) + 1 IF (LENPP>=51 .AND. LENPP<=70) LNPIV(8) = LNPIV(8) + 1 IF (LENPP>=71 .AND. LENPP<=100) LNPIV(9) = LNPIV(9) + 1 IF (LENPP>=101) LNPIV(10) = LNPIV(10) + 1 MANPIV = MAX(MANPIV,LENPP) IANPIV = IANPIV + LENPP KOUNTL = KOUNTL + 1 DO 600 JJ = ROWI, IEND J = ICN(JJ) IF (IQ(J)>0) GOTO 600 IOP = IOP + 1 PIVROW = IJPOS - IQ(J) A(JJ) = A(JJ) + AU*A(PIVROW) IF (LBIG) BIG = MAX(ABS(A(JJ)),BIG) ICN(PIVROW) = -ICN(PIVROW) IF (ABS(A(JJ))0) LASTR(ISW) = -NC IF (ISW<0) IFIRST(NZ) = -NC 650 END DO ICN(JNEW:IEND) = 0 ! The value of IDROP might be different from that ! calculated earlier because we may now have dropped ! some non-zeros which were not modified by the pivot ! row. IDROP = IEND + 1 - JNEW IEND = JNEW - 1 LENR(I) = LENR(I) - IDROP NZROW = NZROW - IDROP NZCOL = NZCOL - IDROP NDROP = NDROP + IDROP 670 IFILL = LENPIV - IOP ! Jump is if there is no fill-in. IF (IFILL==0) GOTO 770 ! Now for the fill-in. MINICN = MAX(MINICN,MOREI+IBEG-1+NZROW+IFILL+LENR(I)) ! See if there is room for fill-in. ! Get maximum space for row I in situ. DO JDIFF = 1, IFILL JNPOS = IEND + JDIFF IF (JNPOS>LICN) GOTO 690 IF (ICN(JNPOS)/=0) GOTO 690 END DO ! There is room for all the fill-in after the end of the ! row so it can be left in situ. ! Next available space for fill-in. IEND = IEND + 1 GOTO 770 ! JMORE spaces for fill-in are required in front of row. 690 JMORE = IFILL - JDIFF + 1 I1 = IPTR(I) ! We now look in front of the row to see if there is space ! for the rest of the fill-in. DO JDIFF = 1, JMORE JNPOS = I1 - JDIFF IF (JNPOS=IBEG) GOTO 750 CALL MA30DD(A,ICN,IPTR(ISTART),N,IACTIV,ITOP,.TRUE.) I1 = IPTR(I) IEND = I1 + LENR(I) - 1 JNPOS = IACTIV - LENR(I) - IFILL IF (JNPOS>=IBEG) GOTO 750 ! No space available so try to create some by throwing ! away previous LU decomposition. MOREI = MOREI + IBEG - IDISP(1) - LENPIV - 1 IF (LP/=0) WRITE (LP,90002) IFLAG = -5 IF (ABORT3) GOTO 1160 ! Keep record of current pivot row. IBEG = IDISP(1) ICN(IBEG) = JPIV A(IBEG) = A(IJPOS) IJPOS = IBEG DO JJ = IJP1, PIVEND IBEG = IBEG + 1 A(IBEG) = A(JJ) ICN(IBEG) = ICN(JJ) END DO IJP1 = IJPOS + 1 PIVEND = IBEG IBEG = IBEG + 1 IF (JNPOS>=IBEG) GOTO 750 ! This still does not give enough room. IFLAG = -4 GOTO 1160 750 IACTIV = MIN(IACTIV,JNPOS) ! Move non-pivot row I. IPTR(I) = JNPOS DO JJ = I1, IEND A(JNPOS) = A(JJ) ICN(JNPOS) = ICN(JJ) JNPOS = JNPOS + 1 ICN(JJ) = 0 END DO ! First new available space. IEND = JNPOS 770 NZROW = NZROW + IFILL ! Innermost fill-in loop which also resets ICN. IDROP = 0 DO 850 JJ = IJP1, PIVEND J = ICN(JJ) IF (J<0) GOTO 840 ANEW = AU*A(JJ) AANEW = ABS(ANEW) IF (AANEW>=TOL) GOTO 780 IDROP = IDROP + 1 NDROP = NDROP + 1 NZROW = NZROW - 1 MINICN = MINICN - 1 IFILL = IFILL - 1 GOTO 850 780 IF (LBIG) BIG = MAX(AANEW,BIG) A(IEND) = ANEW ICN(IEND) = J IEND = IEND + 1 ! Put new entry in column file. MINIRN = MAX(MINIRN,NZCOL+LENC(J)+1) JEND = IPC(J) + LENC(J) JROOM = NZPC - III + 1 + LENC(J) IF (JEND>LIRN) GOTO 790 IF (IRN(JEND)==0) GOTO 830 790 IF (JROOM=LENC(J)+1) GOTO 800 ! Column file is not large enough. GOTO 1170 ! Copy column to beginning of file. 800 JBEG = IPC(J) JEND = IPC(J) + LENC(J) - 1 JZERO = DISPC - 1 DISPC = DISPC - JROOM IDISPC = DISPC DO II = JBEG, JEND IRN(IDISPC) = IRN(II) IRN(II) = 0 IDISPC = IDISPC + 1 END DO IPC(J) = DISPC JEND = IDISPC IRN(JEND:JZERO) = 0 830 IRN(JEND) = I NZCOL = NZCOL + 1 LENC(J) = LENC(J) + 1 ! End of adjustment to column file. GOTO 850 840 ICN(JJ) = -J 850 END DO IF (IDROP==0) GOTO 870 DO KDROP = 1, IDROP ICN(IEND) = 0 IEND = IEND + 1 END DO 870 LENR(I) = LENR(I) + IFILL ! End of scan of pivot column. 880 END DO ! Remove pivot column from column oriented storage ! and update row ordering arrays. I1 = IPC(JPIV) I2 = IPC(JPIV) + LENC(JPIV) - 1 NZCOL = NZCOL - LENC(JPIV) DO 930 II = I1, I2 I = IRN(II) IRN(II) = 0 NZ = LENR(I) - LENRL(I) IF (NZ/=0) GOTO 890 LASTR(I) = 0 GOTO 930 890 IFIR = IFIRST(NZ) IFIRST(NZ) = I ! IF (IFIR) 900, 920, 910 !900 LASTR(I) = IFIR IF (IFIR == 0) GOTO 920 IF (IFIR > 0) GOTO 910 LASTR(I) = IFIR NEXTR(I) = 0 GOTO 930 910 LASTR(I) = LASTR(IFIR) NEXTR(I) = IFIR LASTR(IFIR) = I GOTO 930 920 LASTR(I) = 0 NEXTR(I) = 0 NZMIN = MIN(NZMIN,NZ) 930 END DO ! Restore IQ and nullify U part of old pivot row. ! Record the column permutation in LASTC(JPIV) and ! the row permutation in LASTR(IPIV). 940 IPC(JPIV) = -ISING LASTR(IPIV) = PIVOT IF (LENPIV==0) GOTO 1050 NZROW = NZROW - LENPIV JVAL = IJP1 JZER = IPTR(IPIV) IPTR(IPIV) = 0 DO JCOUNT = 1, LENPIV J = ICN(JVAL) IQ(J) = ICN(JZER) ICN(JZER) = 0 JVAL = JVAL + 1 JZER = JZER + 1 END DO ! Adjust column ordering arrays. IF (NSRCH>NN) GOTO 980 DO 970 JJ = IJP1, PIVEND J = ICN(JJ) NZ = LENC(J) IF (NZ/=0) GOTO 960 IPC(J) = 0 GOTO 970 960 NZMIN = MIN(NZMIN,NZ) 970 END DO GOTO 1050 980 JJ = COLUPD DO 1040 JDUMMY = 1, NN J = JJ IF (J==NN+1) GOTO 1050 JJ = -NEXTC(J) NZ = LENC(J) IF (NZ/=0) GOTO 990 IPC(J) = 0 GOTO 1040 990 IFIR = IFIRST(NZ) LASTC(J) = 0 ! IF (IFIR) 1000, 1010, 1020 !1000 IFIRST(NZ) = -J IF (IFIR == 0) GOTO 1010 IF (IFIR > 0) GOTO 1020 IFIRST(NZ) = -J IFIR = -IFIR LASTC(IFIR) = J NEXTC(J) = IFIR GOTO 1040 1010 IFIRST(NZ) = -J NEXTC(J) = 0 GOTO 1030 1020 LC = -LASTR(IFIR) LASTR(IFIR) = -J NEXTC(J) = LC IF (LC/=0) LASTC(LC) = J 1030 NZMIN = MIN(NZMIN,NZ) 1040 END DO 1050 END DO ! ******************************************** ! **** End of main elimination loop **** ! ******************************************** ! Reset IACTIV to point to the beginning of the ! next block. 1060 IF (ILAST/=NN) IACTIV = IPTR(ILAST+1) 1070 END DO ! ******************************************** ! **** End of deomposition of block **** ! ******************************************** ! Record singularity (if any) in IQ array. IF (IRANK==NN) GOTO 1090 DO 1080 I = 1, NN IF (IPC(I)<0) GOTO 1080 ISING = IPC(I) IQ(ISING) = -IQ(ISING) IPC(I) = -ISING 1080 END DO ! Run through LU decomposition changing column indices ! to that of new order and permuting LENR and LENRL ! arrays according to pivot permutations. 1090 ISTART = IDISP(1) IEND = IBEG - 1 IF (IEND=0) GOTO 20 ! First non-zero of row/col has been located. J = -ICN(JPOS) ICN(JPOS) = IPTR(J) IPTR(J) = KN 20 ICN(KN) = ICN(JPOS) 30 END DO IACTIV = KN RETURN END SUBROUTINE MA30DD !_______________________________________________________________________ SUBROUTINE MA30BD(N,ICN,A,LICN,LENR,LENRL,IDISP,IP,IQ,W,IW,IFLAG) ! .. ! MA30BD performs the LU decomposition of the diagonal blocks of ! a new matrix PAQ of the same sparsity pattern, using information ! from a previous call to MA30AD. THe entries of the input matrix ! must already be in their final positions in the LU decomposition ! structure. This routine executes about five times faster than ! MA30AD. ! .. ! We now describe the argument list for MA30BD. Consult MA30AD for ! further information on these parameters. ! N is an integer variable set to the order of the matrix. ! ICN is an integer array of length LICN. It should be unchanged ! since the last call to MA30AD. It is not altered by MA30BD. ! A is a real(kind=wp) array of length LICN. The user must set ! entries IDISP(1) to IDISP(2) to contain the entries in the ! diagonal blocks of the matrix PAQ whose column numbers are ! held in ICN, using corresponding positions. Note that some ! zeros may need to be held explicitly. On output entries ! IDISP(1) to IDISP(2) of array A contain the LU decomposition ! of the diagonal blocks of PAQ. Entries A(1) to A(IDISP(1)-1) ! are neither required nor altered by MA30BD. ! LICN is an integer variable which must be set by the user to the ! length of arrays A and ICN. it is not altered by MA30BD. ! LENR, LENRL are integer arrays of length N. They should be ! unchanged since the last call to MA30AD. They are not ! altered by MA30BD. ! IDISP is an integer array of length 2. It should be unchanged ! since the last call to MA30AD. It is not altered by MA30BD. ! IP, IQ are integer arrays of length N. They should be unchanged ! since the last call to MA30AD. They are not altered by ! MA30BD. ! W is a REAL(KIND=WP) array of length N which is used as ! workspace by MA30BD. ! IW is an integer array of length N which is used as workspace ! by MA30BD. ! IFLAG is an integer variable. On output from MA30BD, IFLAG has ! the value zero if the factorization was successful, has the ! value I if pivot I was very small and has the value -I if ! an unexpected singularity was detected at stage I of the ! decomposition. ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. INTEGER :: IFLAG, LICN, N ! .. ! .. Array Arguments .. KPP_REAL :: A(LICN), W(N) INTEGER :: ICN(LICN), IDISP(2), IP(N), IQ(N), IW(N), LENR(N), LENRL(N) ! .. ! .. Local Scalars .. KPP_REAL :: AU, ROWMAX INTEGER :: I, IFIN, ILEND, IPIVJ, ISING, ISTART, J, JAY, JAYJAY, JFIN, & JJ, PIVPOS LOGICAL :: STAB ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX ! .. ! .. FIRST EXECUTABLE STATEMENT MA30BD ! .. STAB = EPS <= ONE RMIN = EPS ISING = 0 IFLAG = 0 W(1:N) = ZERO ! Set up pointers to the beginning of the rows. IW(1) = IDISP(1) IF (N==1) GOTO 30 DO I = 2, N IW(I) = IW(I-1) + LENR(I-1) END DO ! Start of main loop. ! At step I, row I of A is transformed to row I of LU by ! adding appropriate multiples of rows 1 TO I-1 using row ! Gauss elimination. 30 DO 170 I = 1, N ! ISTART is beginning of row I of A and row I of L. ISTART = IW(I) ! IFIN is end of row I of A and row I of U. IFIN = ISTART + LENR(I) - 1 ! ILEND is end of row I of L. ILEND = ISTART + LENRL(I) - 1 IF (ISTART>ILEND) GOTO 100 ! Load row I of A into vector W. DO JJ = ISTART, IFIN J = ICN(JJ) W(J) = A(JJ) END DO ! Add multiples of appropriate rows of I to I-1 to row I. DO 80 JJ = ISTART, ILEND J = ICN(JJ) ! IPIVJ is position of pivot in row J. IPIVJ = IW(J) + LENRL(J) ! Form multiplier AU. AU = -W(J)/A(IPIVJ) IF (LBIG) BIG = MAX(ABS(AU),BIG) W(J) = AU ! AU * ROW J (U part) is added to row I. IPIVJ = IPIVJ + 1 JFIN = IW(J) + LENR(J) - 1 IF (IPIVJ>JFIN) GOTO 80 ! Innermost loop. IF (LBIG) GOTO 60 DO JAYJAY = IPIVJ, JFIN JAY = ICN(JAYJAY) W(JAY) = W(JAY) + AU*A(JAYJAY) END DO GOTO 80 60 DO JAYJAY = IPIVJ, JFIN JAY = ICN(JAYJAY) W(JAY) = W(JAY) + AU*A(JAYJAY) BIG = MAX(ABS(W(JAY)),BIG) END DO 80 END DO ! Reload W back into A (now LU). DO JJ = ISTART, IFIN J = ICN(JJ) A(JJ) = W(J) W(J) = ZERO END DO ! We now perform the stability checks. 100 PIVPOS = ILEND + 1 IF (IQ(I)>0) GOTO 150 ! Matrix had singularity at this point in MA30AD. ! Is it the first such pivot in current block? IF (ISING==0) ISING = I ! Does current matrix have a singularity in the same place? IF (PIVPOS>IFIN) GOTO 110 IF (ABS(A(PIVPOS))>ZERO) GOTO 180 ! It does, so set ising if it is not the end of the current ! block. Check to see that appropriate part of LU is zero ! or null. 110 IF (ISTART>IFIN) GOTO 130 DO 120 JJ = ISTART, IFIN IF (ICN(JJ)ZERO) GOTO 180 120 END DO 130 IF (PIVPOS<=IFIN) A(PIVPOS) = ONE IF (IP(I)>0 .AND. I/=N) GOTO 170 ! End of current block. Reset zero pivots and ISING. DO 140 J = ISING, I IF ((LENR(J)-LENRL(J))==0) GOTO 140 JJ = IW(J) + LENRL(J) A(JJ) = ZERO 140 END DO ISING = 0 GOTO 170 ! Matrix had non-zero pivot in MA30AD at this stage. 150 IF (PIVPOS>IFIN) GOTO 180 IF (ABS(A(PIVPOS))<=ZERO) GOTO 180 IF (.NOT.STAB) GOTO 170 ROWMAX = ZERO DO JJ = PIVPOS, IFIN ROWMAX = MAX(ROWMAX,ABS(A(JJ))) END DO IF (ABS(A(PIVPOS))/ROWMAX>=RMIN) GOTO 170 IFLAG = I RMIN = ABS(A(PIVPOS))/ROWMAX ! End of main loop. 170 END DO GOTO 190 ! Error return 180 IF (LP/=0) WRITE (LP,90000) I IFLAG = -I 190 RETURN 90000 FORMAT (' Error return from MA30BD; Singularity detected in',' row', & I8) END SUBROUTINE MA30BD !_______________________________________________________________________ SUBROUTINE MA30CD(N,ICN,A,LICN,LENR,LENRL,LENOFF,IDISP,IP,IQ,X, & W,MTYPE) ! .. ! MA30CD uses the factors produced by MA30AD or MA30BD to solve ! AX = B or A TRANSPOSE X = B when the matrix P1*A*Q1(PAQ) is ! block lower triangular (including the case of only one diagonal ! block). ! .. ! We now describe the argument list for MA30CD. ! N is an integer variable set to the order of the matrix. It is ! not altered by the subroutine. ! ICN is an integer array of length LICN. Entries IDISP(1) to ! IDISP(2) should be unchanged since the last call to MA30AD. If ! the matrix has more than one diagonal block, then column indices ! corresponding to non-zeros in sub-diagonal blocks of PAQ must ! appear in positions 1 to IDISP(1)-1. For the same row those ! entries must be contiguous, with those in row I preceding those ! in row I+1 (I=1,...,N-1) and no wasted space between rows. ! Entries may be in any order within each row. It is not altered ! by MA30CD. ! A is a REAL(KIND=WP) array of length LICN. Entries IDISP(1) to ! IDISP(2) should be unchanged since the last call to MA30AD or ! MA30BD. If the matrix has more than one diagonal block, then ! the values of the non-zeros in sub-diagonal blocks must be in ! positions 1 to IDISP(1)-1 in the order given by ICN. It is not ! altered by MA30CD. ! LICN is an integer variable set to the size of arrays ICN and A. ! It is not altered by MA30CD. ! LENR, LENRL are integer arrays of length N which should be ! unchanged since the last call to MA30AD. They are not ! altered by MA30CD. ! LENOFF is an integer array of length N. If the matrix PAQ (or ! P1*A*Q1) has more than one diagonal block, then LENOFF(I), ! I=1,...,N should be set to the number of non-zeros in row I of ! the matrix PAQ which are in sub-diagonal blocks. If there is ! only one diagonal block then LENOFF(1) may be set TO -1, in ! which case the other entries of LENOFF are never accessed. ! It is not altered by ma30cd. ! IDISP is an integer array of length 2 which should be unchanged ! since the last call to MA30AD. It is not altered by MA30CD. ! IP, IQ are integer arrays of length N which should be unchanged ! since the last call to MA30AD. They are not altered by ! MA30CD. ! X is a REAL(KIND=WP) array of length N. It must be set by the ! user to the values of the right hand side vector B for the ! equations being solved. ON exit from MA30CD it will be equal ! to the solution X required. ! W is a REAL(KIND=WP) array of length N which is used as ! workspace by MA30CD. ! MTYPE is an integer variable which must be set by the user. If ! MTYPE = 1, then the solution to the system AX = B is returned. ! Any other value for mtype will return the solution to the ! system A TRANSPOSE X = B. It is not altered by MA30CD. ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. INTEGER :: LICN, MTYPE, N ! .. ! .. Array Arguments .. KPP_REAL :: A(LICN), W(N), X(N) INTEGER :: ICN(LICN), IDISP(2), IP(N), IQ(N), LENOFF(N), LENR(N), & LENRL(N) ! .. ! .. Local Scalars .. KPP_REAL :: WI, WII INTEGER :: I, IB, IBACK, IBLEND, IBLOCK, IEND, IFIRST, II, III, & ILAST, J, J1, J2, J3, JJ, JPIV, JPIVP1, K, LJ1, LJ2, LT, LTEND, & NUMBLK LOGICAL :: NEG, NOBLOC ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, IABS, MAX ! .. ! .. FIRST EXECUTABLE STATEMENT MA30CD ! .. ! The final value of RESID is the maximum residual for an ! inconsistent set of equations. RESID = ZERO ! NOBLOC is .TRUE. if subroutine block has been used ! previously and is .FALSE. otherwise. The value .FALSE. ! means that LENOFF will not be subsequently accessed. NOBLOC = LENOFF(1) < 0 IF (MTYPE/=1) GOTO 140 ! We now solve A * X = B. ! NEG is used to indicate when the last row in a block ! has been reached. It is then set to .TRUE. whereafter ! back substitution is performed on the block. NEG = .FALSE. ! IP(N) is negated so that the last row of the last ! block can be recognised. It is reset to its positive ! value on exit. IP(N) = -IP(N) ! Preorder VECTOR ... W(I) = X(IP(I)) DO II = 1, N I = IP(II) I = IABS(I) W(II) = X(I) END DO ! LT holds the position of the first non-zero in the current ! row of the off-diagonal blocks. LT = 1 ! IFIRST holds the index of the first row in the current block. IFIRST = 1 ! IBLOCK holds the position of the first non-zero in the current ! row of the LU decomposition of the diagonal blocks. IBLOCK = IDISP(1) ! If I is not the last row of a block, then a pass through this ! loop adds the inner product of row I of the off-diagonal blocks ! and W to W and performs forward elimination using row I of the ! LU decomposition. If I is the last row of a block then, after ! performing these aforementioned operations, back substitution ! is performed using the rows of the block. DO 120 I = 1, N WI = W(I) IF (NOBLOC) GOTO 30 IF (LENOFF(I)==0) GOTO 30 ! Operations using lower triangular blocks. ! LTEND is the end of row I in the off-diagonal blocks. LTEND = LT + LENOFF(I) - 1 DO JJ = LT, LTEND J = ICN(JJ) WI = WI - A(JJ)*W(J) END DO ! LT is set the beginning of the next off-diagonal row. LT = LTEND + 1 ! Set NEG to .TRUE. if we are on the last row of the block. 30 IF (IP(I)<0) NEG = .TRUE. IF (LENRL(I)==0) GOTO 50 ! Forward elimination phase. ! IEND is the end of the L part of row I in the LU decomposition. IEND = IBLOCK + LENRL(I) - 1 DO JJ = IBLOCK, IEND J = ICN(JJ) WI = WI + A(JJ)*W(J) END DO ! IBLOCK is adjusted to point to the start of the next row. 50 IBLOCK = IBLOCK + LENR(I) W(I) = WI IF (.NOT.NEG) GOTO 120 ! Back substitution phase. ! J1 is position in A/ICN after end of block beginning in ! row IFIRST and ending in row I. J1 = IBLOCK ! Are there any singularities in this block? If not, continue ! with the back substitution. IB = I IF (IQ(I)>0) GOTO 70 DO III = IFIRST, I IB = I - III + IFIRST IF (IQ(IB)>0) GOTO 70 J1 = J1 - LENR(IB) RESID = MAX(RESID,ABS(W(IB))) W(IB) = ZERO END DO ! Entire block is singular. GOTO 110 ! Each pass through this loop performs the back substitution ! operations for a single row, starting at the end of the ! block and working through it in reverse order. 70 DO III = IFIRST, IB II = IB - III + IFIRST ! J2 is end of row II. J2 = J1 - 1 ! J1 is beginning of row II. J1 = J1 - LENR(II) ! JPIV is the position of the pivot in row II. JPIV = J1 + LENRL(II) JPIVP1 = JPIV + 1 ! JUMP if row II of U has no non-zeros. IF (J2KMAX) GOTO 40 KOR = KMAX DO KDUMMY = KLO, KMAX ! Items KOR,KOR+1,...,KMAX are in order. ACE = A(KOR-1) ICE = INUM(KOR-1) DO K = KOR, KMAX IK = INUM(K) IF (IABS(ICE)<=IABS(IK)) GOTO 20 INUM(K-1) = IK A(K-1) = A(K) END DO K = KMAX + 1 20 INUM(K-1) = ICE A(K-1) = ACE KOR = KOR - 1 END DO ! Next column. 40 KMAX = KLO - 2 END DO RETURN END SUBROUTINE MC20BD !_______________________________________________________________________ SUBROUTINE MC21A(N,ICN,LICN,IP,LENR,IPERM,NUMNZ,IW) ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. INTEGER :: LICN, N, NUMNZ ! .. ! .. Array Arguments .. INTEGER :: ICN(LICN), IP(N), IPERM(N), IW(N,4), LENR(N) ! .. ! .. FIRST EXECUTABLE STATEMENT MA21A ! .. CALL MC21B(N,ICN,LICN,IP,LENR,IPERM,NUMNZ,IW(1,1),IW(1,2), & IW(1,3),IW(1,4)) RETURN END SUBROUTINE MC21A !_______________________________________________________________________ SUBROUTINE MC21B(N,ICN,LICN,IP,LENR,IPERM,NUMNZ,PR,ARP,CV,OUT) ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. ! .. INTEGER :: LICN, N, NUMNZ ! .. ! .. Array Arguments .. INTEGER :: ARP(N), CV(N), ICN(LICN), IP(N), IPERM(N), LENR(N), & OUT(N), PR(N) ! .. ! .. Local Scalars .. INTEGER :: I, II, IN1, IN2, IOUTK, J, J1, JORD, K, KK ! .. ! .. FIRST EXECUTABLE STATEMENT MA21B ! .. ! PR(I) is the previous row to I in the depth first search. ! It is used as a work array in the sorting algorithm. ! Elements (IPERM(I),I) I=1,...,N are non-zero at the ! end of the algorithm unless N assignments have not ! been made, in which case (IPERM(I),I) will be zero ! for N-NUMNZ entries. ! CV(I) is the most recent row extension at which column I ! was visited. ! ARP(I) is one less than the number of non-zeros in row I ! which have not been scanned when looking for a cheap ! assignment. ! OUT(I) is one less than the number of non-zeros in row I ! which have not been scanned during one pass through ! the main loop. ! Initialization of arrays. DO I = 1, N ARP(I) = LENR(I) - 1 CV(I) = 0 IPERM(I) = 0 END DO NUMNZ = 0 ! Main loop. ! Each pass round this loop either results in a new ! assignment or gives a row with no assignment. DO 100 JORD = 1, N J = JORD PR(J) = -1 DO 70 K = 1, JORD ! Look for a cheap assignment. IN1 = ARP(J) IF (IN1<0) GOTO 30 IN2 = IP(J) + LENR(J) - 1 IN1 = IN2 - IN1 DO II = IN1, IN2 I = ICN(II) IF (IPERM(I)==0) GOTO 80 END DO ! No cheap assignment in row. ARP(J) = -1 ! Begin looking for assignment chain starting with row J. 30 OUT(J) = LENR(J) - 1 ! Inner loop. Extends chain by one or backtracks. DO KK = 1, JORD IN1 = OUT(J) IF (IN1<0) GOTO 50 IN2 = IP(J) + LENR(J) - 1 IN1 = IN2 - IN1 ! Forward scan. DO 40 II = IN1, IN2 I = ICN(II) IF (CV(I)==JORD) GOTO 40 ! Column I has not yet been accessed during this pass. J1 = J J = IPERM(I) CV(I) = JORD PR(J) = J1 OUT(J1) = IN2 - II - 1 GOTO 70 40 END DO ! Backtracking step. 50 J = PR(J) IF (J==-1) GOTO 100 END DO 70 END DO ! New assignment is made. 80 IPERM(I) = J ARP(J) = IN2 - II - 1 NUMNZ = NUMNZ + 1 DO K = 1, JORD J = PR(J) IF (J==-1) GOTO 100 II = IP(J) + LENR(J) - OUT(J) - 2 I = ICN(II) IPERM(I) = J END DO 100 END DO ! If matrix is structurally singular, we now complete the ! permutation IPERM. IF (NUMNZ==N) RETURN ARP(1:N) = 0 K = 0 DO 130 I = 1, N IF (IPERM(I)/=0) GOTO 120 K = K + 1 OUT(K) = I GOTO 130 120 J = IPERM(I) ARP(J) = I 130 END DO K = 0 DO 140 I = 1, N IF (ARP(I)/=0) GOTO 140 K = K + 1 IOUTK = OUT(K) IPERM(IOUTK) = I 140 END DO RETURN END SUBROUTINE MC21B !_______________________________________________________________________ SUBROUTINE MC22AD(N,ICN,A,NZ,LENROW,IP,IQ,IW,IW1) ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. INTEGER :: N, NZ ! .. ! .. Array Arguments .. KPP_REAL :: A(NZ) INTEGER :: ICN(NZ), IP(N), IQ(N), IW(N,2), IW1(NZ), LENROW(N) ! .. ! .. Local Scalars .. KPP_REAL :: AVAL INTEGER :: I, ICHAIN, IOLD, IPOS, J, J2, JJ, JNUM, JVAL, LENGTH, & NEWPOS ! .. ! .. Intrinsic Functions .. INTRINSIC IABS ! .. ! .. FIRST EXECUTABLE STATEMENT MA22AD ! .. IF (NZ<=0) GOTO 90 IF (N<=0) GOTO 90 ! Set start of row I in IW(I,1) and LENROW(I) in IW(I,2) IW(1,1) = 1 IW(1,2) = LENROW(1) DO I = 2, N IW(I,1) = IW(I-1,1) + LENROW(I-1) IW(I,2) = LENROW(I) END DO ! Permute LENROW according to IP. Set off-sets for new ! position of row IOLD in IW(IOLD,1) and put old row ! indices in IW1 in positions corresponding to the new ! position of this row in A/ICN. JJ = 1 DO 30 I = 1, N IOLD = IP(I) IOLD = IABS(IOLD) LENGTH = IW(IOLD,2) LENROW(I) = LENGTH IF (LENGTH==0) GOTO 30 IW(IOLD,1) = IW(IOLD,1) - JJ J2 = JJ + LENGTH - 1 DO 20 J = JJ, J2 20 IW1(J) = IOLD JJ = J2 + 1 30 END DO ! Set inverse permutation to IQ in IW(:,2). DO I = 1, N IOLD = IQ(I) IOLD = IABS(IOLD) IW(IOLD,2) = I END DO ! Permute A and ICN in place, changing to new column numbers. ! Main loop. ! Each pass through this loop places a closed chain of ! column indices in their new (and final) positions. ! This is recorded by setting the iw1 entry to zero so ! that any which are subsequently encountered during ! this major scan can be bypassed. DO 80 I = 1, NZ IOLD = IW1(I) IF (IOLD==0) GOTO 80 IPOS = I JVAL = ICN(I) ! If row IOLD is in same positions after permutation, ! GOTO 150. IF (IW(IOLD,1)==0) GOTO 70 AVAL = A(I) ! Chain loop. ! Each pass through this loop places one(permuted) column ! index in its final position, viz. IPOS. DO ICHAIN = 1, NZ ! NEWPOS is the original position in A/ICN of the ! element to be placed in position IPOS. It is also ! the position of the next element in the chain. NEWPOS = IPOS + IW(IOLD,1) ! Is chain complete? IF (NEWPOS==I) GOTO 60 A(IPOS) = A(NEWPOS) JNUM = ICN(NEWPOS) ICN(IPOS) = IW(JNUM,2) IPOS = NEWPOS IOLD = IW1(IPOS) IW1(IPOS) = 0 ! End of chain loop. END DO 60 A(IPOS) = AVAL 70 ICN(IPOS) = IW(JVAL,2) ! END OF MAIN LOOP 80 END DO 90 RETURN END SUBROUTINE MC22AD !_______________________________________________________________________ SUBROUTINE MC23AD(N,ICN,A,LICN,LENR,IDISP,IP,IQ,LENOFF,IW,IW1) ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. INTEGER :: LICN, N ! .. ! .. Array Arguments .. KPP_REAL :: A(LICN) INTEGER :: ICN(LICN), IDISP(2), IP(N), IQ(N), IW(N,5), IW1(N,2), & LENOFF(N), LENR(N) ! .. ! .. Local Scalars .. INTEGER :: I, I1, I2, IBEG, IBLOCK, IEND, II, ILEND, INEW, IOLD, & IROWB, IROWE, J, JJ, JNEW, JNPOS, JOLD, K, LENI, NZ ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN ! .. ! .. FIRST EXECUTABLE STATEMENT MA23AD ! .. ! Input ... N,ICN ... A,ICN,LENR ... ! Set up pointers IW(:,1) to the beginning of the rows ! and set LENOFF equal to LENR. IW1(1,1) = 1 LENOFF(1) = LENR(1) IF (N==1) GOTO 20 DO I = 2, N LENOFF(I) = LENR(I) IW1(I,1) = IW1(I-1,1) + LENR(I-1) END DO ! IDISP(1) points to the first position in A/ICN after ! the off-diagonal blocks and untreated rows. 20 IDISP(1) = IW1(N,1) + LENR(N) ! Find row permutation ip to make diagonal zero-free. CALL MC21A(N,ICN,LICN,IW1(1,1),LENR,IP,NUMNZ,IW(1,1)) ! Possible error return for structurally singular matrices. IF (NUMNZ/=N .AND. ABORT) GOTO 170 ! IW1(:,2) and LENR are permutations of IW1(:,1) and ! LENR/LENOFF suitable for entry to MC13D since matrix ! with these row pointer and length arrays has maximum ! number of non-zeros on the diagonal. DO II = 1, N I = IP(II) IW1(II,2) = IW1(I,1) LENR(II) = LENOFF(I) END DO ! Find symmetric permutation IQ to block lower triangular form. CALL MC13D(N,ICN,LICN,IW1(1,2),LENR,IQ,IW(1,4),NUM,IW) IF (NUM/=1) GOTO 60 ! Action taken if matrix is irreducible: The ! whole matrix is just moved to the end of the storage. DO I = 1, N LENR(I) = LENOFF(I) IP(I) = I IQ(I) = I END DO LENOFF(1) = -1 ! IDISP(1) is the first position after the last element in ! the off-diagonal blocks and untreated rows. NZ = IDISP(1) - 1 IDISP(1) = 1 ! IDISP(2) Is the position in A/ICN of the first element ! in the diagonal blocks. IDISP(2) = LICN - NZ + 1 LARGE = N IF (NZ==LICN) GOTO 200 DO K = 1, NZ J = NZ - K + 1 JJ = LICN - K + 1 A(JJ) = A(J) ICN(JJ) = ICN(J) END DO GOTO 200 ! Data structure reordered. ! Form composite row permutation, IP(I) = IP(IQ(I)). 60 DO II = 1, N I = IQ(II) IW(II,1) = IP(I) END DO DO I = 1, N IP(I) = IW(I,1) END DO ! Run through blocks in reverse order separating diagonal ! blocks which are moved to the end of the storage. Elements ! in off-diagonal blocks are left in place unless a compress ! is necessary. ! IBEG indicates the lowest value of J for which ICN(J) has ! been set to zero when element in position J was moved to ! the diagonal block part of storage. IBEG = LICN + 1 ! IEND is the position of the first element of those treated ! rows which are in diagonal blocks. IEND = LICN + 1 ! LARGE is the dimension of the largest block encountered ! so far. LARGE = 0 ! NUM is the number of diagonal blocks. DO K = 1, NUM IBLOCK = NUM - K + 1 ! I1 is first row (in permuted form) of block IBLOCK. ! I2 is last row (in permuted form) of block IBLOCK. I1 = IW(IBLOCK,4) I2 = N IF (K/=1) I2 = IW(IBLOCK+1,4) - 1 LARGE = MAX(LARGE,I2-I1+1) ! Go through the rows of block IBLOCK in the reverse order. DO II = I1, I2 INEW = I2 - II + I1 ! We now deal with row inew in permuted form (row IOLD ! in original matrix). IOLD = IP(INEW) ! If there is space to move up diagonal block portion ! of row GOTO 110. IF (IEND-IDISP(1)>=LENOFF(IOLD)) GOTO 110 ! In-line compress. ! Moves separated off-diagonal elements and untreated ! rows to front of storage. JNPOS = IBEG ILEND = IDISP(1) - 1 IF (ILENDLICN) GOTO 200 JNPOS = IBEG ILEND = IDISP(1) - 1 DO 160 J = IBEG, ILEND IF (ICN(J)==0) GOTO 160 ICN(JNPOS) = ICN(J) A(JNPOS) = A(J) JNPOS = JNPOS + 1 160 END DO ! IDISP(1) is first position after last element of ! off-diagonal blocks. IDISP(1) = JNPOS GOTO 200 ! Error return 170 IF (LP/=0) WRITE (LP,90000) NUMNZ 90000 FORMAT (' Matrix is structurally singular, rank = ',I6) IDISP(1) = -1 GOTO 190 180 IF (LP/=0) WRITE (LP,90001) N 90001 FORMAT (' LICN is not big enough; increase by ',I6) IDISP(1) = -2 190 IF (LP/=0) WRITE (LP,90002) 90002 FORMAT (' + Error return from MC23AD') 200 RETURN END SUBROUTINE MC23AD !_______________________________________________________________________ SUBROUTINE MC24AD(N,ICN,A,LICN,LENR,LENRL,W) ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. INTEGER :: LICN, N ! .. ! .. Array Arguments .. KPP_REAL :: A(LICN), W(N) INTEGER :: ICN(LICN), LENR(N), LENRL(N) ! .. ! .. Local Scalars .. KPP_REAL :: AMAXL, AMAXU, WROWL INTEGER :: I, J, J0, J1, J2, JJ ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX ! .. ! .. FIRST EXECUTABLE STATEMENT MA24AD ! .. AMAXL = ZERO W(1:N) = ZERO J0 = 1 DO 60 I = 1, N IF (LENR(I)==0) GOTO 60 J2 = J0 + LENR(I) - 1 IF (LENRL(I)==0) GOTO 30 ! Calculation of 1-norm of L. J1 = J0 + LENRL(I) - 1 WROWL = ZERO DO 20 JJ = J0, J1 20 WROWL = WROWL + ABS(A(JJ)) ! AMAXL is the maximum norm of columns of L so far found. AMAXL = MAX(AMAXL,WROWL) J0 = J1 + 1 ! Calculation of norms of columns of U(MAX-NORMS). 30 J0 = J0 + 1 IF (J0>J2) GOTO 50 DO 40 JJ = J0, J2 J = ICN(JJ) 40 W(J) = MAX(ABS(A(JJ)),W(J)) 50 J0 = J2 + 1 60 END DO ! AMAXU is set to maximum max-norm of columns of U. AMAXU = ZERO DO I = 1, N AMAXU = MAX(AMAXU,W(I)) END DO ! GROFAC is MAX U max-norm times MAX L 1-norm. W(1) = AMAXL*AMAXU RETURN END SUBROUTINE MC24AD !_______________________________________________________________________ SUBROUTINE MC19AD(N,NA,A,IRN,ICN,R,C,W) ! .. ! MC19A was altered to use same precision for R, C, ! and W as is used for other variables in program. ! .. ! REAL A(NA),R(N),C(N),W(N,5) ! R(I) is used to return log(scaling factor for row I). ! C(J) is used to return log(scaling factor for col J). ! W(I,1), W(I,2) hold row,col non-zero counts. ! W(J,3) holds - COL J LOG during execution. ! W(J,4) holds 2-iteration change in W(J,3). ! W(I,5) is used to save average element log for row I. ! INTEGER*2 IRN(NA), ICN(NA) ! IRN(K) gives row number of element in A(K). ! ICN(K) gives col number of element in A(K). ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. INTEGER :: N, NA ! .. ! .. Array Arguments .. KPP_REAL :: A(NA), C(N), R(N), W(N,5) INTEGER :: ICN(NA), IRN(NA) ! .. ! .. Local Scalars .. KPP_REAL :: E, E1, EM, Q, Q1, QM, S, S1, SM, SMIN, U, V INTEGER :: I, I1, I2, ITER, J, K, MAXIT ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, LOG, REAL ! .. ! .. Data Statements .. ! MAXIT is the maximal permitted number of iterations. ! SMIN is used in a convergence test on (residual norm)**2. DATA MAXIT/100/, SMIN/0.1/ ! .. ! .. FIRST EXECUTABLE STATEMENT MA19AD ! .. ! Check scalar data. IFAIL = 1 IF (N<1) GOTO 210 IFAIL = 2 ! IF (N > 32767)GOTO 230 IFAIL = 2 IFAIL = 0 ! Initialise for accumulation of sums and products. C(1:N) = ZERO R(1:N) = ZERO W(1:N,1:4) = ZERO IF (NA<=0) GOTO 220 DO 40 K = 1, NA U = ABS(A(K)) ! IF (U == ZERO) GOTO 30 IF (ABS(U-ZERO)<=ZERO) GOTO 40 U = LOG(U) I1 = IRN(K) I2 = ICN(K) IF (I1>=1 .AND. I1<=N .AND. I2>=1 .AND. I2<=N) GOTO 30 IF (LP>0) WRITE (LP,90000) K, I1, I2 90000 FORMAT (' MC19 error. Element ',I5,' is in row ',I5,' and column ', & I5) IFAIL = 3 GOTO 40 ! Count row/col non-zeros and compute rhs vectors. 30 W(I1,1) = W(I1,1) + 1. W(I2,2) = W(I2,2) + 1. R(I1) = R(I1) + U W(I2,3) = W(I2,3) + U 40 END DO IF (IFAIL==3) GOTO 210 ! Divide rhs by diagonal matrices. DO I = 1, N ! IF (W(I,1) == ZERO) W(I,1) = 1. IF (ABS(W(I,1))<=ZERO) W(I,1) = ONE R(I) = R(I)/W(I,1) ! SAVE R(I) FOR USE AT END. W(I,5) = R(I) ! IF (W(I,2) == ZERO) W(I,2) = 1. IF (ABS(W(I,2))<=ZERO) W(I,2) = ONE W(I,3) = W(I,3)/W(I,2) END DO ! SM = SMIN*FLOAT(NA) SM = SMIN*REAL(NA) ! Sweep to compute initial residual vector. DO 60 K = 1, NA ! IF (A(K) == ZERO) GOTO 80 IF (ABS(A(K))<=ZERO) GOTO 60 I = IRN(K) J = ICN(K) R(I) = R(I) - W(J,3)/W(I,1) 60 END DO ! Initialise iteration. E = ZERO Q = 1. S = ZERO DO I = 1, N S = S + W(I,1)*R(I)**2 END DO IF (S<=SM) GOTO 160 ! Iteration loop. DO ITER = 1, MAXIT ! Sweep through matrix to update residual vector. DO 80 K = 1, NA ! IF (A(K) == ZERO) GOTO 130 IF (ABS(A(K))<=ZERO) GOTO 80 I = ICN(K) J = IRN(K) C(I) = C(I) + R(J) 80 END DO S1 = S S = ZERO DO I = 1, N V = -C(I)/Q C(I) = V/W(I,2) S = S + V*C(I) END DO E1 = E E = Q*S/S1 Q = 1. - E IF (S<=SM) E = ZERO ! Update residual. DO I = 1, N R(I) = R(I)*E*W(I,1) END DO IF (S<=SM) GOTO 180 EM = E*E1 ! Sweep through matrix to update residual vector. DO 110 K = 1, NA ! IF (A(K) == ZERO) GOTO 152 IF (ABS(A(K))<=ZERO) GOTO 110 I = IRN(K) J = ICN(K) R(I) = R(I) + C(J) 110 END DO S1 = S S = ZERO DO I = 1, N V = -R(I)/Q R(I) = V/W(I,1) S = S + V*R(I) END DO E1 = E E = Q*S/S1 Q1 = Q Q = 1. - E ! Special fixup for last iteration. IF (S<=SM) Q = 1. ! Update colulm scaling powers. QM = Q*Q1 DO I = 1, N W(I,4) = (EM*W(I,4)+C(I))/QM W(I,3) = W(I,3) + W(I,4) END DO IF (S<=SM) GOTO 160 ! Update residual. DO I = 1, N C(I) = C(I)*E*W(I,2) END DO END DO 160 DO I = 1, N R(I) = R(I)*W(I,1) END DO ! Sweep through matrix to prepare to get row scaling powers. 180 DO 190 K = 1, NA ! IF (A(K) == ZERO) GOTO 200 IF (ABS(A(K))<=ZERO) GOTO 190 I = IRN(K) J = ICN(K) R(I) = R(I) + W(J,3) 190 END DO ! Final conversion to output values. DO I = 1, N R(I) = R(I)/W(I,1) - W(I,5) C(I) = -W(I,3) END DO GOTO 220 210 IF (LP>0) WRITE (LP,90001) IFAIL 90001 FORMAT (' Error return ',I2,' from MC19') 220 RETURN END SUBROUTINE MC19AD ! End of MA28 subroutines. !_______________________________________________________________________ ! Beginning of JACSP routines. ! Change Record: ! ST 09-01-05 ! Convert to F90 using Metcalf converter ! Trim trailing blanks using trimem.pl ! Convert arithmetic operators to F90 ! Replace R1MACH by EPSILON ! Run through nag tools suite ! ST 09-17-05 ! Delete RDUM and IDUM ! Change FCN argument list ! ST 09-18-05 ! Add subroutine DGROUPDS to define the IGP and JGP arrays for JACSP ! ST 09-20-05 ! Modify JACSP to produce JACSPDB for sparse, dense, and ! banded Jacobians !_______________________________________________________________________ SUBROUTINE JACSP(FCN,N,T,Y,F,FJAC,NRFJAC,YSCALE,FAC,IOPT,WK, & LWK,IWK,LIWK,MAXGRP,NGRP,JPNTR,INDROW) ! BEGIN PROLOGUE JACSP ! DATE WRITTEN 850415 ! CATEGORY NO. D4 ! KEYWORDS NUMERICAL DIFFERENCING, SPARSE JACOBIANS ! AUTHOR SALANE, DOUGLAS E., SANDIA NATIONAL LABORATORIES ! NUMERICAL MATHEMATICS DIVISION,1642 ! ALBUQUERQUE, NM 87185 ! SUBROUTINE JACSP USES FINITE DIFFERENCES TO COMPUTE THE JACOBIAN OF ! A SPARSE SYSTEM OF N EQUATIONS AND N UNKNOWNS. JACSP IS DESIGNED FOR ! USE IN NUMERICAL METHODS FOR SOLVING NONLINEAR PROBLEMS WHERE THE ! JACOBIAN IS EVALUATED REPEATEDLY AND OFTEN AT NEIGHBORING ARGUMENTS ! (E.G., NEWTON'S METHOD OR A BDF METHOD FOR SOVING STIFF ORDINARY ! DIFFERENTIAL EQUATIONS). JACSP IS INTENDED FOR APPLICATIONS IN WHICH ! THE REQUIRED JACOBIANS ARE LARGE AND SPARSE. ! TAKING ADVANTAGE OF SPARSITY. ! SUBROUTINE JACSP TAKES ADVANTAGE OF THE SPARSITY OF A MATRIX TO REDUCE ! THE NUMBER OF FUNCTION EVALUATIONS REQUIRED TO COMPUTE THE JACOBIAN. ! TO REALIZE THIS ADVANTAGE, THE USER MUST PROVIDE JACSP WITH A COLUMN ! GROUPING. THIS MEANS THE USER MUST ASSIGN COLUMNS OF THE JACOBIAN TO ! MUTUALLY EXCLUSIVE GROUPS BASED ON THE SPARSITY OF THE COLUMNS.THE ! DIFFERENCES REQUIRED TO COMPUTE THE NONZERO ELEMENTS IN ALL COLUMNS IN ! A GROUP ARE FORMED USING ONLY ONE ADDITIONAL FUNCTION EVALUATION. FOR ! MORE DETAILS, THE USER IS REFERRED TO THE REPORT BY D.E. SALANE AND ! L.F. SHAMPINE (REF. 1). ! THE SUBROUTINE DVDSM (REF 2.) IS THE WAY MOST USERS WILL DETERMINE A ! COLUMN GROUPING FOR JACSP. THE USE OF DSM AND JACSP IS DESCRIBED ! LATER IN THE PROLOGUE. ! STORAGE. ! JACSP REQUIRES THE USER TO PROVIDE A SPARSE DATA STRUCTURE FOR THE ! JACOBIAN TO BE COMPUTED. JACSP REQUIRES THE USER TO SPECIFY THE ! INDICES OF THE NONZERO ELEMENTS IN A COLUMN PACKED SPARSE DATA ! STRUCTURE (SEE REF.1). THE SUBROUTINE DVDSM( REF 2.) CAN BE USED TO ! ESTABLISH THE SPARSE DATA STRUCTURE REQUIRED BY JACSP. THE USE OF ! JACSP AND DSM IS DESCRIBED LATER IN THE PROLOGUE. ! ON OUTPUT, SUBROUTINE JACSP WILL RETURN THE JACOBIAN IN ANY ONE OF ! THE FOLLOWING THREE FORMATS SPECIFIED BY THE USER. ! (1) FULL STORAGE FORMAT.......THE COMPUTED JACOBIAN IS STORED IN ! AN ARRAY WHOSE ROW AND COLUMN DIMENSIONS ARE THE NUMBER OF ! EQUATIONS. ! (2) BANDED STORAGE FORMAT.....THE COMPUTED MATRIX IS STORED IN A TWO ! DIMENSIONAL ARRAY WHOSE ROW DIMENSION IS ! 2*(NUMBER OF LOWER DIAGONALS) + (THE NUMBER OF UPPER DIAGONALS) ! + 1. THE COLUMN DIMENSION OF THIS ARRAY IS THE NUMBER OF ! EQUATIONS. THIS STORAGE FORMAT IS COMPATIBLE WITH THE LINPACK ! GENERAL BAND MATRIX EQUATION SOLVER. ! (3) SPARSE STORAGE FORMAT.....THE COMPUTED JACOBIAN IS STORED IN A ! ONE DIMENSIONAL ARRAY WHOSE LENGTH IS THE NUMBER OF NONZERO ! ELEMENTS IN THE JACOBIAN. ! DESCRIPTION ! SUBROUTINE PARAMETERS ! FCN()......A USER-PROVIDED FUNCTION (SEE SUBROUTINE DESCRIPTION). ! N..........THE NUMBER OF EQUATIONS. ! T..........A SCALAR VARIABLE. T IS PROVIDED SO USERS CAN PASS THE ! VALUE OF AN INDEPENDENT VARIALBE TO THE FUNCTION ! EVALUATION ROUTINE. ! Y(*).......AN ARRAY OF DIMENSION N. THE POINT AT WHICH THE ! JACOBIAN IS TO BE EVALUATED. ! F(*).......AN ARRAY OF DIMENSION N. THE EQUATIONS EVALUATED AT ! THE POINT Y. ! FJAC(*,*)..AN ARRAY OF WHOSE DIMENSIONS DEPEND ON THE STORAGE ! FORMAT SELECTED BY THE USER. THE ROW AND COLUMN DIMENSIONS ARE ! SET BY THE USER. IF THE SPARSE MATRIX FORMAT IS SELECTED, FJAC ! SHOULD BE TREATED AS A ONE DIMENSIONAL ARRAY BY THE CALLING ! PROGRAM. FOR FURTHER DETAILS, SEE THE DESCRIPTION OF THE ! PARAMETER IOPT(1) WHICH CONTROLS THE STORAGE FORMAT. ! NOTE THAT IF THE BANDED OR FULL OPTION IS USED,THE USER SHOULD ! ZERO OUT THOSE POSITIONS OF FJAC THAT WILL NOT BE ACCESSED BY ! JACSP. JACSP DOES NOT ZERO OUT THE MATRIX FJAC BEFORE ! COMPUTING THE JACOBIAN. POSITIONS OF FJAC THAT ARE NOT ASSIGNED ! VALUES BY JACSP WILL BE THE SAME ON EXIT AS ON ENTRY TO JACSP. ! NRFJAC.....THE NUMBER OF ROWS IN FJAC AND THE LEADING DIMENSION ! OF FJAC (SEE IOPT(1)). ! NCFJAC.....THE NUMBER OF COLUMNS IN FJAC AND THE COLUMN DIMENSION ! OF FJAC (SEE IOPT(1)). ! YSCALE(*)..AN ARRAY OF DIMENSION N. YSCALE(I) CONTAINS A ! REPRESENTATIVE MAGNITUDE FOR Y(I). YSCALE(I) MUST BE POSITIVE. ! YSCALE IS AN OPTIONAL FEATURE OF THE ROUTINE. IF THE USER DOES ! NOT WISH TO PROVIDE YSCALE, IT CAN BE TREATED AS A DUMMY SCALAR ! VARIABLE (SEE IOPT(3)). ! FAC(*).....AN ARRAY OF DIMENSION N. FAC CONTAINS A PERCENTAGE FOR ! USE IN COMPUTING THE INCREMENT. ! THE NORMAL WAY TO USE THE CODE IS TO LET JACSP ADJUST FAC VALUES. ! IN THIS CASE FAC IS INITIALIZED BY JACSP. ALSO, THE USER MUST ! NOT ALTER FAC VALUES BETWEEN CALLS TO JACSP. ! THE USER MAY PROVIDE FAC VALUES IF DESIRED (SEE IOPT(4) FOR ! DETAILS). IF THE USER PROVIDES FAC VALUES, FAC(I) SHOULD BE ! SHOULD BE SET TO A VALUE BETWEEN O AND 1. JACSP WILL NOT PERMIT ! FAC(I) TO BE SET TO A VALUE THAT RESULTS IN TOO SMALL AN ! INCREMENT. JACSP ENSURES THAT ! FACMIN <= FAC(I) <= FACMAX. ! FOR FURTHER DETAILS ON FACMIN AND FACMAX SEE ! THE REPORT(REF.3). ! IOPT(*)....AN INTEGER ARRAY OF LENGTH 5 FOR USER SELECTED OPTIONS. ! IOPT(1) CONTROLS THE STORAGE FORMAT. ! IOPT(1) = 0 INDICATES FULL STORAGE FORMAT. SET BOTH ! NRFJAC = N AMD NCFJAC = N. ! IOPT(1) = 1 INDICATES BANDED STORAGE FORMAT. SET ! NRFJAC = 2 * ML + MU + 1 WHERE ! ML = NUMBER OF SUB-DIAGONALS BELOW THE MAIN DIAGONAL AND ! MU = NUMBER OF SUPER-DIAGONALS ABOVE THE MAIN DIAGONAL. ! SET NCFJAC = N. ! IOPT(1) = 2 INDICATES SPARSE STORAGE FORMAT. SET ! NRFJAC = TO THE NUMBER OF NONZEROS IN THE JACOBIAN AND ! SET NCFJAC = 1. ! IOPT(2) MUST BE SET TO THE BANDWIDTH OF THE MATRIX. ! IOPT(2) NEED ONLY BE PROVIDED IF BANDED STORAGE ! FORMAT IS REQUESTED(I.E., IOPT(1) = 1). ! IOPT(3) ALLOWS THE USER TO PROVIDE TYPICAL VALUES ! TO BE USED IN COMPUTING INCREMENTS FOR DIFFERENCING. ! IOPT(3) = 0 INDICATES Y VALUES ARE USED IN COMPUTING ! INCREMENTS. IF IOPT(3) = 0, NO STORAGE IS REQUIRED FOR ! YSCALE AND IT MAY BE TREATED AS A DUMMY VARIABLE. ! IOPT(3) = 1 INDICATES THAT YSCALE VALUES ARE TO BE USED. ! IF IOPT(3) = 1, THE USER MUST PROVIDE AN ARRAY OF NONZERO ! VALUES IN YSCALE. ! IOPT(4) ALLOWS THE USER TO PROVIDE THE VALUES USED ! IN THE FAC ARRAY TO COMPUTE INCREMENTS FOR DIFFERENCING. ! IF IOPT(4) = 0, EACH COMPONENT OF FAC IS ! SET TO THE SQUARE ROOT OF MACHINE UNIT ROUNDOFF ON THE ! FIRST CALL TO JACSP. IOPT(4) IS SET TO ONE ON RETURN. ! IF IOPT(4) = 1, EACH COMPONENT OF FAC MUST BE SET ! BY THE CALLING ROUTINE. UNLESS THE USER WISHES TO ! INITIALIZE FAC, THE FAC ARRAY SHOULD NOT BE ALTERED ! BETWEEN SUBSEQUENT CALLS TO JACSP. ALSO, THE USER ! SHOULD NOT CHANGE THE VALUE OF IOPT(4) RETURNED BY ! JACSP. ! IOPT(5) IS NOT USED IN JACSP. ! WK(*)......A WORK ARRAY OF DIMENSION AT LEAST 3*N ! LWK........THE LENGTH OF THE WORK ARRAY. LWK IS AT LEAST 3*N. ! IWK(*)...AN INTEGER ARRAY OF LENGTH LIWK = 50 + N WHICH GIVES ! DIAGNOSTIC INFORMATION IN POSITIONS 1 THROUGH 50. POSITIONS 51 ! THROUGH 50 + N ARE USED AS INTEGER WORKSPACE. ! IWK(1) GIVES THE NUMBER OF TIMES THE INCREMENT FOR DIFFERENCING ! (DEL) WAS COMPUTED AND HAD TO BE INCREASED BECAUSE (Y(JCOL)+DEL) ! -Y(JCOL)) WAS TOO SMALL RELATIVE TO Y(JCOL) OR YSCALE(JCOL). ! IWK(2) GIVES THE NUMBER OF COLUMNS IN WHICH THREE ATTEMPTS WERE ! MADE TO INCREASE A PERCENTAGE FACTOR FOR DIFFERENCING (I.E., A ! COMPONENT IN THE FAC ARRAY) BUT THE COMPUTED DEL REMAINED ! UNACCEPTABLY SMALL RELATIVE TO Y(JCOL) OR YSCALE(JCOL). IN SUCH ! CASES THE PERCENTAGE FACTOR IS SET TO THE SQUARE ROOT OF THE UNIT ! ROUNDOFF OF THE MACHINE. THE FIRST 10 COLUMNS ARE GIVEN IN ! IWK(21),...,IWK(30). ! IWK(3) GIVES THE NUMBER OF COLUMNS IN WHICH THE COMPUTED DEL WAS ! ZERO TO MACHINE PRECISION BECAUSE Y(JCOL) OR YSCALE(JCOL) WAS ! ZERO. IN SUCH CASES DEL IS SET TO THE SQUARE ROOT OF THE UNIT ! ROUNDOFF. ! IWK(4) GIVES THE NUMBER OF COLUMNS WHICH HAD TO BE RECOMPUTED ! BECAUSE THE LARGEST DIFFERENCE FORMED IN THE COLUMN WAS VERY ! CLOSE TO ZERO RELATIVE TO SCALE WHERE ! SCALE = MAX(F(Y),F(Y+DEL)) ! I I ! AND I DENOTES THE ROW INDEX OF THE LARGEST DIFFERENCE IN THE ! COLUMN CURRENTLY BEING PROCESSED. IWK(31),...,IWK(40) GIVES THE ! FIRST 10 OF THESE COLUMNS. ! IWK(5) GIVES THE NUMBER OF COLUMNS WHOSE LARGEST DIFFERENCE IS ! CLOSE TO ZERO RELATIVE TO SCALE AFTER THE COLUMN HAS BEEN ! RECOMPUTED. THE FIRST 10 OF THESE COLUMNS ARE GIVEN IN POSITIONS ! IWK(41)...IWK(50). ! IWK(6) GIVES THE NUMBER OF TIMES SCALE INFORMATION WAS NOT ! AVAILABLE FOR USE IN THE ROUNDOFF AND TRUNCATION ERROR TESTS. ! THIS OCCURS WHEN ! MIN(F(Y),F(Y+DEL)) = 0. ! I I ! WHERE I IS THE INDEX OF THE LARGEST DIFFERENCE FOR THE COLUMN ! CURRENTLY BEING PROCESSED. ! IWK(7) GIVES THE NUMBER OF TIMES THE FUNCTION EVALUATION ROUTINE ! WAS CALLED. ! IWK(8) GIVES THE NUMBER OF TIMES A COMPONENT OF THE FAC ARRAY WAS ! REDUCED BECAUSE CHANGES IN FUNCTION VALUES WERE LARGE AND EXCESS ! TRUNCATION ERROR WAS SUSPECTED. IWK(11),...,IWK(20) GIVES THE FIRST ! 10 OF THESE COLUMNS. ! IWK(9) AND IWK(10) ARE NOT USED IN JACSP. ! LIWK.....THE LENGTH OF THE ARRAY IWK. LIWK = 50 + N. ! THE FOLLOWING PARAMETERS MAY BE PROVIDED BY THE USER OR ! INITIALIZED BY THE SUBROUTINE DVDSM (SEE LONG DESCRIPTION ! SECTION OF THE PROLOGUE). ! PARAMETERS CONTAINING COLUMN GROUPING: ! MAXGRP.....THE NUMBER OF DIFFERENT GROUPS TO WHICH THE COLUMNS ! HAVE BEEN ASSIGNED. ! NGRP(*)....AN ARRAY OF LENGTH N THAT CONTAINS THE COLUMN GROUPING. ! NGRP(I) IS THE GROUP TO WHICH THE I-TH COLUMN HAS BEEN ! ASSIGNED. ! (SEE USE OF DSM AND JACSP FOR DETERMINING MAXGRP AND NGRP) ! PARAMETERS CONTAINING THE SPARSE DATA STRUCTURE: ! JPNTR(*)...AN ARRAY OF LENGTH N+1 THAT CONTAINS POINTERS TO ! THE ROW INDICES IN INDROW (SEE INDROW). ! INDROW(*)..AN ARRAY WHOSE LENGTH IS THE NUMBER OF NONZERO ELEMENTS ! IN THE JACOBIAN. INDROW CONTAINS THE ROW INDICES ! STORED IN COLUMN PACKED FORMAT. IN OTHER WORDS, THE ! ROW INDICES OF THE NONZERO ELEMENTS OF A GIVEN ! COLUMN OF THE JACOBIAN ARE STORED CONTIGUOUSLY IN ! INDROW. JPNTR(JCOL) POINTS TO THE ROW INDEX OF THE FIRST ! NONZERO ELEMENT IN THE COLUMN JCOL. JPNTR(JCOL+1) - 1 ! POINTS TO THE ROW INDEX OF THE LAST NONZERO ELEMENT IN ! THE COLUMN JCOL. ! (SEE USE OF DSM AND JACSP FOR DETERMINING INDROW AND JPNTR) ! REQUIRED SUBROUTINES: SUBROUTINE FCN(N,T,Y,F) ! T......AN INDEPENDENT SCALAR VARIABLE WHICH MAY BE USED ! IN EVALUATING F(E.G., F(Y(T),T)). ! Y(*)...AN ARRAY OF DIMENSION N WHICH CONTAINS THE POINT AT ! WHICH THE EQUATIONS ARE TO BE EVALUATED. ! F(*)...AN ARRAY OF DIMENSION N WHICH ON RETURN FROM FCN ! CONTAINS THE EQUATIONS EVALUATED AT Y. ! LONG DESCRIPTION ! ROUNDOFF AND TRUNCATION ERRORS. ! SUBROUTINE JACSP TAKES ADVANTAGE OF THE WAY IN WHICH THE JACOBIAN ! IS EVALUATED TO ADJUST INCREMENTS FOR DIFFERENCING TO CONTROL ! ROUNDOFF AND TRUNCATION ERRORS. THE ROUTINE SELDOM REQUIRES MORE ! THAN ONE ADDITIONAL FUNCTION EVALUATION TO COMPUTE A COLUMN OF THE ! JACOBIAN. ALSO, THE ROUTINE RETURNS A VARIETY OF ERROR DIAGNOSTICS ! TO WARN USERS WHEN COMPUTED DERIVATIVES MAY NOT BE ACCURATE. ! WARNING: JACSP CAN NOT GUARANTEE THE ACCURACY OF THE COMPUTED ! DERIVATIVES. IN ORDER O SAVE ON FUNCTION EVALUATIONS, HEURISTIC ! TECNIQUES FOR INCREMENT ADJUSTMENT AND SAFEGUARDING INCREMENTS ARE ! USED. THESE USUALLY WORK WELL. ! WARNING: SOME OF THE DIAGNOSTICS RETURNED CAN ONLY BE INTERPRETED ! WITH A DETAILED KNOWLEDGE OF THE ROUTINE. NEVERTHELESS, THEY ARE ! PROVIDED TO GIVE USERS FULL ACCESS TO THE INFORMATION PRODUCED BY ! THE SUBROUTINE. ! USE OF DSM AND JACSP. ! SUBROUTINE DVDSM CAN BE USED TO DETERMINE THE COLUMN GROUPING (MAXGRP ! AND NGRP(*)) AND THE SPARSE DATA STRUCTURE VARIABLES (JPNTR(*) AND ! INDROW(*)). THE USER CAN CALL DVDSM ONCE TO INITIALIZE ! MAXGRP,NGRP,JPNTR AND INDROW. JACSP MAY THEN BE CALLED REPEATEDLY TO ! EVALUATE THE JACOBIAN. THE FOLLOWING ARE THE IMPORTANT VARIABLES IN ! THE DSM CALLING SEQUENCE. ! SUBROUTINE DVDSM(...,INDROW,INDCOL,NGRP,MAXGRP,..,JPNTR,...) ! ON INPUT, THE USER MUST PROVIDE DSM WITH THE INTEGER ARRAYS INDROW AND ! INDCOL. THE PAIR ! (INDROW(I),INDCOL(I)) ! PROVIDES THE INDEX OF A NONZERO ELEMENT OF THE JACOBIAN. THE LENGTH OF ! INDROW AND INDCOL IS THE NUMBER OF NONZERO ELEMENTS IN THE JACOBIAN. ! NO ORDERING OF THE INDICES FOR NONZERO ELEMENTS IS REQUIRED IN THE ! ARRAYS INDROW AND INDCOL. ! ON RETURN FROM DSM, MAXGRP,NGRP,INDROW,JPNTR ARE INITIALIZED ! FOR INPUT TO JACSP. THE USER MUST NOT CHANGE MAXGRP,NGRP,JPNTR OR ! INDROW AFTER CALLING DSM. ! WE REFER THE READER TO THE IN CODE DOCUMENTATION FOR DSM OR THE REPORT ! BY MORE AND COLEMAN (REF 2.) FOR FURTHER DETAILS. ! REFERENCES ! (1) D.E. SALANE AND L. F. SHAMPINE ! "AN ECONOMICAL AND EFFICIENT ROUTINE FOR COMPUTING ! SPARSE JACOBIANS", REPORT NO. SAND85-0977, SANDIA NATIONAL ! LABORATORIES, ALBUQUERQUE,NM,87185. ! (2) T.F. COLEMAN AND J.J. MORE ! "SOFTWARE FOR ESTIMATING SPARSE JACOBIAN MATRICES" ACM TOMS, ! V10.,N0.3,SEPT. 1984. ! (3) D.E. SALANE AND L. F. SHAMPINE ! "THREE ADAPTIVE ROUTINES FOR FORMING JACOBIANS NUMERICALLY," ! REPORT NO. SAND86- ****, SANDIA NATIONAL LABORATORIES, ! ALBUQUERQUE, NM, 87185. ! REQUIRED FORTRAN INTRINSIC FUNCTIONS: MAX,MIN,ABS,SIGN ! MACHINE DEPENDENT CONSTANT: U (MACHINE UNIT ROUNDOFF) ! JACSP SETS THE REQUIRED MACHINE CONSTANT USING THE F90 ! INTRINSIC EPSILON. ! END PROLOGUE JACSP IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: WP = KIND(0.0D0) ! .. ! .. Scalar Arguments .. KPP_REAL :: T INTEGER :: LIWK, LWK, MAXGRP, N, NRFJAC ! .. ! .. Array Arguments .. KPP_REAL :: F(N), FAC(N), FJAC(NRFJAC,*), WK(LWK), Y(N), YSCALE(*) INTEGER :: INDROW(*), IOPT(5), IWK(LIWK), JPNTR(*), NGRP(N) ! .. ! .. Subroutine Arguments .. EXTERNAL FCN ! .. ! .. Local Scalars .. KPP_REAL :: ADIFF, AY, DEL, DELM, DFMJ, DIFF, DMAX, EXPFMN, FACMAX, & FACMIN, FJACL, FMJ, ONE, P125, P25, P75, P875, PERT, RDEL, RMNFDF, & RMXFDF, SDF, SF, SGN, T1, T2, U, U3QRT, U7EGT, UEGT, UMEGT, UQRT, & USQT, ZERO INTEGER :: IDXL, IDXU, IFLAG1, IFLAG2, IRCMP, IRDEL, IROW, IROWB, & IROWMX, ITRY, J, JCOL, KT1, KT2, KT3, KT4, KT5, L, NID1, NID2, NID3, & NID4, NID5, NID6, NIFAC, NT2, NUMGRP ! .. ! .. Intrinsic Functions .. ! INTRINSIC ABS, EPSILON, KIND, MAX, MIN, SIGN, SQRT INTRINSIC ABS, EPSILON, MAX, MIN, SIGN, SQRT ! .. ! .. Data Statements .. DATA PERT/2.0E+0_dp/, FACMAX/1.E-1_dp/, EXPFMN/.75E+0_dp/ DATA ONE/1.0E0_dp/, ZERO/0.0E0_dp/ DATA P125/.125E+0_dp/, P25/.25E+0_dp/, P75/.75E+0_dp/, P875/.875E+0_dp/ DATA NIFAC/3/, NID1/10/, NID2/20/, NID3/30/, NID4/40/, NID5/50/ ! .. ! COMPUTE ALGORITHM AND MACHINE CONSTANTS. ! .. ! .. FIRST EXECUTABLE STATEMENT JACSP ! .. U = EPSILON(ONE) USQT = SQRT(U) UEGT = U**P125 UMEGT = ONE/UEGT UQRT = U**P25 U3QRT = U**P75 U7EGT = U**P875 FACMIN = U**EXPFMN IF (IOPT(4) == 0) THEN IOPT(4) = 1 DO 10 J = 1, N FAC(J) = USQT 10 CONTINUE END IF DO 20 J = 1, 50 IWK(J) = 0 20 CONTINUE KT1 = NID1 KT2 = NID2 KT3 = NID3 KT4 = NID4 KT5 = NID5 NID6 = LIWK NT2 = 2*N DO NUMGRP = 1, MAXGRP ! COMPUTE AND SAVE THE INCREMENTS FOR THE COLUMNS IN GROUP NUMGRP. IRCMP = 0 ITRY = 0 DO 30 J = NID5 + 1, NID6 IWK(J) = 0 30 CONTINUE 40 CONTINUE DO JCOL = 1, N IF (NGRP(JCOL) == NUMGRP) THEN WK(N+JCOL) = Y(JCOL) ! COMPUTE DEL. IF DEL IS TOO SMALL INCREASE FAC(JCOL) AND RECOMPUTE ! DEL. NIFAC ATTEMPTS ARE MADE TO INCREASE FAC(JCOL) AND FIND AN ! APPROPRIATE DEL. IF DEL CANT BE FOUND IN THIS MANNER, DEL IS COMPUTED ! WITH FAC(JCOL) SET TO THE SQUARE ROOT OF THE MACHINE PRECISION (USQT). ! IF DEL IS ZERO TO MACHINE PRECISION BECAUSE Y(JCOL) IS ZERO OR ! YSCALE(JCOL) IS ZERO, DEL IS SET TO USQT. SGN = SIGN(ONE,F(JCOL)) IRDEL = 0 IF (IOPT(3) == 1) THEN AY = ABS(YSCALE(JCOL)) ELSE AY = ABS(Y(JCOL)) END IF DELM = U7EGT*AY DO 50 J = 1, NIFAC DEL = FAC(JCOL)*AY*SGN ! IF (DEL == ZERO) THEN IF (ABS(DEL) <= ZERO) THEN DEL = USQT*SGN IF (ITRY == 0) IWK(3) = IWK(3) + 1 END IF T1 = Y(JCOL) + DEL DEL = T1 - Y(JCOL) IF (ABS(DEL) < DELM) THEN IF (J >= NIFAC) GOTO 50 IF (IRDEL == 0) THEN IRDEL = 1 IWK(1) = IWK(1) + 1 END IF T1 = FAC(JCOL)*UMEGT FAC(JCOL) = MIN(T1,FACMAX) ELSE GOTO 60 END IF 50 END DO FAC(JCOL) = USQT DEL = USQT*AY*SGN IWK(2) = IWK(2) + 1 IF (KT2 < NID3) THEN KT2 = KT2 + 1 IWK(KT2) = JCOL END IF 60 CONTINUE WK(NT2+JCOL) = DEL Y(JCOL) = Y(JCOL) + DEL END IF END DO IWK(7) = IWK(7) + 1 CALL FCN(N,T,Y,WK) DO JCOL = 1, N IF (NGRP(JCOL) == NUMGRP) Y(JCOL) = WK(N+JCOL) END DO ! COMPUTE THE JACOBIAN ENTRIES FOR ALL COLUMNS IN NUMGRP. ! STORE ENTRIES ACCORDING TO SELECTED STORAGE FORMAT. ! USE LARGEST ELEMENTS IN A COLUMN TO DETERMINE SCALING ! INFORMATION FOR ROUNDOFF AND TRUNCATION ERROR TESTS. DO JCOL = 1, N IF (NGRP(JCOL) == NUMGRP) THEN IDXL = JPNTR(JCOL) IDXU = JPNTR(JCOL+1) - 1 DMAX = ZERO RDEL = ONE/WK(NT2+JCOL) IROWMX = 1 DO L = IDXL, IDXU IROW = INDROW(L) DIFF = WK(IROW) - F(IROW) ADIFF = ABS(DIFF) IF (ADIFF >= DMAX) THEN IROWMX = IROW DMAX = ADIFF SF = F(IROW) SDF = WK(IROW) END IF FJACL = DIFF*RDEL IF (ITRY == 1) WK(IROW) = FJACL IF (IOPT(1) == 0) THEN IF (ITRY == 1) WK(IROW+N) = FJAC(IROW,JCOL) FJAC(IROW,JCOL) = FJACL END IF IF (IOPT(1) == 1) THEN IROWB = IROW - JCOL + IOPT(2) IF (ITRY == 1) WK(IROW+N) = FJAC(IROWB,JCOL) FJAC(IROWB,JCOL) = FJACL END IF IF (IOPT(1) == 2) THEN IF (ITRY == 1) WK(IROW+N) = FJAC(L,1) FJAC(L,1) = FJACL END IF END DO ! IF A COLUMN IS BEING RECOMPUTED (ITRY=1),THIS SECTION OF THE ! CODE PERFORMS AN EXTRAPOLATION TEST TO ENABLE THE CODE TO ! COMPUTE SMALL DERIVATIVES MORE ACCURATELY. THIS TEST IS ONLY ! PERFORMED ON THOSE COLUMNS WHOSE LARGEST DIFFERENCE IS CLOSE ! TO ZERO RELATIVE TO SCALE. IF (ITRY == 1) THEN IFLAG1 = 0 IFLAG2 = 0 DO 100 J = NID5 + 1, NID6 IF (IWK(J) == JCOL) IFLAG1 = 1 100 CONTINUE IF (IFLAG1 == 1) THEN IFLAG1 = 0 T1 = WK(IROWMX+N) T2 = WK(IROWMX)*FAC(JCOL) IF (ABS(T2) < ABS(T1)*PERT) IFLAG2 = 1 END IF IF (IFLAG2 == 1) THEN IFLAG2 = 0 T1 = FAC(JCOL)*FAC(JCOL) FAC(JCOL) = MAX(T1,FACMIN) DO L = IDXL, IDXU IROW = INDROW(L) FJACL = WK(IROW+N) IF (IOPT(1) == 0) FJAC(IROW,JCOL) = FJACL IF (IOPT(1) == 1) THEN IROWB = IROW - JCOL + IOPT(2) FJAC(IROWB,JCOL) = FJACL END IF IF (IOPT(1) == 2) FJAC(L,1) = FJACL END DO END IF END IF FMJ = ABS(SF) DFMJ = ABS(SDF) RMXFDF = MAX(FMJ,DFMJ) RMNFDF = MIN(FMJ,DFMJ) ! IF SCALE INFORMATION IS NOT AVAILABLE, PERFORM NO ROUNDOFF ! OR TRUNCATION ERROR TESTS. IF THE EXTRAPOLATION TEST HAS ! CAUSED FAC(JCOL) TO BE RESET TO ITS PREVIOUS VALUE (IAJAC=1) ! THEN NO FURTHER ROUNDOFF OR TRUNCATION ERROR TESTS ARE ! PERFORMED. ! IF (RMNFDF/=ZERO) THEN IF (ABS(RMNFDF) > ZERO) THEN ! TEST FOR POSSIBLE ROUNDOFF ERROR (FIRST TEST) ! AND ALSO FOR POSSIBLE SERIOUS ROUNDOFF ERROR (SECOND TEST). IF (DMAX <= (U3QRT*RMXFDF)) THEN IF (DMAX <= (U7EGT*RMXFDF)) THEN IF (ITRY == 0) THEN T1 = SQRT(FAC(JCOL)) FAC(JCOL) = MIN(T1,FACMAX) IRCMP = 1 IF (KT5 < NID6) THEN KT5 = KT5 + 1 IWK(KT5) = JCOL END IF IWK(4) = IWK(4) + 1 IF (KT3 < NID4) THEN KT3 = KT3 + 1 IWK(KT3) = JCOL END IF ELSE IWK(5) = IWK(5) + 1 IF (KT4 < NID5) THEN KT4 = KT4 + 1 IWK(KT4) = JCOL END IF END IF ELSE T1 = UMEGT*FAC(JCOL) FAC(JCOL) = MIN(T1,FACMAX) END IF END IF ! TEST FOR POSSIBLE TRUNCATION ERROR. IF (DMAX > UQRT*RMXFDF) THEN T1 = FAC(JCOL)*UEGT FAC(JCOL) = MAX(T1,FACMIN) IWK(8) = IWK(8) + 1 IF (KT1 < NID2) THEN KT1 = KT1 + 1 IWK(KT1) = JCOL END IF END IF ELSE IWK(6) = IWK(6) + 1 END IF END IF END DO ! IF SERIOUS ROUNDOFF ERROR IS SUSPECTED, RECOMPUTE ALL ! COLUMNS IN GROUP NUMGRP. IF (IRCMP == 1) THEN IRCMP = 0 ITRY = 1 GOTO 40 END IF ITRY = 0 END DO RETURN END SUBROUTINE JACSP !_______________________________________________________________________ SUBROUTINE DEGR(N,INDROW,JPNTR,INDCOL,IPNTR,NDEG,IWA) ! GIVEN THE SPARSITY PATTERN OF AN M BY N MATRIX A, ! THIS SUBROUTINE DETERMINES THE DEGREE SEQUENCE FOR ! THE INTERSECTION GRAPH OF THE COLUMNS OF A. ! IN GRAPH-THEORY TERMINOLOGY, THE INTERSECTION GRAPH OF ! THE COLUMNS OF A IS THE LOOPLESS GRAPH G WITH VERTICES ! A(J), J = 1,2,...,N WHERE A(J) IS THE J-TH COLUMN OF A ! AND WITH EDGE (A(I),A(J)) IF AND ONLY IF COLUMNS I AND J ! HAVE A NON-ZERO IN THE SAME ROW POSITION. ! NOTE THAT THE VALUE OF M IS NOT NEEDED BY DEGR AND IS ! THEREFORE NOT PRESENT IN THE SUBROUTINE STATEMENT. ! THE SUBROUTINE STATEMENT IS ! SUBROUTINE DEGR(N,INDROW,JPNTR,INDCOL,IPNTR,NDEG,IWA) ! WHERE ! N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER ! OF COLUMNS OF A. ! INDROW IS AN INTEGER INPUT ARRAY WHICH CONTAINS THE ROW ! INDICES FOR THE NON-ZEROES IN THE MATRIX A. ! JPNTR IS AN INTEGER INPUT ARRAY OF LENGTH N + 1 WHICH ! SPECIFIES THE LOCATIONS OF THE ROW INDICES IN INDROW. ! THE ROW INDICES FOR COLUMN J ARE ! INDROW(K), K = JPNTR(J),...,JPNTR(J+1)-1. ! NOTE THAT JPNTR(N+1)-1 IS THEN THE NUMBER OF NON-ZERO ! ELEMENTS OF THE MATRIX A. ! INDCOL IS AN INTEGER INPUT ARRAY WHICH CONTAINS THE ! COLUMN INDICES FOR THE NON-ZEROES IN THE MATRIX A. ! IPNTR IS AN INTEGER INPUT ARRAY OF LENGTH M + 1 WHICH ! SPECIFIES THE LOCATIONS OF THE COLUMN INDICES IN INDCOL. ! THE COLUMN INDICES FOR ROW I ARE ! INDCOL(K), K = IPNTR(I),...,IPNTR(I+1)-1. ! NOTE THAT IPNTR(M+1)-1 IS THEN THE NUMBER OF NON-ZERO ! ELEMENTS OF THE MATRIX A. ! NDEG IS AN INTEGER OUTPUT ARRAY OF LENGTH N WHICH ! SPECIFIES THE DEGREE SEQUENCE. THE DEGREE OF THE ! J-TH COLUMN OF A IS NDEG(J). ! IWA IS AN INTEGER WORK ARRAY OF LENGTH N. ! ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. JULY 1983. ! THOMAS F. COLEMAN, BURTON S. GARBOW, JORGE J. MORE' IMPLICIT NONE ! .. Scalar Arguments .. INTEGER :: N ! .. ! .. Array Arguments .. INTEGER :: INDCOL(*), INDROW(*), IPNTR(*), IWA(N), JPNTR(N+1), NDEG(N) ! .. ! .. Local Scalars .. INTEGER :: IC, IP, IR, JCOL, JP ! .. ! .. FIRST EXECUTABLE STATEMENT DEGR ! .. ! INITIALIZATION BLOCK. NDEG(1:N) = 0 IWA(1:N) = 0 ! COMPUTE THE DEGREE SEQUENCE BY DETERMINING THE CONTRIBUTIONS ! TO THE DEGREES FROM THE CURRENT (JCOL) COLUMN AND FURTHER ! COLUMNS WHICH HAVE NOT YET BEEN CONSIDERED. DO JCOL = 2, N IWA(JCOL) = N ! DETERMINE ALL POSITIONS (IR,JCOL) WHICH CORRESPOND ! TO NON-ZEROES IN THE MATRIX. DO JP = JPNTR(JCOL), JPNTR(JCOL+1) - 1 IR = INDROW(JP) ! FOR EACH ROW IR, DETERMINE ALL POSITIONS (IR,IC) ! WHICH CORRESPOND TO NON-ZEROES IN THE MATRIX. DO IP = IPNTR(IR), IPNTR(IR+1) - 1 IC = INDCOL(IP) ! ARRAY IWA MARKS COLUMNS WHICH HAVE CONTRIBUTED TO ! THE DEGREE COUNT OF COLUMN JCOL. UPDATE THE DEGREE ! COUNTS OF THESE COLUMNS AS WELL AS COLUMN JCOL. IF (IWA(IC) < JCOL) THEN IWA(IC) = JCOL NDEG(IC) = NDEG(IC) + 1 NDEG(JCOL) = NDEG(JCOL) + 1 END IF END DO END DO END DO RETURN END SUBROUTINE DEGR !_______________________________________________________________________ SUBROUTINE IDO(M,N,INDROW,JPNTR,INDCOL,IPNTR,NDEG,LIST,MAXCLQ, & IWA1,IWA2,IWA3,IWA4) ! SUBROUTINE IDO ! GIVEN THE SPARSITY PATTERN OF AN M BY N MATRIX A, THIS ! SUBROUTINE DETERMINES AN INCIDENCE-DEGREE ORDERING OF THE ! COLUMNS OF A. ! THE INCIDENCE-DEGREE ORDERING IS DEFINED FOR THE LOOPLESS ! GRAPH G WITH VERTICES A(J), J = 1,2,...,N WHERE A(J) IS THE ! J-TH COLUMN OF A AND WITH EDGE (A(I),A(J)) IF AND ONLY IF ! COLUMNS I AND J HAVE A NON-ZERO IN THE SAME ROW POSITION. ! THE INCIDENCE-DEGREE ORDERING IS DETERMINED RECURSIVELY BY ! LETTING LIST(K), K = 1,...,N BE A COLUMN WITH MAXIMAL ! INCIDENCE TO THE SUBGRAPH SPANNED BY THE ORDERED COLUMNS. ! AMONG ALL THE COLUMNS OF MAXIMAL INCIDENCE, IDO CHOOSES A ! COLUMN OF MAXIMAL DEGREE. ! THE SUBROUTINE STATEMENT IS ! SUBROUTINE IDO(M,N,INDROW,JPNTR,INDCOL,IPNTR,NDEG,LIST, ! MAXCLQ,IWA1,IWA2,IWA3,IWA4) ! WHERE ! M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER ! OF ROWS OF A. ! N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER ! OF COLUMNS OF A. ! INDROW IS AN INTEGER INPUT ARRAY WHICH CONTAINS THE ROW ! INDICES FOR THE NON-ZEROES IN THE MATRIX A. ! JPNTR IS AN INTEGER INPUT ARRAY OF LENGTH N + 1 WHICH ! SPECIFIES THE LOCATIONS OF THE ROW INDICES IN INDROW. ! THE ROW INDICES FOR COLUMN J ARE ! INDROW(K), K = JPNTR(J),...,JPNTR(J+1)-1. ! NOTE THAT JPNTR(N+1)-1 IS THEN THE NUMBER OF NON-ZERO ! ELEMENTS OF THE MATRIX A. ! INDCOL IS AN INTEGER INPUT ARRAY WHICH CONTAINS THE ! COLUMN INDICES FOR THE NON-ZEROES IN THE MATRIX A. ! IPNTR IS AN INTEGER INPUT ARRAY OF LENGTH M + 1 WHICH ! SPECIFIES THE LOCATIONS OF THE COLUMN INDICES IN INDCOL. ! THE COLUMN INDICES FOR ROW I ARE ! INDCOL(K), K = IPNTR(I),...,IPNTR(I+1)-1. ! NOTE THAT IPNTR(M+1)-1 IS THEN THE NUMBER OF NON-ZERO ! ELEMENTS OF THE MATRIX A. ! NDEG IS AN INTEGER INPUT ARRAY OF LENGTH N WHICH SPECIFIES ! THE DEGREE SEQUENCE. THE DEGREE OF THE J-TH COLUMN ! OF A IS NDEG(J). ! LIST IS AN INTEGER OUTPUT ARRAY OF LENGTH N WHICH SPECIFIES ! THE INCIDENCE-DEGREE ORDERING OF THE COLUMNS OF A. THE J-TH ! COLUMN IN THIS ORDER IS LIST(J). ! MAXCLQ IS AN INTEGER OUTPUT VARIABLE SET TO THE SIZE ! OF THE LARGEST CLIQUE FOUND DURING THE ORDERING. ! IWA1,IWA2,IWA3, AND IWA4 ARE INTEGER WORK ARRAYS OF LENGTH N. ! SUBPROGRAMS CALLED ! MINPACK-SUPPLIED ... NUMSRT ! INTRINSIC ... MAX ! ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. JULY 1983. ! THOMAS F. COLEMAN, BURTON S. GARBOW, JORGE J. MORE' IMPLICIT NONE ! .. Scalar Arguments .. INTEGER :: M, MAXCLQ, N ! .. ! .. Array Arguments .. INTEGER :: INDCOL(*), INDROW(*), IPNTR(M+1), IWA1(0:N-1), IWA2(N), & IWA3(N), IWA4(N), JPNTR(N+1), LIST(N), NDEG(N) ! .. ! .. Local Scalars .. INTEGER :: IC, IP, IR, JCOL, JP, MAXINC, MAXLST, NCOMP, NUMINC, NUMLST, & NUMORD, NUMWGT ! .. ! .. External Subroutines .. ! EXTERNAL NUMSRT ! .. ! .. Intrinsic Functions .. INTRINSIC MAX ! .. ! .. FIRST EXECUTABLE STATEMENT IDO ! .. ! SORT THE DEGREE SEQUENCE. CALL NUMSRT(N,N-1,NDEG,-1,IWA4,IWA2,IWA3) ! INITIALIZATION BLOCK. ! CREATE A DOUBLY-LINKED LIST TO ACCESS THE INCIDENCES OF THE ! COLUMNS. THE POINTERS FOR THE LINKED LIST ARE AS FOLLOWS. ! EACH UNORDERED COLUMN IC IS IN A LIST (THE INCIDENCE LIST) ! OF COLUMNS WITH THE SAME INCIDENCE. ! IWA1(NUMINC) IS THE FIRST COLUMN IN THE NUMINC LIST ! UNLESS IWA1(NUMINC) = 0. IN THIS CASE THERE ARE ! NO COLUMNS IN THE NUMINC LIST. ! IWA2(IC) IS THE COLUMN BEFORE IC IN THE INCIDENCE LIST ! UNLESS IWA2(IC) = 0. IN THIS CASE IC IS THE FIRST ! COLUMN IN THIS INCIDENCE LIST. ! IWA3(IC) IS THE COLUMN AFTER IC IN THE INCIDENCE LIST ! UNLESS IWA3(IC) = 0. IN THIS CASE IC IS THE LAST ! COLUMN IN THIS INCIDENCE LIST. ! IF IC IS AN UN-ORDERED COLUMN, THEN LIST(IC) IS THE ! INCIDENCE OF IC TO THE GRAPH INDUCED BY THE ORDERED ! COLUMNS. IF JCOL IS AN ORDERED COLUMN, THEN LIST(JCOL) ! IS THE INCIDENCE-DEGREE ORDER OF COLUMN JCOL. MAXINC = 0 DO JP = N, 1, -1 IC = IWA4(JP) IWA1(N-JP) = 0 IWA2(IC) = 0 IWA3(IC) = IWA1(0) IF (IWA1(0) > 0) IWA2(IWA1(0)) = IC IWA1(0) = IC IWA4(JP) = 0 LIST(JP) = 0 END DO ! DETERMINE THE MAXIMAL SEARCH LENGTH FOR THE LIST ! OF COLUMNS OF MAXIMAL INCIDENCE. MAXLST = 0 DO IR = 1, M MAXLST = MAXLST + (IPNTR(IR+1)-IPNTR(IR))**2 END DO MAXLST = MAXLST/N MAXCLQ = 0 NUMORD = 1 ! BEGINNING OF ITERATION LOOP. 30 CONTINUE ! UPDATE THE SIZE OF THE LARGEST CLIQUE ! FOUND DURING THE ORDERING. IF (MAXINC == 0) NCOMP = 0 NCOMP = NCOMP + 1 IF (MAXINC+1 == NCOMP) MAXCLQ = MAX(MAXCLQ,NCOMP) ! CHOOSE A COLUMN JCOL OF MAXIMAL DEGREE AMONG THE ! COLUMNS OF MAXIMAL INCIDENCE MAXINC. 40 CONTINUE JP = IWA1(MAXINC) IF (JP > 0) GOTO 50 MAXINC = MAXINC - 1 GOTO 40 50 CONTINUE NUMWGT = -1 DO NUMLST = 1, MAXLST IF (NDEG(JP) > NUMWGT) THEN NUMWGT = NDEG(JP) JCOL = JP END IF JP = IWA3(JP) IF (JP <= 0) GOTO 70 END DO 70 CONTINUE LIST(JCOL) = NUMORD NUMORD = NUMORD + 1 ! TERMINATION TEST. IF (NUMORD > N) GOTO 100 ! DELETE COLUMN JCOL FROM THE MAXINC LIST. IF (IWA2(JCOL) == 0) THEN IWA1(MAXINC) = IWA3(JCOL) ELSE IWA3(IWA2(JCOL)) = IWA3(JCOL) END IF IF (IWA3(JCOL) > 0) IWA2(IWA3(JCOL)) = IWA2(JCOL) ! FIND ALL COLUMNS ADJACENT TO COLUMN JCOL. IWA4(JCOL) = N ! DETERMINE ALL POSITIONS(IR,JCOL) WHICH CORRESPOND ! TO NON-ZEROES IN THE MATRIX. DO JP = JPNTR(JCOL), JPNTR(JCOL+1) - 1 IR = INDROW(JP) ! FOR EACH ROW IR, DETERMINE ALL POSITIONS(IR,IC) ! WHICH CORRESPOND TO NON-ZEROES IN THE MATRIX. DO IP = IPNTR(IR), IPNTR(IR+1) - 1 IC = INDCOL(IP) ! ARRAY IWA4 MARKS COLUMNS WHICH ARE ADJACENT TO ! COLUMN JCOL. IF (IWA4(IC) < NUMORD) THEN IWA4(IC) = NUMORD ! UPDATE THE POINTERS TO THE CURRENT INCIDENCE LISTS. NUMINC = LIST(IC) LIST(IC) = LIST(IC) + 1 MAXINC = MAX(MAXINC,LIST(IC)) ! DELETE COLUMN IC FROM THE NUMINC LIST. IF (IWA2(IC) == 0) THEN IWA1(NUMINC) = IWA3(IC) ELSE IWA3(IWA2(IC)) = IWA3(IC) END IF IF (IWA3(IC) > 0) IWA2(IWA3(IC)) = IWA2(IC) ! ADD COLUMN IC TO THE NUMINC+1 LIST. IWA2(IC) = 0 IWA3(IC) = IWA1(NUMINC+1) IF (IWA1(NUMINC+1) > 0) IWA2(IWA1(NUMINC+1)) = IC IWA1(NUMINC+1) = IC END IF END DO END DO ! END OF ITERATION LOOP. GOTO 30 100 CONTINUE ! INVERT THE ARRAY LIST. DO JCOL = 1, N IWA2(LIST(JCOL)) = JCOL END DO LIST(1:N) = IWA2(1:N) RETURN END SUBROUTINE IDO !_______________________________________________________________________ SUBROUTINE NUMSRT(N,NMAX,NUM,MODE,INDEX,LAST,NEXT) ! GIVEN A SEQUENCE OF INTEGERS, THIS SUBROUTINE GROUPS TOGETHER THOSE ! INDICES WITH THE SAME SEQUENCE VALUE AND, OPTIONALLY, SORTS THE ! SEQUENCE INTO EITHER ASCENDING OR DESCENDING ORDER. THE SEQUENCE ! OF INTEGERS IS DEFINED BY THE ARRAY NUM, AND IT IS ASSUMED THAT THE ! INTEGERS ARE EACH FROM THE SET 0,1,...,NMAX. ON OUTPUT THE INDICES ! K SUCH THAT NUM(K) = L FOR ANY L = 0,1,...,NMAX CAN BE OBTAINED ! FROM THE ARRAYS LAST AND NEXT AS FOLLOWS. ! K = LAST(L) ! WHILE(K /= 0) K = NEXT(K) ! OPTIONALLY, THE SUBROUTINE PRODUCES AN ARRAY INDEX SO THAT ! THE SEQUENCE NUM(INDEX(I)), I = 1,2,...,N IS SORTED. ! THE SUBROUTINE STATEMENT IS ! SUBROUTINE NUMSRT(N,NMAX,NUM,MODE,INDEX,LAST,NEXT) ! WHERE ! N IS A POSITIVE INTEGER INPUT VARIABLE. ! NMAX IS A POSITIVE INTEGER INPUT VARIABLE. ! NUM IS AN INPUT ARRAY OF LENGTH N WHICH CONTAINS THE ! SEQUENCE OF INTEGERS TO BE GROUPED AND SORTED. IT ! IS ASSUMED THAT THE INTEGERS ARE EACH FROM THE SET ! 0,1,...,NMAX. ! MODE IS AN INTEGER INPUT VARIABLE. THE SEQUENCE NUM IS ! SORTED IN ASCENDING ORDER IF MODE IS POSITIVE AND IN ! DESCENDING ORDER IF MODE IS NEGATIVE. IF MODE IS 0, ! NO SORTING IS DONE. ! INDEX IS AN INTEGER OUTPUT ARRAY OF LENGTH N SET SO ! THAT THE SEQUENCE ! NUM(INDEX(I)), I = 1,2,...,N ! IS SORTED ACCORDING TO THE SETTING OF MODE. IF MODE ! IS 0, INDEX IS NOT REFERENCED. ! LAST IS AN INTEGER OUTPUT ARRAY OF LENGTH NMAX + 1. THE ! INDEX OF NUM FOR THE LAST OCCURRENCE OF L IS LAST(L) ! FOR ANY L = 0,1,...,NMAX UNLESS LAST(L) = 0. IN ! THIS CASE L DOES NOT APPEAR IN NUM. ! NEXT IS AN INTEGER OUTPUT ARRAY OF LENGTH N. IF ! NUM(K) = L, THEN THE INDEX OF NUM FOR THE PREVIOUS ! OCCURRENCE OF L IS NEXT(K) FOR ANY L = 0,1,...,NMAX ! UNLESS NEXT(K) = 0. IN THIS CASE THERE IS NO PREVIOUS ! OCCURRENCE OF L IN NUM. ! ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. JULY 1983. ! THOMAS F. COLEMAN, BURTON S. GARBOW, JORGE J. MORE' IMPLICIT NONE ! .. Scalar Arguments .. INTEGER :: MODE, N, NMAX ! .. ! .. Array Arguments .. INTEGER :: INDEX(N), LAST(0:NMAX), NEXT(N), NUM(N) ! .. ! .. Local Scalars .. INTEGER :: I, J, JINC, JL, JU, K, L ! .. ! .. FIRST EXECUTABLE STATEMENT NUMSRT ! .. ! DETERMINE THE ARRAYS NEXT AND LAST. LAST(0:NMAX) = 0 DO K = 1, N L = NUM(K) NEXT(K) = LAST(L) LAST(L) = K END DO IF (MODE == 0) RETURN ! STORE THE POINTERS TO THE SORTED ARRAY IN INDEX. I = 1 IF (MODE > 0) THEN JL = 0 JU = NMAX JINC = 1 ELSE JL = NMAX JU = 0 JINC = -1 END IF DO J = JL, JU, JINC K = LAST(J) 30 CONTINUE IF (K == 0) GOTO 40 INDEX(I) = K I = I + 1 K = NEXT(K) GOTO 30 40 CONTINUE END DO RETURN END SUBROUTINE NUMSRT !_______________________________________________________________________ SUBROUTINE SEQ(N,INDROW,JPNTR,INDCOL,IPNTR,LIST,NGRP,MAXGRP,IWA) ! GIVEN THE SPARSITY PATTERN OF AN M BY N MATRIX A, THIS ! SUBROUTINE DETERMINES A CONSISTENT PARTITION OF THE ! COLUMNS OF A BY A SEQUENTIAL ALGORITHM. ! A CONSISTENT PARTITION IS DEFINED IN TERMS OF THE LOOPLESS ! GRAPH G WITH VERTICES A(J), J = 1,2,...,N WHERE A(J) IS THE ! J-TH COLUMN OF A AND WITH EDGE(A(I),A(J)) IF AND ONLY IF ! COLUMNS I AND J HAVE A NON-ZERO IN THE SAME ROW POSITION. ! A PARTITION OF THE COLUMNS OF A INTO GROUPS IS CONSISTENT ! IF THE COLUMNS IN ANY GROUP ARE NOT ADJACENT IN THE GRAPH G. ! IN GRAPH-THEORY TERMINOLOGY, A CONSISTENT PARTITION OF THE ! COLUMNS OF A CORRESPONDS TO A COLORING OF THE GRAPH G. ! THE SUBROUTINE EXAMINES THE COLUMNS IN THE ORDER SPECIFIED ! BY THE ARRAY LIST, AND ASSIGNS THE CURRENT COLUMN TO THE ! GROUP WITH THE SMALLEST POSSIBLE NUMBER. ! NOTE THAT THE VALUE OF M IS NOT NEEDED BY SEQ AND IS ! THEREFORE NOT PRESENT IN THE SUBROUTINE STATEMENT. ! THE SUBROUTINE STATEMENT IS ! SUBROUTINE SEQ(N,INDROW,JPNTR,INDCOL,IPNTR,LIST,NGRP,MAXGRP,IWA) ! WHERE ! N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER ! OF COLUMNS OF A. ! INDROW IS AN INTEGER INPUT ARRAY WHICH CONTAINS THE ROW ! INDICES FOR THE NON-ZEROES IN THE MATRIX A. ! JPNTR IS AN INTEGER INPUT ARRAY OF LENGTH N + 1 WHICH ! SPECIFIES THE LOCATIONS OF THE ROW INDICES IN INDROW. ! THE ROW INDICES FOR COLUMN J ARE ! INDROW(K), K = JPNTR(J),...,JPNTR(J+1)-1. ! NOTE THAT JPNTR(N+1)-1 IS THEN THE NUMBER OF NON-ZERO ! ELEMENTS OF THE MATRIX A. ! INDCOL IS AN INTEGER INPUT ARRAY WHICH CONTAINS THE ! COLUMN INDICES FOR THE NON-ZEROES IN THE MATRIX A. ! IPNTR IS AN INTEGER INPUT ARRAY OF LENGTH M + 1 WHICH ! SPECIFIES THE LOCATIONS OF THE COLUMN INDICES IN INDCOL. ! THE COLUMN INDICES FOR ROW I ARE ! INDCOL(K), K = IPNTR(I),...,IPNTR(I+1)-1. ! NOTE THAT IPNTR(M+1)-1 IS THEN THE NUMBER OF NON-ZERO ! ELEMENTS OF THE MATRIX A. ! LIST IS AN INTEGER INPUT ARRAY OF LENGTH N WHICH SPECIFIES ! THE ORDER TO BE USED BY THE SEQUENTIAL ALGORITHM. ! THE J-TH COLUMN IN THIS ORDER IS LIST(J). ! NGRP IS AN INTEGER OUTPUT ARRAY OF LENGTH N WHICH SPECIFIES ! THE PARTITION OF THE COLUMNS OF A. COLUMN JCOL BELONGS ! TO GROUP NGRP(JCOL). ! MAXGRP IS AN INTEGER OUTPUT VARIABLE WHICH SPECIFIES THE ! NUMBER OF GROUPS IN THE PARTITION OF THE COLUMNS OF A. ! IWA IS AN INTEGER WORK ARRAY OF LENGTH N. ! ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. JULY 1983. ! THOMAS F. COLEMAN, BURTON S. GARBOW, JORGE J. MORE' IMPLICIT NONE ! .. Scalar Arguments .. INTEGER :: MAXGRP, N ! .. ! .. Array Arguments .. INTEGER :: INDCOL(*), INDROW(*), IPNTR(*), IWA(N), JPNTR(N+1), & LIST(N), NGRP(N) ! .. ! .. Local Scalars .. INTEGER :: IC, IP, IR, J, JCOL, JP ! .. ! .. FIRST EXECUTABLE STATEMENT SEQ ! .. ! INITIALIZATION BLOCK. MAXGRP = 0 NGRP(1:N) = N IWA(1:N) = 0 ! BEGINNING OF ITERATION LOOP. DO J = 1, N JCOL = LIST(J) ! FIND ALL COLUMNS ADJACENT TO COLUMN JCOL. ! DETERMINE ALL POSITIONS (IR,JCOL) WHICH CORRESPOND ! TO NON-ZEROES IN THE MATRIX. DO JP = JPNTR(JCOL), JPNTR(JCOL+1) - 1 IR = INDROW(JP) ! FOR EACH ROW IR, DETERMINE ALL POSITIONS (IR,IC) ! WHICH CORRESPOND TO NON-ZEROES IN THE MATRIX. DO IP = IPNTR(IR), IPNTR(IR+1) - 1 IC = INDCOL(IP) ! ARRAY IWA MARKS THE GROUP NUMBERS OF THE ! COLUMNS WHICH ARE ADJACENT TO COLUMN JCOL. IWA(NGRP(IC)) = J END DO END DO ! ASSIGN THE SMALLEST UN-MARKED GROUP NUMBER TO JCOL. DO JP = 1, MAXGRP IF (IWA(JP)/=J) GOTO 50 END DO MAXGRP = MAXGRP + 1 50 CONTINUE NGRP(JCOL) = JP END DO ! END OF ITERATION LOOP. RETURN END SUBROUTINE SEQ !_______________________________________________________________________ SUBROUTINE SETR(M,N,INDROW,JPNTR,INDCOL,IPNTR,IWA) ! GIVEN A COLUMN-ORIENTED DEFINITION OF THE SPARSITY PATTERN ! OF AN M BY N MATRIX A, THIS SUBROUTINE DETERMINES A ! ROW-ORIENTED DEFINITION OF THE SPARSITY PATTERN OF A. ! ON INPUT THE COLUMN-ORIENTED DEFINITION IS SPECIFIED BY ! THE ARRAYS INDROW AND JPNTR. ON OUTPUT THE ROW-ORIENTED ! DEFINITION IS SPECIFIED BY THE ARRAYS INDCOL AND IPNTR. ! THE SUBROUTINE STATEMENT IS ! SUBROUTINE SETR(M,N,INDROW,JPNTR,INDCOL,IPNTR,IWA) ! WHERE ! M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER ! OF ROWS OF A. ! N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER ! OF COLUMNS OF A. ! INDROW IS AN INTEGER INPUT ARRAY WHICH CONTAINS THE ROW ! INDICES FOR THE NON-ZEROES IN THE MATRIX A. ! JPNTR IS AN INTEGER INPUT ARRAY OF LENGTH N + 1 WHICH ! SPECIFIES THE LOCATIONS OF THE ROW INDICES IN INDROW. ! THE ROW INDICES FOR COLUMN J ARE ! INDROW(K), K = JPNTR(J),...,JPNTR(J+1)-1. ! NOTE THAT JPNTR(N+1)-1 IS THEN THE NUMBER OF NON-ZERO ! ELEMENTS OF THE MATRIX A. ! INDCOL IS AN INTEGER OUTPUT ARRAY WHICH CONTAINS THE ! COLUMN INDICES FOR THE NON-ZEROES IN THE MATRIX A. ! IPNTR IS AN INTEGER OUTPUT ARRAY OF LENGTH M + 1 WHICH ! SPECIFIES THE LOCATIONS OF THE COLUMN INDICES IN INDCOL. ! THE COLUMN INDICES FOR ROW I ARE ! INDCOL(K), K = IPNTR(I),...,IPNTR(I+1)-1. ! NOTE THAT IPNTR(1) IS SET TO 1 AND THAT IPNTR(M+1)-1 IS ! THEN THE NUMBER OF NON-ZERO ELEMENTS OF THE MATRIX A. ! IWA IS AN INTEGER WORK ARRAY OF LENGTH M. ! ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. JULY 1983. ! THOMAS F. COLEMAN, BURTON S. GARBOW, JORGE J. MORE' IMPLICIT NONE ! .. Scalar Arguments .. INTEGER :: M, N ! .. ! .. Array Arguments .. INTEGER :: INDCOL(*), INDROW(*), IPNTR(M+1), IWA(M), JPNTR(N+1) ! .. ! .. Local Scalars .. INTEGER :: IR, JCOL, JP ! .. ! .. FIRST EXECUTABLE STATEMENT SETR ! .. ! STORE IN ARRAY IWA THE COUNTS OF NON-ZEROES IN THE ROWS. IWA(1:M) = 0 DO JP = 1, JPNTR(N+1) - 1 IWA(INDROW(JP)) = IWA(INDROW(JP)) + 1 END DO ! SET POINTERS TO THE START OF THE ROWS IN INDCOL. IPNTR(1) = 1 DO IR = 1, M IPNTR(IR+1) = IPNTR(IR) + IWA(IR) IWA(IR) = IPNTR(IR) END DO ! FILL INDCOL. DO JCOL = 1, N DO JP = JPNTR(JCOL), JPNTR(JCOL+1) - 1 IR = INDROW(JP) INDCOL(IWA(IR)) = JCOL IWA(IR) = IWA(IR) + 1 END DO END DO RETURN END SUBROUTINE SETR !_______________________________________________________________________ SUBROUTINE SLO(N,INDROW,JPNTR,INDCOL,IPNTR,NDEG,LIST,MAXCLQ,IWA1,IWA2, & IWA3,IWA4) ! GIVEN THE SPARSITY PATTERN OF AN M BY N MATRIX A, THIS ! SUBROUTINE DETERMINES THE SMALLEST-LAST ORDERING OF THE ! COLUMNS OF A. ! THE SMALLEST-LAST ORDERING IS DEFINED FOR THE LOOPLESS ! GRAPH G WITH VERTICES A(J), J = 1,2,...,N WHERE A(J) IS THE ! J-TH COLUMN OF A AND WITH EDGE(A(I),A(J)) IF AND ONLY IF ! COLUMNS I AND J HAVE A NON-ZERO IN THE SAME ROW POSITION. ! THE SMALLEST-LAST ORDERING IS DETERMINED RECURSIVELY BY ! LETTING LIST(K), K = N,...,1 BE A COLUMN WITH LEAST DEGREE ! IN THE SUBGRAPH SPANNED BY THE UN-ORDERED COLUMNS. ! NOTE THAT THE VALUE OF M IS NOT NEEDED BY SLO AND IS ! THEREFORE NOT PRESENT IN THE SUBROUTINE STATEMENT. ! THE SUBROUTINE STATEMENT IS ! SUBROUTINE SLO(N,INDROW,JPNTR,INDCOL,IPNTR,NDEG,LIST, & ! MAXCLQ,IWA1,IWA2,IWA3,IWA4) ! WHERE ! N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER ! OF COLUMNS OF A. ! INDROW IS AN INTEGER INPUT ARRAY WHICH CONTAINS THE ROW ! INDICES FOR THE NON-ZEROES IN THE MATRIX A. ! JPNTR IS AN INTEGER INPUT ARRAY OF LENGTH N + 1 WHICH ! SPECIFIES THE LOCATIONS OF THE ROW INDICES IN INDROW. ! THE ROW INDICES FOR COLUMN J ARE ! INDROW(K), K = JPNTR(J),...,JPNTR(J+1)-1. ! NOTE THAT JPNTR(N+1)-1 IS THEN THE NUMBER OF NON-ZERO ! ELEMENTS OF THE MATRIX A. ! INDCOL IS AN INTEGER INPUT ARRAY WHICH CONTAINS THE ! COLUMN INDICES FOR THE NON-ZEROES IN THE MATRIX A. ! IPNTR IS AN INTEGER INPUT ARRAY OF LENGTH M + 1 WHICH ! SPECIFIES THE LOCATIONS OF THE COLUMN INDICES IN INDCOL. ! THE COLUMN INDICES FOR ROW I ARE ! INDCOL(K), K = IPNTR(I),...,IPNTR(I+1)-1. ! NOTE THAT IPNTR(M+1)-1 IS THEN THE NUMBER OF NON-ZERO ! ELEMENTS OF THE MATRIX A. ! NDEG IS AN INTEGER INPUT ARRAY OF LENGTH N WHICH SPECIFIES ! THE DEGREE SEQUENCE. THE DEGREE OF THE J-TH COLUMN ! OF A IS NDEG(J). ! LIST IS AN INTEGER OUTPUT ARRAY OF LENGTH N WHICH SPECIFIES ! THE SMALLEST-LAST ORDERING OF THE COLUMNS OF A. THE J-TH ! COLUMN IN THIS ORDER IS LIST(J). ! MAXCLQ IS AN INTEGER OUTPUT VARIABLE SET TO THE SIZE ! OF THE LARGEST CLIQUE FOUND DURING THE ORDERING. ! IWA1,IWA2,IWA3, AND IWA4 ARE INTEGER WORK ARRAYS OF LENGTH N. ! SUBPROGRAMS CALLED ! INTRINSIC ... MIN ! ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. JULY 1983. ! THOMAS F. COLEMAN, BURTON S. GARBOW, JORGE J. MORE' IMPLICIT NONE ! .. Scalar Arguments .. INTEGER :: MAXCLQ, N ! .. ! .. Array Arguments .. INTEGER :: INDCOL(*), INDROW(*), IPNTR(*), IWA1(0:N-1), IWA2(N), & IWA3(N), IWA4(N), JPNTR(N+1), LIST(N), NDEG(N) ! .. ! .. Local Scalars .. INTEGER :: IC, IP, IR, JCOL, JP, MINDEG, NUMDEG, NUMORD ! .. ! .. Intrinsic Functions .. INTRINSIC MIN ! .. ! .. FIRST EXECUTABLE STATEMENT SLO ! .. ! INITIALIZATION BLOCK. MINDEG = N DO JP = 1, N IWA1(JP-1) = 0 IWA4(JP) = N LIST(JP) = NDEG(JP) MINDEG = MIN(MINDEG,NDEG(JP)) END DO ! CREATE A DOUBLY-LINKED LIST TO ACCESS THE DEGREES OF THE ! COLUMNS. THE POINTERS FOR THE LINKED LIST ARE AS FOLLOWS. ! EACH UN-ORDERED COLUMN IC IS IN A LIST (THE DEGREE LIST) ! OF COLUMNS WITH THE SAME DEGREE. ! IWA1(NUMDEG) IS THE FIRST COLUMN IN THE NUMDEG LIST ! UNLESS IWA1(NUMDEG) = 0. IN THIS CASE THERE ARE ! NO COLUMNS IN THE NUMDEG LIST. ! IWA2(IC) IS THE COLUMN BEFORE IC IN THE DEGREE LIST ! UNLESS IWA2(IC) = 0. IN THIS CASE IC IS THE FIRST ! COLUMN IN THIS DEGREE LIST. ! IWA3(IC) IS THE COLUMN AFTER IC IN THE DEGREE LIST ! UNLESS IWA3(IC) = 0. IN THIS CASE IC IS THE LAST ! COLUMN IN THIS DEGREE LIST. ! IF IC IS AN UN-ORDERED COLUMN, THEN LIST(IC) IS THE ! DEGREE OF IC IN THE GRAPH INDUCED BY THE UN-ORDERED ! COLUMNS. IF JCOL IS AN ORDERED COLUMN, THEN LIST(JCOL) ! IS THE SMALLEST-LAST ORDER OF COLUMN JCOL. DO JP = 1, N NUMDEG = NDEG(JP) IWA2(JP) = 0 IWA3(JP) = IWA1(NUMDEG) IF (IWA1(NUMDEG) > 0) IWA2(IWA1(NUMDEG)) = JP IWA1(NUMDEG) = JP END DO MAXCLQ = 0 NUMORD = N ! BEGINNING OF ITERATION LOOP. 30 CONTINUE ! MARK THE SIZE OF THE LARGEST CLIQUE ! FOUND DURING THE ORDERING. IF (MINDEG+1 == NUMORD .AND. MAXCLQ == 0) MAXCLQ = NUMORD ! CHOOSE A COLUMN JCOL OF MINIMAL DEGREE MINDEG. 40 CONTINUE JCOL = IWA1(MINDEG) IF (JCOL > 0) GOTO 50 MINDEG = MINDEG + 1 GOTO 40 50 CONTINUE LIST(JCOL) = NUMORD NUMORD = NUMORD - 1 ! TERMINATION TEST. IF (NUMORD == 0) GOTO 80 ! DELETE COLUMN JCOL FROM THE MINDEG LIST. IWA1(MINDEG) = IWA3(JCOL) IF (IWA3(JCOL) > 0) IWA2(IWA3(JCOL)) = 0 ! FIND ALL COLUMNS ADJACENT TO COLUMN JCOL. IWA4(JCOL) = 0 ! DETERMINE ALL POSITIONS (IR,JCOL) WHICH CORRESPOND ! TO NON-ZEROES IN THE MATRIX. DO JP = JPNTR(JCOL), JPNTR(JCOL+1) - 1 IR = INDROW(JP) ! FOR EACH ROW IR, DETERMINE ALL POSITIONS (IR,IC) ! WHICH CORRESPOND TO NON-ZEROES IN THE MATRIX. DO IP = IPNTR(IR), IPNTR(IR+1) - 1 IC = INDCOL(IP) ! ARRAY IWA4 MARKS COLUMNS WHICH ARE ADJACENT TO ! COLUMN JCOL. IF (IWA4(IC) > NUMORD) THEN IWA4(IC) = NUMORD ! UPDATE THE POINTERS TO THE CURRENT DEGREE LISTS. NUMDEG = LIST(IC) LIST(IC) = LIST(IC) - 1 MINDEG = MIN(MINDEG,LIST(IC)) ! DELETE COLUMN IC FROM THE NUMDEG LIST. IF (IWA2(IC) == 0) THEN IWA1(NUMDEG) = IWA3(IC) ELSE IWA3(IWA2(IC)) = IWA3(IC) END IF IF (IWA3(IC) > 0) IWA2(IWA3(IC)) = IWA2(IC) ! ADD COLUMN IC TO THE NUMDEG-1 LIST. IWA2(IC) = 0 IWA3(IC) = IWA1(NUMDEG-1) IF (IWA1(NUMDEG-1) > 0) IWA2(IWA1(NUMDEG-1)) = IC IWA1(NUMDEG-1) = IC END IF END DO END DO ! END OF ITERATION LOOP. GOTO 30 80 CONTINUE ! INVERT THE ARRAY LIST. DO JCOL = 1, N IWA2(LIST(JCOL)) = JCOL END DO LIST(1:N) = IWA2(1:N) RETURN END SUBROUTINE SLO !_______________________________________________________________________ SUBROUTINE SRTDAT(N,NNZ,INDROW,INDCOL,JPNTR,IWA) ! GIVEN THE NON-ZERO ELEMENTS OF AN M BY N MATRIX A IN ARBITRARY ! ORDER AS SPECIFIED BY THEIR ROW AND COLUMN INDICES, THIS SUBROUTINE ! PERMUTES THESE ELEMENTS SO THAT THEIR COLUMN INDICES ARE IN ! NON-DECREASING ORDER. ON INPUT IT IS ASSUMED THAT THE ELEMENTS ARE ! SPECIFIED IN ! INDROW(K),INDCOL(K), K = 1,...,NNZ. ! ON OUTPUT THE ELEMENTS ARE PERMUTED SO THAT INDCOL IS IN ! NON-DECREASING ORDER. IN ADDITION, THE ARRAY JPNTR IS SET SO THAT ! THE ROW INDICES FOR COLUMN J ARE ! INDROW(K), K = JPNTR(J),...,JPNTR(J+1)-1. ! NOTE THAT THE VALUE OF M IS NOT NEEDED BY SRTDAT AND IS THEREFORE ! NOT PRESENT IN THE SUBROUTINE STATEMENT. ! THE SUBROUTINE STATEMENT IS ! SUBROUTINE SRTDAT(N,NNZ,INDROW,INDCOL,JPNTR,IWA) ! WHERE ! N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER ! OF COLUMNS OF A. ! NNZ IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER ! OF NON-ZERO ELEMENTS OF A. ! INDROW IS AN INTEGER ARRAY OF LENGTH NNZ. ON INPUT INDROW ! MUST CONTAIN THE ROW INDICES OF THE NON-ZERO ELEMENTS OF A. ! ON OUTPUT INDROW IS PERMUTED SO THAT THE CORRESPONDING ! COLUMN INDICES OF INDCOL ARE IN NON-DECREASING ORDER. ! INDCOL IS AN INTEGER ARRAY OF LENGTH NNZ. ON INPUT INDCOL ! MUST CONTAIN THE COLUMN INDICES OF THE NON-ZERO ELEMENTS ! OF A. ON OUTPUT INDCOL IS PERMUTED SO THAT THESE INDICES ! ARE IN NON-DECREASING ORDER. ! JPNTR IS AN INTEGER OUTPUT ARRAY OF LENGTH N + 1 WHICH ! SPECIFIES THE LOCATIONS OF THE ROW INDICES IN THE OUTPUT ! INDROW. THE ROW INDICES FOR COLUMN J ARE ! INDROW(K), K = JPNTR(J),...,JPNTR(J+1)-1. ! NOTE THAT JPNTR(1) IS SET TO 1 AND THAT JPNTR(N+1)-1 ! IS THEN NNZ. ! IWA IS AN INTEGER WORK ARRAY OF LENGTH N. ! SUBPROGRAMS CALLED - NONE ! INTRINSIC - MAX ! ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. JULY 1983. ! THOMAS F. COLEMAN, BURTON S. GARBOW, JORGE J. MORE' IMPLICIT NONE ! .. Scalar Arguments .. INTEGER :: N, NNZ ! .. ! .. Array Arguments .. INTEGER :: INDCOL(NNZ), INDROW(NNZ), IWA(N), JPNTR(N+1) ! .. ! .. Local Scalars .. INTEGER :: I, J, K, L ! .. ! .. Intrinsic Functions .. INTRINSIC MAX ! .. ! .. FIRST EXECUTABLE STATEMENT SRTDAT ! .. ! STORE IN ARRAY IWA THE COUNTS OF NON-ZEROES IN THE COLUMNS. IWA(1:N) = 0 DO K = 1, NNZ IWA(INDCOL(K)) = IWA(INDCOL(K)) + 1 END DO ! SET POINTERS TO THE START OF THE COLUMNS IN INDROW. JPNTR(1) = 1 DO J = 1, N JPNTR(J+1) = JPNTR(J) + IWA(J) IWA(J) = JPNTR(J) END DO K = 1 ! BEGIN IN-PLACE SORT. 40 CONTINUE J = INDCOL(K) IF (K >= JPNTR(J)) THEN ! CURRENT ELEMENT IS IN POSITION. NOW EXAMINE THE ! NEXT ELEMENT OR THE FIRST UN-SORTED ELEMENT IN ! THE J-TH GROUP. K = MAX(K+1,IWA(J)) ELSE ! CURRENT ELEMENT IS NOT IN POSITION. PLACE ELEMENT ! IN POSITION AND MAKE THE DISPLACED ELEMENT THE ! CURRENT ELEMENT. L = IWA(J) IWA(J) = IWA(J) + 1 I = INDROW(K) INDROW(K) = INDROW(L) INDCOL(K) = INDCOL(L) INDROW(L) = I INDCOL(L) = J END IF IF (K <= NNZ) GOTO 40 RETURN END SUBROUTINE SRTDAT !_______________________________________________________________________ SUBROUTINE FDJS(M,N,COL,IND,NPNTR,NGRP,NUMGRP,D,FJACD,FJAC) ! GIVEN A CONSISTENT PARTITION OF THE COLUMNS OF AN M BY N ! JACOBIAN MATRIX INTO GROUPS, THIS SUBROUTINE COMPUTES ! APPROXIMATIONS TO THOSE COLUMNS IN A GIVEN GROUP. THE ! APPROXIMATIONS ARE STORED INTO EITHER A COLUMN-ORIENTED ! OR A ROW-ORIENTED PATTERN. ! A PARTITION IS CONSISTENT IF THE COLUMNS IN ANY GROUP ! DO NOT HAVE A NON-ZERO IN THE SAME ROW POSITION. ! APPROXIMATIONS TO THE COLUMNS OF THE JACOBIAN MATRIX IN A ! GIVEN GROUP CAN BE OBTAINED BY SPECIFYING A DIFFERENCE ! PARAMETER ARRAY D WITH D(JCOL) NON-ZERO IF AND ONLY IF ! JCOL IS A COLUMN IN THE GROUP, AND AN APPROXIMATION TO ! JAC*D WHERE JAC DENOTES THE JACOBIAN MATRIX OF A MAPPING F. ! D CAN BE DEFINED WITH THE FOLLOWING SEGMENT OF CODE. ! DO 10 JCOL = 1, N ! D(JCOL) = 0.0 ! IF (NGRP(JCOL) == NUMGRP) D(JCOL) = ETA(JCOL) ! 10 CONTINUE ! IN THE ABOVE CODE NUMGRP IS THE GIVEN GROUP NUMBER, ! NGRP(JCOL) IS THE GROUP NUMBER OF COLUMN JCOL, AND ! ETA(JCOL) IS THE DIFFERENCE PARAMETER USED TO ! APPROXIMATE COLUMN JCOL OF THE JACOBIAN MATRIX. ! SUITABLE VALUES FOR THE ARRAY ETA MUST BE PROVIDED. ! AS MENTIONED ABOVE, AN APPROXIMATION TO JAC*D MUST ! ALSO BE PROVIDED. FOR EXAMPLE, THE APPROXIMATION ! F(X+D) - F(X) ! CORRESPONDS TO THE FORWARD DIFFERENCE FORMULA AT X. ! THE SUBROUTINE STATEMENT IS ! SUBROUTINE FDJS(M,N,COL,IND,NPNTR,NGRP,NUMGRP,D,FJACD,FJAC) ! WHERE ! M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER ! OF ROWS OF THE JACOBIAN MATRIX. ! N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER ! OF COLUMNS OF THE JACOBIAN MATRIX. ! COL IS A LOGICAL INPUT VARIABLE. IF COL IS SET TRUE, THEN THE ! JACOBIAN APPROXIMATIONS ARE STORED INTO A COLUMN-ORIENTED ! PATTERN. IF COL IS SET FALSE, THEN THE JACOBIAN ! APPROXIMATIONS ARE STORED INTO A ROW-ORIENTED PATTERN. ! IND IS AN INTEGER INPUT ARRAY WHICH CONTAINS THE ROW ! INDICES FOR THE NON-ZEROES IN THE JACOBIAN MATRIX ! IF COL IS TRUE, AND CONTAINS THE COLUMN INDICES FOR ! THE NON-ZEROES IN THE JACOBIAN MATRIX IF COL IS FALSE. ! NPNTR IS AN INTEGER INPUT ARRAY WHICH SPECIFIES THE ! LOCATIONS OF THE ROW INDICES IN IND IF COL IS TRUE, AND ! SPECIFIES THE LOCATIONS OF THE COLUMN INDICES IN IND IF ! COL IS FALSE. IF COL IS TRUE, THE INDICES FOR COLUMN J ARE ! IND(K), K = NPNTR(J),...,NPNTR(J+1)-1. ! IF COL IS FALSE, THE INDICES FOR ROW I ARE ! IND(K), K = NPNTR(I),...,NPNTR(I+1)-1. ! NOTE THAT NPNTR(N+1)-1 IF COL IS TRUE, OR NPNTR(M+1)-1 ! IF COL IS FALSE, IS THEN THE NUMBER OF NON-ZERO ELEMENTS ! OF THE JACOBIAN MATRIX. ! NGRP IS AN INTEGER INPUT ARRAY OF LENGTH N WHICH SPECIFIES ! THE PARTITION OF THE COLUMNS OF THE JACOBIAN MATRIX. ! COLUMN JCOL BELONGS TO GROUP NGRP(JCOL). ! NUMGRP IS A POSITIVE INTEGER INPUT VARIABLE SET TO A GROUP ! NUMBER IN THE PARTITION. THE COLUMNS OF THE JACOBIAN ! MATRIX IN THIS GROUP ARE TO BE ESTIMATED ON THIS CALL. ! D IS AN INPUT ARRAY OF LENGTH N WHICH CONTAINS THE ! DIFFERENCE PARAMETER VECTOR FOR THE ESTIMATE OF ! THE JACOBIAN MATRIX COLUMNS IN GROUP NUMGRP. ! FJACD IS AN INPUT ARRAY OF LENGTH M WHICH CONTAINS ! AN APPROXIMATION TO THE DIFFERENCE VECTOR JAC*D, ! WHERE JAC DENOTES THE JACOBIAN MATRIX. ! FJAC IS AN OUTPUT ARRAY OF LENGTH NNZ, WHERE NNZ IS THE ! NUMBER OF ITS NON-ZERO ELEMENTS. AT EACH CALL OF FDJS, ! FJAC IS UPDATED TO INCLUDE THE NON-ZERO ELEMENTS OF THE ! JACOBIAN MATRIX FOR THOSE COLUMNS IN GROUP NUMGRP. FJAC ! SHOULD NOT BE ALTERED BETWEEN SUCCESSIVE CALLS TO FDJS. ! ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. JULY 1983. ! THOMAS F. COLEMAN, BURTON S. GARBOW, JORGE J. MORE' IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: WP = KIND(0.0D0) ! .. ! .. Scalar Arguments .. INTEGER :: M, N, NUMGRP LOGICAL :: COL ! .. ! .. Array Arguments .. KPP_REAL :: D(N), FJAC(*), FJACD(M) INTEGER :: IND(*), NGRP(N), NPNTR(*) ! .. ! .. Local Scalars .. INTEGER :: IP, IROW, JCOL, JP ! .. ! .. Intrinsic Functions .. ! INTRINSIC KIND ! .. ! .. FIRST EXECUTABLE STATEMENT FDJS ! .. ! COMPUTE ESTIMATES OF JACOBIAN MATRIX COLUMNS IN GROUP ! NUMGRP. THE ARRAY FJACD MUST CONTAIN AN APPROXIMATION ! TO JAC*D, WHERE JAC DENOTES THE JACOBIAN MATRIX AND D ! IS A DIFFERENCE PARAMETER VECTOR WITH D(JCOL) NON-ZERO ! IF AND ONLY IF JCOL IS A COLUMN IN GROUP NUMGRP. IF (COL) THEN ! COLUMN ORIENTATION. DO JCOL = 1, N IF (NGRP(JCOL) == NUMGRP) THEN DO JP = NPNTR(JCOL), NPNTR(JCOL+1) - 1 IROW = IND(JP) FJAC(JP) = FJACD(IROW)/D(JCOL) END DO END IF END DO ELSE ! ROW ORIENTATION. DO IROW = 1, M DO IP = NPNTR(IROW), NPNTR(IROW+1) - 1 JCOL = IND(IP) IF (NGRP(JCOL) == NUMGRP) THEN FJAC(IP) = FJACD(IROW)/D(JCOL) GOTO 40 END IF END DO 40 CONTINUE END DO END IF RETURN END SUBROUTINE FDJS !_______________________________________________________________________ SUBROUTINE DVDSM(M,N,NPAIRS,INDROW,INDCOL,NGRP,MAXGRP,MINGRP,INFO, & IPNTR, JPNTR,IWA,LIWA) ! THE PURPOSE OF DSM IS TO DETERMINE AN OPTIMAL OR NEAR- ! OPTIMAL CONSISTENT PARTITION OF THE COLUMNS OF A SPARSE ! M BY N MATRIX A. ! THE SPARSITY PATTERN OF THE MATRIX A IS SPECIFIED BY ! THE ARRAYS INDROW AND INDCOL. ON INPUT THE INDICES ! FOR THE NON-ZERO ELEMENTS OF A ARE ! INDROW(K),INDCOL(K), K = 1,2,...,NPAIRS. ! THE(INDROW,INDCOL) PAIRS MAY BE SPECIFIED IN ANY ORDER. ! DUPLICATE INPUT PAIRS ARE PERMITTED, BUT THE SUBROUTINE ! ELIMINATES THEM. ! THE SUBROUTINE PARTITIONS THE COLUMNS OF A INTO GROUPS ! SUCH THAT COLUMNS IN THE SAME GROUP DO NOT HAVE A ! NON-ZERO IN THE SAME ROW POSITION. A PARTITION OF THE ! COLUMNS OF A WITH THIS PROPERTY IS CONSISTENT WITH THE ! DIRECT DETERMINATION OF A. ! THE SUBROUTINE STATEMENT IS ! SUBROUTINE DVDSM(M,N,NPAIRS,INDROW,INDCOL,NGRP,MAXGRP,MINGRP, ! INFO,IPNTR,JPNTR,IWA,LIWA) ! WHERE ! M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER ! OF ROWS OF A. ! N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER ! OF COLUMNS OF A. ! NPAIRS IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE ! NUMBER OF (INDROW,INDCOL) PAIRS USED TO DESCRIBE THE ! SPARSITY PATTERN OF A. ! INDROW IS AN INTEGER ARRAY OF LENGTH NPAIRS. ON INPUT INDROW ! MUST CONTAIN THE ROW INDICES OF THE NON-ZERO ELEMENTS OF A. ! ON OUTPUT INDROW IS PERMUTED SO THAT THE CORRESPONDING ! COLUMN INDICES ARE IN NON-DECREASING ORDER. THE COLUMN ! INDICES CAN BE RECOVERED FROM THE ARRAY JPNTR. ! INDCOL IS AN INTEGER ARRAY OF LENGTH NPAIRS. ON INPUT INDCOL ! MUST CONTAIN THE COLUMN INDICES OF THE NON-ZERO ELEMENTS OF ! A. ON OUTPUT INDCOL IS PERMUTED SO THAT THE CORRESPONDING ! ROW INDICES ARE IN NON-DECREASING ORDER. THE ROW INDICES ! CAN BE RECOVERED FROM THE ARRAY IPNTR. ! NGRP IS AN INTEGER OUTPUT ARRAY OF LENGTH N WHICH SPECIFIES ! THE PARTITION OF THE COLUMNS OF A. COLUMN JCOL BELONGS ! TO GROUP NGRP(JCOL). ! MAXGRP IS AN INTEGER OUTPUT VARIABLE WHICH SPECIFIES THE ! NUMBER OF GROUPS IN THE PARTITION OF THE COLUMNS OF A. ! MINGRP IS AN INTEGER OUTPUT VARIABLE WHICH SPECIFIES A LOWER ! BOUND FOR THE NUMBER OF GROUPS IN ANY CONSISTENT PARTITION ! OF THE COLUMNS OF A. ! INFO IS AN INTEGER OUTPUT VARIABLE SET AS FOLLOWS. FOR ! NORMAL TERMINATION INFO = 1. IF M, N, OR NPAIRS IS NOT ! POSITIVE OR LIWA IS LESS THAN MAX(M,6*N), THEN INFO = 0. ! IF THE K-TH ELEMENT OF INDROW IS NOT AN INTEGER BETWEEN ! 1 AND M OR THE K-TH ELEMENT OF INDCOL IS NOT AN INTEGER ! BETWEEN 1 AND N, THEN INFO = -K. ! IPNTR IS AN INTEGER OUTPUT ARRAY OF LENGTH M + 1 WHICH ! SPECIFIES THE LOCATIONS OF THE COLUMN INDICES IN INDCOL. ! THE COLUMN INDICES FOR ROW I ARE ! INDCOL(K), K = IPNTR(I),...,IPNTR(I+1)-1. ! NOTE THAT IPNTR(M+1)-1 IS THEN THE NUMBER OF NON-ZERO ! ELEMENTS OF THE MATRIX A. ! JPNTR IS AN INTEGER OUTPUT ARRAY OF LENGTH N + 1 WHICH ! SPECIFIES THE LOCATIONS OF THE ROW INDICES IN INDROW. ! THE ROW INDICES FOR COLUMN J ARE ! INDROW(K), K = JPNTR(J),...,JPNTR(J+1)-1. ! NOTE THAT JPNTR(N+1)-1 IS THEN THE NUMBER OF NON-ZERO ! ELEMENTS OF THE MATRIX A. ! IWA IS AN INTEGER WORK ARRAY OF LENGTH LIWA. ! LIWA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN ! MAX(M,6*N). ! MINPACK-SUPPLIED ... DEGR,IDO,NUMSRT,SEQ,SETR,SLO,SRTDAT ! INTRINSIC - MAX ! ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. JULY 1983. ! THOMAS F. COLEMAN, BURTON S. GARBOW, JORGE J. MORE' IMPLICIT NONE ! .. Scalar Arguments .. INTEGER :: INFO, LIWA, M, MAXGRP, MINGRP, N, NPAIRS ! .. ! .. Array Arguments .. INTEGER :: INDCOL(NPAIRS), INDROW(NPAIRS), IPNTR(M+1), IWA(LIWA), & JPNTR(N+1), NGRP(N) ! .. ! .. Local Scalars .. INTEGER :: I, IR, J, JP, K, MAXCLQ, NNZ, NUMGRP ! .. ! .. External Subroutines .. ! EXTERNAL DEGR, IDO, NUMSRT, SEQ, SETR, SLO, SRTDAT ! .. ! .. Intrinsic Functions .. INTRINSIC MAX ! .. ! .. FIRST EXECUTABLE STATEMENT DSM ! .. ! CHECK THE INPUT DATA. INFO = 0 IF (M<1 .OR. N<1 .OR. NPAIRS<1 .OR. LIWAM .OR. INDCOL(K)<1 .OR. INDCOL(K)>N) & RETURN END DO INFO = 1 ! SORT THE DATA STRUCTURE BY COLUMNS. CALL SRTDAT(N,NPAIRS,INDROW,INDCOL,JPNTR,IWA) ! COMPRESS THE DATA AND DETERMINE THE NUMBER OF ! NON-ZERO ELEMENTS OF A. IWA(1:M) = 0 NNZ = 1 DO J = 1, N K = NNZ DO JP = JPNTR(J), JPNTR(J+1) - 1 IR = INDROW(JP) IF (IWA(IR)/=J) THEN INDROW(NNZ) = IR NNZ = NNZ + 1 IWA(IR) = J END IF END DO JPNTR(J) = K END DO JPNTR(N+1) = NNZ ! EXTEND THE DATA STRUCTURE TO ROWS. CALL SETR(M,N,INDROW,JPNTR,INDCOL,IPNTR,IWA) ! DETERMINE A LOWER BOUND FOR THE NUMBER OF GROUPS. MINGRP = 0 DO I = 1, M MINGRP = MAX(MINGRP,IPNTR(I+1)-IPNTR(I)) END DO ! DETERMINE THE DEGREE SEQUENCE FOR THE INTERSECTION ! GRAPH OF THE COLUMNS OF A. CALL DEGR(N,INDROW,JPNTR,INDCOL,IPNTR,IWA(5*N+1),IWA(N+1)) ! COLOR THE INTERSECTION GRAPH OF THE COLUMNS OF A ! WITH THE SMALLEST-LAST (SL) ORDERING. CALL SLO(N,INDROW,JPNTR,INDCOL,IPNTR,IWA(5*N+1),IWA(4*N+1),MAXCLQ, & IWA(1),IWA(N+1),IWA(2*N+1),IWA(3*N+1)) CALL SEQ(N,INDROW,JPNTR,INDCOL,IPNTR,IWA(4*N+1),NGRP,MAXGRP,IWA(N+1)) MINGRP = MAX(MINGRP,MAXCLQ) ! EXIT IF THE SMALLEST-LAST ORDERING IS OPTIMAL. IF (MAXGRP == MINGRP) RETURN ! COLOR THE INTERSECTION GRAPH OF THE COLUMNS OF A ! WITH THE INCIDENCE-DEGREE(ID) ORDERING. CALL IDO(M,N,INDROW,JPNTR,INDCOL,IPNTR,IWA(5*N+1),IWA(4*N+1),MAXCLQ, & IWA(1),IWA(N+1),IWA(2*N+1),IWA(3*N+1)) CALL SEQ(N,INDROW,JPNTR,INDCOL,IPNTR,IWA(4*N+1),IWA(1),NUMGRP,IWA(N+1)) MINGRP = MAX(MINGRP,MAXCLQ) ! RETAIN THE BETTER OF THE TWO ORDERINGS SO FAR. IF (NUMGRP < MAXGRP) THEN MAXGRP = NUMGRP NGRP(1:N) = IWA(1:N) ! EXIT IF THE INCIDENCE-DEGREE ORDERING IS OPTIMAL. IF (MAXGRP == MINGRP) RETURN END IF ! COLOR THE INTERSECTION GRAPH OF THE COLUMNS OF A ! WITH THE LARGEST-FIRST (LF) ORDERING. CALL NUMSRT(N,N-1,IWA(5*N+1),-1,IWA(4*N+1),IWA(2*N+1),IWA(N+1)) CALL SEQ(N,INDROW,JPNTR,INDCOL,IPNTR,IWA(4*N+1),IWA(1),NUMGRP,IWA(N+1)) ! RETAIN THE BEST OF THE THREE ORDERINGS AND EXIT. IF (NUMGRP < MAXGRP) THEN MAXGRP = NUMGRP NGRP(1:N) = IWA(1:N) END IF RETURN END SUBROUTINE DVDSM !_______________________________________________________________________ SUBROUTINE DGROUPDS(N,MAXGRPDS,NGRPDS,IGP,JGP) ! .. ! Construct the column grouping arrays IGP anf JGP needed by DVJACS28 ! from the DSM array NGRPDS. ! .. ! Input: ! ! N = the order of the matrix ! MAXGRPDS = number of groups (from DSM) ! NGRPDS = DSM output array ! Output: ! JGP = array of length N containing the column ! indices by groups ! IGP = pointer array of length NGRP + 1 to the ! locations in JGP of the beginning of ! each group ! .. IMPLICIT NONE ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: N, MAXGRPDS ! .. ! .. Array Arguments .. INTEGER, INTENT (IN) :: NGRPDS(MAXGRPDS) INTEGER, INTENT (OUT) :: IGP(MAXGRPDS+1), JGP(N) ! .. ! .. Local Scalars .. INTEGER :: IGRP, INDEX, JCOL ! .. ! .. FIRST EXECUTABLE STATEMENT DGROUPDS ! .. IGP(1) = 1 INDEX = 0 DO IGRP = 1, MAXGRPDS IGP(IGRP+1) = IGP(IGRP) DO JCOL = 1, N IF (NGRPDS(JCOL) == IGRP) THEN IGP(IGRP+1) = IGP(IGRP+1) + 1 INDEX = INDEX + 1 JGP(INDEX) = JCOL END IF END DO END DO RETURN END SUBROUTINE DGROUPDS !_______________________________________________________________________ SUBROUTINE JACSPDB(FCN,N,T,Y,F,FJAC,NRFJAC,YSCALE,FAC,IOPT, & WK,LWK,IWK,LIWK,MAXGRP,NGRP,JPNTR,INDROW) ! This is a modified version of JACSP which does not require the NGRP, ! JPNTR and INDROW sparse pointer arrays in the event a dense or a ! banded matrix is being processed. ! Refer to the documentation for JACSP for a description of the ! parameters. If the banded option is used, IOPT(5) is used to ! input the lower bandwidth ML in this version. IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: WP = KIND(0.0D0) ! .. ! .. Scalar Arguments .. KPP_REAL :: T INTEGER :: LIWK, LWK, MAXGRP, N, NRFJAC ! .. ! .. Array Arguments .. KPP_REAL :: F(N), FAC(N), FJAC(NRFJAC,*), WK(LWK), Y(N), YSCALE(*) INTEGER :: INDROW(*), IOPT(5), IWK(LIWK), JPNTR(*), NGRP(N) ! .. ! .. Subroutine Arguments .. EXTERNAL FCN ! .. ! .. Local Scalars .. KPP_REAL :: ADIFF, AY, DEL, DELM, DFMJ, DIFF, DMAX, EXPFMN, FACMAX, & FACMIN, FJACL, FMJ, ONE, P125, P25, P75, P875, PERT, RDEL, RMNFDF, & RMXFDF, SDF, SF, SGN, T1, T2, U, U3QRT, U7EGT, UEGT, UMEGT, UQRT, & USQT, ZERO INTEGER :: IDXL, IDXU, IFLAG1, IFLAG2, IRCMP, IRDEL, IROW, IROWB, & IROWMX, ITRY, J, JCOL, JFIRST, JINC, JLAST, KT1, KT2, KT3, KT4, & KT5, L, MBAND, ML, MU, NID1, NID2, NID3, NID4, NID5, NID6, & NIFAC, NT2, NUMGRP ! KT5, L, MBAND, MEB1, ML, MU, NID1, NID2, NID3, NID4, NID5, NID6, & LOGICAL :: DOTHISBLOCK CHARACTER (80) :: MSG ! .. ! .. Intrinsic Functions .. ! INTRINSIC ABS, EPSILON, KIND, MAX, MIN, SIGN, SQRT INTRINSIC ABS, EPSILON, MAX, MIN, SIGN, SQRT ! .. ! .. Data Statements .. DATA PERT/2.0E+0_dp/, FACMAX/1.E-1_dp/, EXPFMN/.75E+0_dp/ DATA ONE/1.0E0_dp/, ZERO/0.0E0_dp/ DATA P125/.125E+0_dp/, P25/.25E+0_dp/, P75/.75E+0_dp/, P875/.875E+0_dp/ DATA NIFAC/3/, NID1/10/, NID2/20/, NID3/30/, NID4/40/, NID5/50/ ! .. ! COMPUTE ALGORITHM AND MACHINE CONSTANTS. ! .. ! .. FIRST EXECUTABLE STATEMENT JACSPDB ! .. IF (IOPT(1) == 0 .AND. MAXGRP /= N) THEN MSG = 'JACSPDB requires that MAXGRP=N for a dense matrix.' CALL XERRDV(MSG,1800,2,0,0,0,0,ZERO,ZERO) END IF IF (IOPT(1) == 1) THEN MBAND = IOPT(2) ML = IOPT(5) MU = MBAND - ML - 1 ! MEB1 = 2*ML + MU END IF U = EPSILON(ONE) USQT = SQRT(U) UEGT = U**P125 UMEGT = ONE/UEGT UQRT = U**P25 U3QRT = U**P75 U7EGT = U**P875 FACMIN = U**EXPFMN IF (IOPT(4) == 0) THEN IOPT(4) = 1 DO 10 J = 1, N FAC(J) = USQT 10 CONTINUE END IF DO 20 J = 1, 50 IWK(J) = 0 20 CONTINUE KT1 = NID1 KT2 = NID2 KT3 = NID3 KT4 = NID4 KT5 = NID5 NID6 = LIWK NT2 = 2*N DO NUMGRP = 1, MAXGRP ! COMPUTE AND SAVE THE INCREMENTS FOR THE COLUMNS IN GROUP NUMGRP. IRCMP = 0 ITRY = 0 DO 30 J = NID5 + 1, NID6 IWK(J) = 0 30 CONTINUE 40 CONTINUE ! Note: For banded in DVJAC: ! mba = min(mband,n) ! Groups: j=1,...,mba ! Columns in group j: jj=j,...,n by mband ! Rows in column jj: i1=max(jj-mu,1),...,i2=min(jj+ml,n) IF (IOPT(1) == 0 .OR. IOPT(1) == 2) THEN JFIRST = 1 JLAST = N JINC = 1 ELSE JFIRST = NUMGRP JLAST = N JINC = MBAND END IF DO JCOL = JFIRST, JLAST, JINC DOTHISBLOCK = .FALSE. IF (IOPT(1) == 2) THEN IF (NGRP(JCOL) == NUMGRP) DOTHISBLOCK = .TRUE. ELSE IF (IOPT(1) == 0) THEN IF (JCOL == NUMGRP) DOTHISBLOCK = .TRUE. ELSE IF (IOPT(1) == 1) THEN DOTHISBLOCK = .TRUE. END IF END IF END IF IF (DOTHISBLOCK) THEN WK(N+JCOL) = Y(JCOL) ! COMPUTE DEL. IF DEL IS TOO SMALL INCREASE FAC(JCOL) AND RECOMPUTE ! DEL. NIFAC ATTEMPTS ARE MADE TO INCREASE FAC(JCOL) AND FIND AN ! APPROPRIATE DEL. IF DEL CANT BE FOUND IN THIS MANNER, DEL IS COMPUTED ! WITH FAC(JCOL) SET TO THE SQUARE ROOT OF THE MACHINE PRECISION (USQT). ! IF DEL IS ZERO TO MACHINE PRECISION BECAUSE Y(JCOL) IS ZERO OR ! YSCALE(JCOL) IS ZERO, DEL IS SET TO USQT. SGN = SIGN(ONE,F(JCOL)) IRDEL = 0 IF (IOPT(3) == 1) THEN AY = ABS(YSCALE(JCOL)) ELSE AY = ABS(Y(JCOL)) END IF DELM = U7EGT*AY DO 50 J = 1, NIFAC DEL = FAC(JCOL)*AY*SGN IF (ABS(DEL) <= ZERO) THEN DEL = USQT*SGN IF (ITRY == 0) IWK(3) = IWK(3) + 1 END IF T1 = Y(JCOL) + DEL DEL = T1 - Y(JCOL) IF (ABS(DEL) < DELM) THEN IF (J >= NIFAC) GOTO 50 IF (IRDEL == 0) THEN IRDEL = 1 IWK(1) = IWK(1) + 1 END IF T1 = FAC(JCOL)*UMEGT FAC(JCOL) = MIN(T1,FACMAX) ELSE GOTO 60 END IF 50 END DO FAC(JCOL) = USQT DEL = USQT*AY*SGN IWK(2) = IWK(2) + 1 IF (KT2 < NID3) THEN KT2 = KT2 + 1 IWK(KT2) = JCOL END IF 60 CONTINUE WK(NT2+JCOL) = DEL Y(JCOL) = Y(JCOL) + DEL END IF END DO IWK(7) = IWK(7) + 1 CALL FCN(N,T,Y,WK) DO JCOL = JFIRST, JLAST, JINC IF (IOPT(1) == 2) THEN IF (NGRP(JCOL) == NUMGRP) Y(JCOL) = WK(N+JCOL) ELSE IF (IOPT(1) == 0) THEN IF (JCOL == NUMGRP) Y(JCOL) = WK(N+JCOL) ELSE IF (IOPT(1) == 1) Y(JCOL) = WK(N+JCOL) END IF END IF END DO ! COMPUTE THE JACOBIAN ENTRIES FOR ALL COLUMNS IN NUMGRP. ! STORE ENTRIES ACCORDING TO SELECTED STORAGE FORMAT. ! USE LARGEST ELEMENTS IN A COLUMN TO DETERMINE SCALING ! INFORMATION FOR ROUNDOFF AND TRUNCATION ERROR TESTS. DO JCOL = JFIRST, JLAST, JINC DOTHISBLOCK = .FALSE. IF (IOPT(1) == 2) THEN IF (NGRP(JCOL) == NUMGRP) DOTHISBLOCK = .TRUE. ELSE IF (IOPT(1) == 0) THEN IF (JCOL == NUMGRP) DOTHISBLOCK = .TRUE. ELSE IF(IOPT(1) == 1) DOTHISBLOCK = .TRUE. END IF END IF IF (DOTHISBLOCK) THEN IF (IOPT(1) == 2) THEN IDXL = JPNTR(JCOL) IDXU = JPNTR(JCOL+1) - 1 ELSE IF (IOPT(1) == 0) THEN IDXL = 1 IDXU = N ELSE IF (IOPT(1) == 1) THEN IDXL = MAX(JCOL-MU,1) IDXU = MIN(JCOL+ML,N) END IF END IF END IF DMAX = ZERO RDEL = ONE/WK(NT2+JCOL) IROWMX = 1 DO L = IDXL, IDXU IF (IOPT(1) == 2) THEN IROW = INDROW(L) ELSE IF (IOPT(1)==0 .OR. IOPT(1)==1) IROW = L END IF DIFF = WK(IROW) - F(IROW) ADIFF = ABS(DIFF) IF (ADIFF >= DMAX) THEN IROWMX = IROW DMAX = ADIFF SF = F(IROW) SDF = WK(IROW) END IF FJACL = DIFF*RDEL IF (ITRY == 1) WK(IROW) = FJACL IF (IOPT(1) == 0) THEN IF (ITRY == 1) WK(IROW+N) = FJAC(IROW,JCOL) FJAC(IROW,JCOL) = FJACL END IF IF (IOPT(1) == 1) THEN IROWB = IROW - JCOL + IOPT(2) IF (ITRY == 1) WK(IROW+N) = FJAC(IROWB,JCOL) FJAC(IROWB,JCOL) = FJACL ! IROWB = JCOL * MEB1 - ML + L ! IF (ITRY == 1) WK(IROW+N) = FJAC(IROWB,1) ! FJAC(IROWB,1) = FJACL END IF IF (IOPT(1) == 2) THEN IF (ITRY == 1) WK(IROW+N) = FJAC(L,1) FJAC(L,1) = FJACL END IF END DO ! IF A COLUMN IS BEING RECOMPUTED (ITRY=1),THIS SECTION OF THE ! CODE PERFORMS AN EXTRAPOLATION TEST TO ENABLE THE CODE TO ! COMPUTE SMALL DERIVATIVES MORE ACCURATELY. THIS TEST IS ONLY ! PERFORMED ON THOSE COLUMNS WHOSE LARGEST DIFFERENCE IS CLOSE ! TO ZERO RELATIVE TO SCALE. IF (ITRY == 1) THEN IFLAG1 = 0 IFLAG2 = 0 DO 100 J = NID5 + 1, NID6 IF (IWK(J) == JCOL) IFLAG1 = 1 100 CONTINUE IF (IFLAG1 == 1) THEN IFLAG1 = 0 T1 = WK(IROWMX+N) T2 = WK(IROWMX)*FAC(JCOL) IF (ABS(T2) < ABS(T1)*PERT) IFLAG2 = 1 END IF IF (IFLAG2 == 1) THEN IFLAG2 = 0 T1 = FAC(JCOL)*FAC(JCOL) FAC(JCOL) = MAX(T1,FACMIN) DO L = IDXL, IDXU IF (IOPT(1) == 2) THEN IROW = INDROW(L) ELSE IF (IOPT(1)==0 .OR. IOPT(1)==1) IROW = L END IF FJACL = WK(IROW+N) IF (IOPT(1) == 0) FJAC(IROW,JCOL) = FJACL IF (IOPT(1) == 1) THEN IROWB = IROW - JCOL + IOPT(2) FJAC(IROWB,JCOL) = FJACL ! IROWB = JCOL * MEB1 - ML + L ! FJAC(IROWB,1) = FJACL END IF IF (IOPT(1) == 2) FJAC(L,1) = FJACL END DO END IF END IF FMJ = ABS(SF) DFMJ = ABS(SDF) RMXFDF = MAX(FMJ,DFMJ) RMNFDF = MIN(FMJ,DFMJ) ! IF SCALE INFORMATION IS NOT AVAILABLE, PERFORM NO ROUNDOFF ! OR TRUNCATION ERROR TESTS. IF THE EXTRAPOLATION TEST HAS ! CAUSED FAC(JCOL) TO BE RESET TO ITS PREVIOUS VALUE (IAJAC=1) ! THEN NO FURTHER ROUNDOFF OR TRUNCATION ERROR TESTS ARE ! PERFORMED. ! IF (RMNFDF/=ZERO) THEN IF (ABS(RMNFDF) > ZERO) THEN ! TEST FOR POSSIBLE ROUNDOFF ERROR (FIRST TEST) ! AND ALSO FOR POSSIBLE SERIOUS ROUNDOFF ERROR (SECOND TEST). IF (DMAX <= (U3QRT*RMXFDF)) THEN IF (DMAX <= (U7EGT*RMXFDF)) THEN IF (ITRY == 0) THEN T1 = SQRT(FAC(JCOL)) FAC(JCOL) = MIN(T1,FACMAX) IRCMP = 1 IF (KT5 < NID6) THEN KT5 = KT5 + 1 IWK(KT5) = JCOL END IF IWK(4) = IWK(4) + 1 IF (KT3 < NID4) THEN KT3 = KT3 + 1 IWK(KT3) = JCOL END IF ELSE IWK(5) = IWK(5) + 1 IF (KT4 < NID5) THEN KT4 = KT4 + 1 IWK(KT4) = JCOL END IF END IF ELSE T1 = UMEGT*FAC(JCOL) FAC(JCOL) = MIN(T1,FACMAX) END IF END IF ! TEST FOR POSSIBLE TRUNCATION ERROR. IF (DMAX > UQRT*RMXFDF) THEN T1 = FAC(JCOL)*UEGT FAC(JCOL) = MAX(T1,FACMIN) IWK(8) = IWK(8) + 1 IF (KT1 < NID2) THEN KT1 = KT1 + 1 IWK(KT1) = JCOL END IF END IF ELSE IWK(6) = IWK(6) + 1 END IF END IF END DO ! IF SERIOUS ROUNDOFF ERROR IS SUSPECTED, RECOMPUTE ALL ! COLUMNS IN GROUP NUMGRP. IF (IRCMP == 1) THEN IRCMP = 0 ITRY = 1 GOTO 40 END IF ITRY = 0 END DO RETURN END SUBROUTINE JACSPDB ! End of JACSP routines. !_______________________________________________________________________ ! *****MA48 build change point. Insert the MA48 Jacobian related ! routines DVNLSS48, DVSOLS48, DVPREPS48, and DVJACS48 here. ! filename = jacobian_for_ma48.f90. Insert the following line ! after the first line of this file: ! USE hsl_ma48_double !_______________________________________________________________________ ! *****LAPACK build change point. Insert the following line after the ! first line of this file: ! USE lapackd_f90_m ! Include the module lapackd_f90_m.f90 at the beginning of this file ! or as an external module. !_______________________________________________________________________ END MODULE DVODE END MODULE KPP_ROOT_Integrator !_______________________________________________________________________