242 lines
6.2 KiB
FortranFixed
242 lines
6.2 KiB
FortranFixed
*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
|