New changes from l2g
w
This commit is contained in:
@@ -0,0 +1,151 @@
|
||||
C This sample problem comes from Zwolak et al. 2001 (High Performance Computing
|
||||
C Symposium, "Estimating rate constants in cell cycle models"). The call to
|
||||
C ODRPACK95 is modified from the call the authors make to ODRPACK. This is
|
||||
C done to illustrate the need for bounds. The authors could just have easily
|
||||
C used the call statement here to solve their problem.
|
||||
C
|
||||
C Curious users are encouraged to remove the bounds in the call statement,
|
||||
C run the code, and compare the results to the current call statement.
|
||||
PROGRAM SAMPLE
|
||||
USE REAL_PRECISION
|
||||
USE ODRPACK95
|
||||
IMPLICIT NONE
|
||||
C INTEGER :: I
|
||||
C REAL (KIND=R8) :: C, M, TOUT
|
||||
INTERFACE
|
||||
SUBROUTINE FCN(N,M,NP,NQ,LDN,LDM,LDNP,BETA,XPLUSD,IFIXB,
|
||||
+ IFIXX,LDIFX,IDEVAL,F,FJACB,FJACD,ISTOP)
|
||||
USE REAL_PRECISION
|
||||
INTEGER, INTENT(IN) :: IDEVAL,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ
|
||||
INTEGER, INTENT(IN) :: IFIXB(NP),IFIXX(LDIFX,M)
|
||||
REAL(KIND=R8), INTENT(IN) :: BETA(NP),XPLUSD(LDN,M)
|
||||
INTEGER, INTENT(OUT) :: ISTOP
|
||||
REAL(KIND=R8), INTENT(OUT) :: F(LDN,NQ),FJACB(LDN,LDNP,NQ),
|
||||
+ FJACD(LDN,LDM,NQ)
|
||||
END SUBROUTINE FCN
|
||||
END INTERFACE
|
||||
REAL(KIND=R8) :: BETA(3) = (/ 1.1E-0_R8, 3.3E+0_R8, 8.7_R8 /)
|
||||
OPEN(9,FILE="REPORT4")
|
||||
CALL ODR(
|
||||
+ FCN,
|
||||
+ N = 5, M = 1, NP = 3, NQ = 1,
|
||||
+ BETA = BETA,
|
||||
+ Y = RESHAPE((/ 55.0_R8, 45.0_R8, 40.0_R8, 30.0_R8, 20.0_R8 /),
|
||||
+ (/5,1/)),
|
||||
+ X = RESHAPE((/ 0.15_R8, 0.20_R8, 0.25_R8, 0.30_R8, 0.50_R8 /),
|
||||
+ (/5,1/)),
|
||||
+ LOWER = (/ 0.0_R8, 0.0_R8, 0.0_R8 /),
|
||||
+ UPPER = (/ 1000.0_R8, 1000.0_R8, 1000.0_R8 /),
|
||||
+ IPRINT = 2122,
|
||||
+ LUNRPT = 9,
|
||||
+ MAXIT = 20
|
||||
+)
|
||||
CLOSE(9)
|
||||
C The following code will reproduce the plot in Figure 2 of Zwolak et
|
||||
C al. 2001.
|
||||
C DO I = 0, 100
|
||||
C C = 0.05+(0.7-0.05)*I/100
|
||||
C TOUT = 1440.0D0
|
||||
C !CALL MPF(M,C,1.1D-10,3.3D-3,8.7D0,0.0D0,TOUT,C/2)
|
||||
C CALL MPF(M,C,1.15395968E-02_R8, 2.61676386E-03_R8,
|
||||
C + 9.23138811E+00_R8,0.0D0,TOUT,C/2)
|
||||
C WRITE(*,*) C, TOUT
|
||||
C END DO
|
||||
END PROGRAM
|
||||
|
||||
SUBROUTINE FCN(N,M,NP,NQ,LDN,LDM,LDNP,BETA,XPLUSD,IFIXB,
|
||||
+ IFIXX,LDIFX,IDEVAL,F,FJACB,FJACD,ISTOP)
|
||||
USE REAL_PRECISION
|
||||
IMPLICIT NONE
|
||||
INTEGER, INTENT(IN) :: IDEVAL,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ
|
||||
INTEGER, INTENT(IN) :: IFIXB(NP),IFIXX(LDIFX,M)
|
||||
REAL(KIND=R8), INTENT(IN) :: BETA(NP),XPLUSD(LDN,M)
|
||||
INTEGER, INTENT(OUT) :: ISTOP
|
||||
REAL(KIND=R8), INTENT(OUT) :: F(LDN,NQ),FJACB(LDN,LDNP,NQ),
|
||||
+ FJACD(LDN,LDM,NQ)
|
||||
! Local variables
|
||||
REAL(KIND=R8) :: MOUT
|
||||
INTEGER :: I
|
||||
ISTOP = 0
|
||||
FJACB(:,:,:) = 0.0E0_R8
|
||||
FJACD(:,:,:) = 0.0E0_R8
|
||||
IF ( MOD(IDEVAL,10).GE.1 ) THEN
|
||||
DO I = 1, N
|
||||
F(I,1) = 1440.0_R8
|
||||
CALL MPF(MOUT,XPLUSD(I,1),BETA(1),BETA(2),BETA(3),0.0_R8,
|
||||
+ F(I,1),XPLUSD(I,1)/2)
|
||||
END DO
|
||||
END IF
|
||||
END SUBROUTINE FCN
|
||||
|
||||
C-------------------------------------------------------------------------------
|
||||
C
|
||||
C MPF
|
||||
C
|
||||
C If ROOT is not zero then returns value of time when M==ROOT in TOUT. Else,
|
||||
C runs until TOUT and returns value in M. If PRINT_EVERY is non-zero then
|
||||
C the solution is printed every PRINT_EVERY time units or every H (which ever
|
||||
C is greater).
|
||||
C
|
||||
C This routine is not meant to be precise, it is only intended to be good
|
||||
C enough for providing a working example of ODRPACK95 with bounds. 4th order
|
||||
C Runge Kutta and linear interpolation are used for numerical integration and
|
||||
C root finding, respectively.
|
||||
C
|
||||
C M - MPF
|
||||
C C - Total Cyclin
|
||||
C KWEE, K25, K25P - Model parameters (BETA(1:3))
|
||||
C
|
||||
SUBROUTINE MPF(M,C,KWEE,K25,K25P,PRINT_EVERY,TOUT,ROOT)
|
||||
USE REAL_PRECISION
|
||||
REAL (KIND=R8), INTENT(OUT) :: M
|
||||
REAL (KIND=R8), INTENT(IN) :: C, KWEE, K25, K25P,
|
||||
+ PRINT_EVERY, ROOT
|
||||
REAL (KIND=R8), INTENT(INOUT) :: TOUT
|
||||
! Local variables
|
||||
REAL (KIND=R8), PARAMETER :: H = 1.0D-1
|
||||
REAL (KIND=R8) :: LAST_PRINT, LAST_M, LAST_T, T
|
||||
REAL (KIND=R8) :: K1, K2, K3, K4
|
||||
INTERFACE
|
||||
FUNCTION DMDT(M,C,KWEE,K25,K25P) RESULT(RES)
|
||||
USE REAL_PRECISION
|
||||
REAL (KIND=R8) :: M, C, KWEE, K25, K25P, RES
|
||||
END FUNCTION
|
||||
END INTERFACE
|
||||
M = 0.0D0
|
||||
T = 0.0D0
|
||||
LAST_PRINT = 0.0D0
|
||||
IF ( PRINT_EVERY .GT. 0.0D0 ) THEN
|
||||
WRITE(*,*) T, M
|
||||
END IF
|
||||
DO WHILE ( T .LT. TOUT )
|
||||
LAST_T = T
|
||||
LAST_M = M
|
||||
K1 = H*DMDT(M,C,KWEE,K25,K25P)
|
||||
K2 = H*DMDT(M+K1/2,C,KWEE,K25,K25P)
|
||||
K3 = H*DMDT(M+K2/2,C,KWEE,K25,K25P)
|
||||
K4 = H*DMDT(M+K3,C,KWEE,K25,K25P)
|
||||
M = M+(K1+2*K2+2*K3+K4)/6
|
||||
T = T + H
|
||||
IF ( T .GE. PRINT_EVERY+LAST_PRINT .AND.
|
||||
+ PRINT_EVERY .GT. 0.0D0 )
|
||||
+ THEN
|
||||
WRITE(*,*) T, M
|
||||
LAST_PRINT = T
|
||||
END IF
|
||||
IF ( ROOT .GT. 0.0D0 ) THEN
|
||||
IF ( LAST_M .LE. ROOT .AND. ROOT .LT. M ) THEN
|
||||
TOUT = (T-LAST_T)/(M-LAST_M)*(ROOT-LAST_M)+LAST_T
|
||||
RETURN
|
||||
END IF
|
||||
END IF
|
||||
END DO
|
||||
END SUBROUTINE MPF
|
||||
|
||||
|
||||
C Equation from Zwolak et al. 2001.
|
||||
FUNCTION DMDT(M,C,KWEE,K25,K25P) RESULT(RES)
|
||||
USE REAL_PRECISION
|
||||
REAL (KIND=R8) :: M, C, KWEE, K25, K25P, RES
|
||||
RES = KWEE*M+(K25+K25P*M**2)*(C-M)
|
||||
END FUNCTION DMDT
|
||||
Reference in New Issue
Block a user