New changes from l2g
w
This commit is contained in:
@@ -0,0 +1,241 @@
|
||||
*TESTER
|
||||
PROGRAM TESTER
|
||||
C***BEGIN PROLOGUE TESTER
|
||||
C***REFER TO ODR
|
||||
C***ROUTINES CALLED ODR
|
||||
C***DATE WRITTEN 20040322 (YYYYMMDD)
|
||||
C***REVISION DATE 20040322 (YYYYMMDD)
|
||||
C***PURPOSE EXCERCISE ERROR REPORTING OF THE F90 VERSION OF ODRPACK95
|
||||
C***END PROLOGUE TESTER
|
||||
|
||||
C...USED MODULES
|
||||
USE REAL_PRECISION
|
||||
USE ODRPACK95
|
||||
|
||||
C...LOCAL SCALARS
|
||||
INTEGER N, M, NQ, NP, INFO, LUN
|
||||
C STAT
|
||||
|
||||
C...LOCAL ARRAYS
|
||||
REAL (KIND=R8)
|
||||
& BETA(:),Y(:,:),X(:,:),UPPER(2),LOWER(2)
|
||||
|
||||
C...ALLOCATABLE ARRAYS
|
||||
ALLOCATABLE BETA,Y,X
|
||||
|
||||
C...EXTERNAL SUBPROGRAMS
|
||||
EXTERNAL FCN
|
||||
|
||||
COMMON /BOUNDS/ UPPER,LOWER
|
||||
|
||||
C***FIRST EXECUTABLE STATEMENT TESTER
|
||||
|
||||
OPEN(UNIT=8,FILE="SUMMARY")
|
||||
WRITE(8,*) "NO SUMMARY AVAILABLE"
|
||||
CLOSE(8)
|
||||
|
||||
LUN = 9
|
||||
OPEN(UNIT=LUN,FILE="REPORT")
|
||||
|
||||
C ERROR IN PROBLEM SIZE
|
||||
|
||||
N = 0
|
||||
M = 0
|
||||
NQ = 0
|
||||
NP = 0
|
||||
ALLOCATE(BETA(NP),Y(N,NQ),X(N,M))
|
||||
Y(:,:) = 0.0_R8
|
||||
X(:,:) = 0.0_R8
|
||||
BETA(:) = 0.0_R8
|
||||
|
||||
CALL ODR(FCN,N,M,NP,NQ,BETA,Y,X,IPRINT=1,INFO=INFO,
|
||||
& LUNRPT=LUN,LUNERR=LUN)
|
||||
|
||||
WRITE(LUN,*) "INFO = ", INFO
|
||||
|
||||
C ERROR IN JOB SPECIFICATION WITH WORK AND IWORK
|
||||
|
||||
N = 1
|
||||
M = 1
|
||||
NQ = 1
|
||||
NP = 1
|
||||
DEALLOCATE(BETA,Y,X)
|
||||
ALLOCATE(BETA(NP),Y(N,NQ),X(N,M))
|
||||
Y(:,:) = 0.0_R8
|
||||
X(:,:) = 0.0_R8
|
||||
BETA(:) = 0.0_R8
|
||||
|
||||
CALL ODR(FCN,N,M,NP,NQ,BETA,Y,X,IPRINT=1,INFO=INFO,JOB=10000,
|
||||
& LUNRPT=LUN,LUNERR=LUN)
|
||||
|
||||
WRITE(LUN,*) "INFO = ", INFO
|
||||
|
||||
C ERROR IN JOB SPECIFICATION WITH DELTA
|
||||
|
||||
N = 1
|
||||
M = 1
|
||||
NQ = 1
|
||||
NP = 1
|
||||
DEALLOCATE(BETA,Y,X)
|
||||
ALLOCATE(BETA(NP),Y(N,NQ),X(N,M))
|
||||
Y(:,:) = 0.0_R8
|
||||
X(:,:) = 0.0_R8
|
||||
BETA(:) = 0.0_R8
|
||||
|
||||
CALL ODR(FCN,N,M,NP,NQ,BETA,Y,X,IPRINT=1,INFO=INFO,JOB=1000,
|
||||
& LUNRPT=LUN,LUNERR=LUN)
|
||||
|
||||
WRITE(LUN,*) "INFO = ", INFO
|
||||
|
||||
C BOUNDS TOO SMALL FOR DERIVATIVE CHECKER WHEN DERIVATIVES DON'T AGREE.
|
||||
|
||||
N = 4
|
||||
M = 1
|
||||
NQ = 1
|
||||
NP = 2
|
||||
DEALLOCATE(BETA,Y,X)
|
||||
ALLOCATE(BETA(NP),Y(N,NQ),X(N,M))
|
||||
BETA(:) = (/ -200.0_R8, -5.0_R8 /)
|
||||
UPPER(1:2) = (/ -200.0_R8, 0.0_R8 /)
|
||||
LOWER(1:2) = (/ -200.000029802322_R8, -5.0_R8 /)
|
||||
Y(:,1) = (/ 2.718281828459045_R8, 7.389056098930650_R8,
|
||||
&148.4131591025766_R8, 403.4287934927353_R8 /)
|
||||
X(:,1) = (/ 1.0_R8, 2.0_R8, 5.0_R8, 6.0_R8 /)
|
||||
|
||||
CALL ODR(FCN,N,M,NP,NQ,BETA,Y,X,IPRINT=1,INFO=INFO,JOB=0020,
|
||||
& LUNRPT=LUN,LUNERR=LUN,LOWER=LOWER,UPPER=UPPER)
|
||||
|
||||
WRITE(LUN,*) "INFO = ", INFO
|
||||
|
||||
C ERROR IN ARRAY ALLOCATION
|
||||
C The following code is intended to force memory allocation failure. An
|
||||
C appropriate N for your machine must be chosen to ensure memory allocation
|
||||
C will fail within ODRPACK95. A value of about 1/4 the total memory available
|
||||
C to a process should do the trick. However, most modern operating systems and
|
||||
C Fortran compilers will not likely deny ODRPACK95 memory before they fail for
|
||||
C another reason. Therefore, the memory allocation checks in ODRPACK95 are not
|
||||
C easy to provoke. An operating system may return successfull memory
|
||||
C allocation but fail to guarantee the memory causing a segfault when some
|
||||
C memory locations are accessed. A Fortran compiler or operating system may
|
||||
C allow limited sized stacks during subroutine invocation causing the ODRPACK95
|
||||
C call to fail before ODRPACK95 executes its first line.
|
||||
C
|
||||
C N = 032000000
|
||||
C M = 1
|
||||
C NQ = 1
|
||||
C NP = 1
|
||||
C DEALLOCATE(BETA,Y,X)
|
||||
C ALLOCATE(BETA(NP),Y(N,NQ),X(N,M),STAT=STAT)
|
||||
C IF (STAT.NE.0) THEN
|
||||
C WRITE(0,*)
|
||||
C & "SYSTEM ERROR: COULD NOT ALLOCATE MEMORY, TESTER ",
|
||||
C & "FAILED TO RUN."
|
||||
C STOP
|
||||
C END IF
|
||||
C Y(:,:) = 0.0_R8
|
||||
C X(:,:) = 0.0_R8
|
||||
C BETA(:) = 0.0_R8
|
||||
C
|
||||
C CALL ODR(FCN,N,M,NP,NQ,BETA,Y,X,IPRINT=1,INFO=INFO,
|
||||
C & LUNRPT=LUN,LUNERR=LUN)
|
||||
C
|
||||
C WRITE(LUN,*) "INFO = ", INFO
|
||||
|
||||
CLOSE(LUN)
|
||||
|
||||
END PROGRAM
|
||||
*FCN
|
||||
SUBROUTINE FCN
|
||||
& (N,M,NP,NQ,
|
||||
& LDN,LDM,LDNP,
|
||||
& BETA,XPLUSD,
|
||||
& IFIXB,IFIXX,LDIFX,
|
||||
& IDEVAL,F,FJACB,FJACD,
|
||||
& ISTOP)
|
||||
C***BEGIN PROLOGUE FCN
|
||||
C***REFER TO ODR
|
||||
C***ROUTINES CALLED (NONE)
|
||||
C***DATE WRITTEN 20040322 (YYYYMMDD)
|
||||
C***REVISION DATE 20040322 (YYYYMMDD)
|
||||
C***PURPOSE DUMMY ROUTINE FOR ODRPACK95 ERROR EXERCISER
|
||||
C***END PROLOGUE FCN
|
||||
|
||||
C...USED MODULES
|
||||
USE REAL_PRECISION
|
||||
|
||||
C...SCALAR ARGUMENTS
|
||||
INTEGER
|
||||
& IDEVAL,ISTOP,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ
|
||||
|
||||
C...ARRAY ARGUMENTS
|
||||
REAL (KIND=R8)
|
||||
& BETA(NP),F(LDN,NQ),FJACB(LDN,LDNP,NQ),FJACD(LDN,LDM,NQ),
|
||||
& XPLUSD(LDN,M)
|
||||
INTEGER
|
||||
& IFIXB(NP),IFIXX(LDIFX,M)
|
||||
|
||||
C...ARRAYS IN COMMON
|
||||
REAL (KIND=R8)
|
||||
& LOWER(2),UPPER(2)
|
||||
|
||||
C...LOCAL SCALARS
|
||||
INTEGER
|
||||
& I
|
||||
|
||||
COMMON /BOUNDS/ UPPER,LOWER
|
||||
|
||||
|
||||
C***FIRST EXECUTABLE STATEMENT
|
||||
|
||||
C Do something with FJACD, FJACB, IFIXB and IFIXX to avoid warnings that they
|
||||
C are not being used. This is simply not to worry users that the example
|
||||
C program is failing.
|
||||
IF (IFIXB(1) .GT. 0 .AND. IFIXX(1,1) .GT. 0
|
||||
& .AND. FJACB(1,1,1) .GT. 0 .AND. FJACD(1,1,1) .GT. 0 ) THEN
|
||||
C Do nothing.
|
||||
END IF
|
||||
|
||||
|
||||
IF (ANY(LOWER(1:NP).GT.BETA(1:NP))) THEN
|
||||
WRITE(0,*) "LOWER BOUNDS VIOLATED"
|
||||
DO I=1,NP
|
||||
IF (LOWER(I).GT.BETA(I)) THEN
|
||||
WRITE(0,*) " IN THE ", I, " POSITION WITH ", BETA(I),
|
||||
& "<", LOWER(I)
|
||||
END IF
|
||||
END DO
|
||||
END IF
|
||||
|
||||
IF (ANY(UPPER(1:NP).LT.BETA(1:NP))) THEN
|
||||
WRITE(0,*) "UPPER BOUNDS VIOLATED"
|
||||
DO I=1,NP
|
||||
IF (UPPER(I).LT.BETA(I)) THEN
|
||||
WRITE(0,*) " IN THE ", I, " POSITION WITH ", BETA(I),
|
||||
& ">", UPPER(I)
|
||||
END IF
|
||||
END DO
|
||||
END IF
|
||||
|
||||
ISTOP = 0
|
||||
|
||||
IF (MOD(IDEVAL,10).NE.0) THEN
|
||||
DO I=1,N
|
||||
F(I,1) = BETA(1)*EXP(BETA(2)*XPLUSD(I,1))
|
||||
END DO
|
||||
END IF
|
||||
|
||||
IF (MOD(IDEVAL/10,10).NE.0) THEN
|
||||
DO I=1,N
|
||||
FJACB(I,1,1) = EXP(BETA(2)*XPLUSD(I,1))
|
||||
FJACB(I,2,1) = BETA(1)*XPLUSD(I,1)*EXP(BETA(2)*
|
||||
& XPLUSD(I,1))
|
||||
END DO
|
||||
END IF
|
||||
|
||||
IF (MOD(IDEVAL/100,10).NE.0) THEN
|
||||
DO I=1,N
|
||||
FJACD(I,1,1) = BETA(1)*BETA(2)*EXP(BETA(2)*XPLUSD(I,1))
|
||||
END DO
|
||||
END IF
|
||||
|
||||
END SUBROUTINE
|
||||
Reference in New Issue
Block a user