New changes from l2g
w
This commit is contained in:
@@ -258,7 +258,7 @@
|
||||
call cplnsrch(nunknowns,xpold,fsqsumold,
|
||||
& gfuncsum,deltax,xp,fsqsumnew,stpmax,
|
||||
& check,funcnleq1,fequ)
|
||||
if(check.eq..true..or.check.eq..TRUE.)then
|
||||
if(check.eqv..true..or.check.eqv..TRUE.)then
|
||||
do i=1,nunknowns
|
||||
call reinitialization(x0min(i),xpold(i),
|
||||
& x0max(i),xp(i),6678)
|
||||
|
||||
@@ -0,0 +1,209 @@
|
||||
DOUBLE PRECISION FUNCTION D1MACH(I)
|
||||
INTEGER I
|
||||
C
|
||||
C DOUBLE-PRECISION MACHINE CONSTANTS
|
||||
C D1MACH( 1) = B**(EMIN-1), THE SMALLEST POSITIVE MAGNITUDE.
|
||||
C D1MACH( 2) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE.
|
||||
C D1MACH( 3) = B**(-T), THE SMALLEST RELATIVE SPACING.
|
||||
C D1MACH( 4) = B**(1-T), THE LARGEST RELATIVE SPACING.
|
||||
C D1MACH( 5) = LOG10(B)
|
||||
C
|
||||
INTEGER SMALL(2)
|
||||
INTEGER LARGE(2)
|
||||
INTEGER RIGHT(2)
|
||||
INTEGER DIVER(2)
|
||||
INTEGER LOG10(2)
|
||||
INTEGER SC, CRAY1(38), J
|
||||
COMMON /D9MACH/ CRAY1
|
||||
SAVE SMALL, LARGE, RIGHT, DIVER, LOG10, SC
|
||||
DOUBLE PRECISION DMACH(5)
|
||||
EQUIVALENCE (DMACH(1),SMALL(1))
|
||||
EQUIVALENCE (DMACH(2),LARGE(1))
|
||||
EQUIVALENCE (DMACH(3),RIGHT(1))
|
||||
EQUIVALENCE (DMACH(4),DIVER(1))
|
||||
EQUIVALENCE (DMACH(5),LOG10(1))
|
||||
C THIS VERSION ADAPTS AUTOMATICALLY TO MOST CURRENT MACHINES.
|
||||
C R1MACH CAN HANDLE AUTO-DOUBLE COMPILING, BUT THIS VERSION OF
|
||||
C D1MACH DOES NOT, BECAUSE WE DO NOT HAVE QUAD CONSTANTS FOR
|
||||
C MANY MACHINES YET.
|
||||
C TO COMPILE ON OLDER MACHINES, ADD A C IN COLUMN 1
|
||||
C ON THE NEXT LINE
|
||||
DATA SC/0/
|
||||
C AND REMOVE THE C FROM COLUMN 1 IN ONE OF THE SECTIONS BELOW.
|
||||
C CONSTANTS FOR EVEN OLDER MACHINES CAN BE OBTAINED BY
|
||||
C mail netlib@research.bell-labs.com
|
||||
C send old1mach from blas
|
||||
C PLEASE SEND CORRECTIONS TO dmg OR ehg@bell-labs.com.
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES.
|
||||
C DATA SMALL(1),SMALL(2) / O402400000000, O000000000000 /
|
||||
C DATA LARGE(1),LARGE(2) / O376777777777, O777777777777 /
|
||||
C DATA RIGHT(1),RIGHT(2) / O604400000000, O000000000000 /
|
||||
C DATA DIVER(1),DIVER(2) / O606400000000, O000000000000 /
|
||||
C DATA LOG10(1),LOG10(2) / O776464202324, O117571775714 /, SC/987/
|
||||
C
|
||||
C MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING
|
||||
C 32-BIT INTEGERS.
|
||||
C DATA SMALL(1),SMALL(2) / 8388608, 0 /
|
||||
C DATA LARGE(1),LARGE(2) / 2147483647, -1 /
|
||||
C DATA RIGHT(1),RIGHT(2) / 612368384, 0 /
|
||||
C DATA DIVER(1),DIVER(2) / 620756992, 0 /
|
||||
C DATA LOG10(1),LOG10(2) / 1067065498, -2063872008 /, SC/987/
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES.
|
||||
C DATA SMALL(1),SMALL(2) / O000040000000, O000000000000 /
|
||||
C DATA LARGE(1),LARGE(2) / O377777777777, O777777777777 /
|
||||
C DATA RIGHT(1),RIGHT(2) / O170540000000, O000000000000 /
|
||||
C DATA DIVER(1),DIVER(2) / O170640000000, O000000000000 /
|
||||
C DATA LOG10(1),LOG10(2) / O177746420232, O411757177572 /, SC/987/
|
||||
C
|
||||
C ON FIRST CALL, IF NO DATA UNCOMMENTED, TEST MACHINE TYPES.
|
||||
IF (SC .NE. 987) THEN
|
||||
DMACH(1) = 1.D13
|
||||
IF ( SMALL(1) .EQ. 1117925532
|
||||
* .AND. SMALL(2) .EQ. -448790528) THEN
|
||||
* *** IEEE BIG ENDIAN ***
|
||||
SMALL(1) = 1048576
|
||||
SMALL(2) = 0
|
||||
LARGE(1) = 2146435071
|
||||
LARGE(2) = -1
|
||||
RIGHT(1) = 1017118720
|
||||
RIGHT(2) = 0
|
||||
DIVER(1) = 1018167296
|
||||
DIVER(2) = 0
|
||||
LOG10(1) = 1070810131
|
||||
LOG10(2) = 1352628735
|
||||
ELSE IF ( SMALL(2) .EQ. 1117925532
|
||||
* .AND. SMALL(1) .EQ. -448790528) THEN
|
||||
* *** IEEE LITTLE ENDIAN ***
|
||||
SMALL(2) = 1048576
|
||||
SMALL(1) = 0
|
||||
LARGE(2) = 2146435071
|
||||
LARGE(1) = -1
|
||||
RIGHT(2) = 1017118720
|
||||
RIGHT(1) = 0
|
||||
DIVER(2) = 1018167296
|
||||
DIVER(1) = 0
|
||||
LOG10(2) = 1070810131
|
||||
LOG10(1) = 1352628735
|
||||
ELSE IF ( SMALL(1) .EQ. -2065213935
|
||||
* .AND. SMALL(2) .EQ. 10752) THEN
|
||||
* *** VAX WITH D_FLOATING ***
|
||||
SMALL(1) = 128
|
||||
SMALL(2) = 0
|
||||
LARGE(1) = -32769
|
||||
LARGE(2) = -1
|
||||
RIGHT(1) = 9344
|
||||
RIGHT(2) = 0
|
||||
DIVER(1) = 9472
|
||||
DIVER(2) = 0
|
||||
LOG10(1) = 546979738
|
||||
LOG10(2) = -805796613
|
||||
ELSE IF ( SMALL(1) .EQ. 1267827943
|
||||
* .AND. SMALL(2) .EQ. 704643072) THEN
|
||||
* *** IBM MAINFRAME ***
|
||||
SMALL(1) = 1048576
|
||||
SMALL(2) = 0
|
||||
LARGE(1) = 2147483647
|
||||
LARGE(2) = -1
|
||||
RIGHT(1) = 856686592
|
||||
RIGHT(2) = 0
|
||||
DIVER(1) = 873463808
|
||||
DIVER(2) = 0
|
||||
LOG10(1) = 1091781651
|
||||
LOG10(2) = 1352628735
|
||||
ELSE IF ( SMALL(1) .EQ. 1120022684
|
||||
* .AND. SMALL(2) .EQ. -448790528) THEN
|
||||
* *** CONVEX C-1 ***
|
||||
SMALL(1) = 1048576
|
||||
SMALL(2) = 0
|
||||
LARGE(1) = 2147483647
|
||||
LARGE(2) = -1
|
||||
RIGHT(1) = 1019215872
|
||||
RIGHT(2) = 0
|
||||
DIVER(1) = 1020264448
|
||||
DIVER(2) = 0
|
||||
LOG10(1) = 1072907283
|
||||
LOG10(2) = 1352628735
|
||||
ELSE IF ( SMALL(1) .EQ. 815547074
|
||||
* .AND. SMALL(2) .EQ. 58688) THEN
|
||||
* *** VAX G-FLOATING ***
|
||||
SMALL(1) = 16
|
||||
SMALL(2) = 0
|
||||
LARGE(1) = -32769
|
||||
LARGE(2) = -1
|
||||
RIGHT(1) = 15552
|
||||
RIGHT(2) = 0
|
||||
DIVER(1) = 15568
|
||||
DIVER(2) = 0
|
||||
LOG10(1) = 1142112243
|
||||
LOG10(2) = 2046775455
|
||||
ELSE
|
||||
DMACH(2) = 1.D27 + 1
|
||||
DMACH(3) = 1.D27
|
||||
LARGE(2) = LARGE(2) - RIGHT(2)
|
||||
IF (LARGE(2) .EQ. 64 .AND. SMALL(2) .EQ. 0) THEN
|
||||
CRAY1(1) = 67291416
|
||||
DO 10 J = 1, 20
|
||||
CRAY1(J+1) = CRAY1(J) + CRAY1(J)
|
||||
10 CONTINUE
|
||||
CRAY1(22) = CRAY1(21) + 321322
|
||||
DO 20 J = 22, 37
|
||||
CRAY1(J+1) = CRAY1(J) + CRAY1(J)
|
||||
20 CONTINUE
|
||||
IF (CRAY1(38) .EQ. SMALL(1)) THEN
|
||||
* *** CRAY ***
|
||||
CALL I1MCRY(SMALL(1), J, 8285, 8388608, 0)
|
||||
SMALL(2) = 0
|
||||
CALL I1MCRY(LARGE(1), J, 24574, 16777215, 16777215)
|
||||
CALL I1MCRY(LARGE(2), J, 0, 16777215, 16777214)
|
||||
CALL I1MCRY(RIGHT(1), J, 16291, 8388608, 0)
|
||||
RIGHT(2) = 0
|
||||
CALL I1MCRY(DIVER(1), J, 16292, 8388608, 0)
|
||||
DIVER(2) = 0
|
||||
CALL I1MCRY(LOG10(1), J, 16383, 10100890, 8715215)
|
||||
CALL I1MCRY(LOG10(2), J, 0, 16226447, 9001388)
|
||||
ELSE
|
||||
WRITE(*,9000)
|
||||
STOP 779
|
||||
END IF
|
||||
ELSE
|
||||
WRITE(*,9000)
|
||||
STOP 779
|
||||
END IF
|
||||
END IF
|
||||
SC = 987
|
||||
END IF
|
||||
* SANITY CHECK
|
||||
IF (DMACH(4) .GE. 1.0D0) STOP 778
|
||||
IF (I .LT. 1 .OR. I .GT. 5) THEN
|
||||
WRITE(*,*) 'D1MACH(I): I =',I,' is out of bounds.'
|
||||
STOP
|
||||
END IF
|
||||
D1MACH = DMACH(I)
|
||||
RETURN
|
||||
9000 FORMAT(/' Adjust D1MACH by uncommenting data statements'/
|
||||
*' appropriate for your machine.')
|
||||
* /* Standard C source for D1MACH -- remove the * in column 1 */
|
||||
*#include <stdio.h>
|
||||
*#include <float.h>
|
||||
*#include <math.h>
|
||||
*double d1mach_(long *i)
|
||||
*{
|
||||
* switch(*i){
|
||||
* case 1: return DBL_MIN;
|
||||
* case 2: return DBL_MAX;
|
||||
* case 3: return DBL_EPSILON/FLT_RADIX;
|
||||
* case 4: return DBL_EPSILON;
|
||||
* case 5: return log10((double)FLT_RADIX);
|
||||
* }
|
||||
* fprintf(stderr, "invalid argument: d1mach(%ld)\n", *i);
|
||||
* exit(1); return 0; /* some compilers demand return values */
|
||||
*}
|
||||
END
|
||||
SUBROUTINE I1MCRY(A, A1, B, C, D)
|
||||
**** SPECIAL COMPUTATION FOR OLD CRAY MACHINES ****
|
||||
INTEGER A, A1, B, C, D
|
||||
A1 = 16777216*B + C
|
||||
A = 16777216*A1 + D
|
||||
END
|
||||
@@ -0,0 +1,34 @@
|
||||
SUBROUTINE DERV1(LABEL,VALUE,FLAG)
|
||||
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
|
||||
c ALL RIGHTS RESERVED.
|
||||
c Based on Government Sponsored Research NAS7-03001.
|
||||
C>> 1994-10-20 DERV1 Krogh Changes to use M77CON
|
||||
C>> 1994-04-20 DERV1 CLL Edited to make DP & SP files similar.
|
||||
C>> 1985-09-20 DERV1 Lawson Initial code.
|
||||
c--D replaces "?": ?ERV1
|
||||
C
|
||||
C ------------------------------------------------------------
|
||||
C SUBROUTINE ARGUMENTS
|
||||
C --------------------
|
||||
C LABEL An identifing name to be printed with VALUE.
|
||||
C
|
||||
C VALUE A floating point number to be printed.
|
||||
C
|
||||
C FLAG See write up for FLAG in ERMSG.
|
||||
C
|
||||
C ------------------------------------------------------------
|
||||
C
|
||||
COMMON/M77ERR/IDELTA,IALPHA
|
||||
INTEGER IDELTA,IALPHA
|
||||
DOUBLE PRECISION VALUE
|
||||
CHARACTER*(*) LABEL
|
||||
CHARACTER*1 FLAG
|
||||
SAVE /M77ERR/
|
||||
C
|
||||
IF (IALPHA.GE.-1) THEN
|
||||
WRITE (*,*) ' ',LABEL,' = ',VALUE
|
||||
IF (FLAG.EQ.'.') CALL ERFIN
|
||||
ENDIF
|
||||
RETURN
|
||||
C
|
||||
END
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,67 @@
|
||||
DOUBLE PRECISION FUNCTION DNRM2(N,X,INCX)
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION X(*)
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* DNRM2 returns the euclidean norm of a vector via the function
|
||||
* name, so that
|
||||
*
|
||||
* DNRM2 := sqrt( x'*x )
|
||||
*
|
||||
* Further Details
|
||||
* ===============
|
||||
*
|
||||
* -- This version written on 25-October-1982.
|
||||
* Modified on 14-October-1993 to inline the call to DLASSQ.
|
||||
* Sven Hammarling, Nag Ltd.
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE,ZERO
|
||||
PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION ABSXI,NORM,SCALE,SSQ
|
||||
INTEGER IX
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS,SQRT
|
||||
* ..
|
||||
IF (N.LT.1 .OR. INCX.LT.1) THEN
|
||||
NORM = ZERO
|
||||
ELSE IF (N.EQ.1) THEN
|
||||
NORM = ABS(X(1))
|
||||
ELSE
|
||||
SCALE = ZERO
|
||||
SSQ = ONE
|
||||
* The following loop is equivalent to this call to the LAPACK
|
||||
* auxiliary routine:
|
||||
* CALL DLASSQ( N, X, INCX, SCALE, SSQ )
|
||||
*
|
||||
DO 10 IX = 1,1 + (N-1)*INCX,INCX
|
||||
IF (X(IX).NE.ZERO) THEN
|
||||
ABSXI = ABS(X(IX))
|
||||
IF (SCALE.LT.ABSXI) THEN
|
||||
SSQ = ONE + SSQ* (SCALE/ABSXI)**2
|
||||
SCALE = ABSXI
|
||||
ELSE
|
||||
SSQ = SSQ + (ABSXI/SCALE)**2
|
||||
END IF
|
||||
END IF
|
||||
10 CONTINUE
|
||||
NORM = SCALE*SQRT(SSQ)
|
||||
END IF
|
||||
*
|
||||
DNRM2 = NORM
|
||||
RETURN
|
||||
*
|
||||
* End of DNRM2.
|
||||
*
|
||||
END
|
||||
@@ -0,0 +1,16 @@
|
||||
SUBROUTINE ERFIN
|
||||
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
|
||||
c ALL RIGHTS RESERVED.
|
||||
c Based on Government Sponsored Research NAS7-03001.
|
||||
C>> 1994-11-11 CLL Typing all variables.
|
||||
C>> 1985-09-23 ERFIN Lawson Initial code.
|
||||
C
|
||||
integer idelta, ialpha
|
||||
COMMON/M77ERR/IDELTA,IALPHA
|
||||
SAVE /M77ERR/
|
||||
C
|
||||
1003 FORMAT(1X,72('$')/' ')
|
||||
PRINT 1003
|
||||
IF (IALPHA.GE.2) STOP
|
||||
RETURN
|
||||
END
|
||||
@@ -0,0 +1,89 @@
|
||||
SUBROUTINE ERMSG(SUBNAM,INDIC,LEVEL,MSG,FLAG)
|
||||
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
|
||||
c ALL RIGHTS RESERVED.
|
||||
c Based on Government Sponsored Research NAS7-03001.
|
||||
c>> 1995-11-22 ERMSG Krogh Got rid of multiple entries.
|
||||
c>> 1995-09-15 ERMSG Krogh Remove '0' in format.
|
||||
C>> 1994-11-11 ERMSG Krogh Declared all vars.
|
||||
C>> 1992-10-20 ERMSG WV Snyder added ERLSET, ERLGET
|
||||
C>> 1985-09-25 ERMSG Lawson Initial code.
|
||||
C
|
||||
C --------------------------------------------------------------
|
||||
C
|
||||
C Four entries: ERMSG, ERMSET, ERLGET, ERLSET
|
||||
C ERMSG initiates an error message. This subr also manages the
|
||||
C saved value IDELOC and the saved COMMON block M77ERR to
|
||||
C control the level of action. This is intended to be the
|
||||
C only subr that assigns a value to IALPHA in COMMON.
|
||||
C ERMSET resets IDELOC & IDELTA. ERLGET returns the last value
|
||||
C of LEVEL passed to ERMSG. ERLSET sets the last value of LEVEL.
|
||||
C ERLSET and ERLGET may be used together to determine the level
|
||||
C of error that occurs during execution of a routine that uses
|
||||
C ERMSG.
|
||||
C
|
||||
C --------------------------------------------------------------
|
||||
C SUBROUTINE ARGUMENTS
|
||||
C --------------------
|
||||
C SUBNAM A name that identifies the subprogram in which
|
||||
C the error occurs.
|
||||
C
|
||||
C INDIC An integer printed as part of the mininal error
|
||||
C message. It together with SUBNAM can be used to
|
||||
C uniquely identify an error.
|
||||
C
|
||||
C LEVEL The user sets LEVEL=2,0,or -2 to specify the
|
||||
C nominal action to be taken by ERMSG. The
|
||||
C subroutine ERMSG contains an internal variable
|
||||
C IDELTA, whose nominal value is zero. The
|
||||
C subroutine will compute IALPHA = LEVEL + IDELTA
|
||||
C and proceed as follows:
|
||||
C If (IALPHA.GE.2) Print message and STOP.
|
||||
C If (IALPHA=-1,0,1) Print message and return.
|
||||
C If (IALPHA.LE.-2) Just RETURN.
|
||||
C
|
||||
C MSG Message to be printed as part of the diagnostic.
|
||||
C
|
||||
C FLAG A single character,which when set to '.' will
|
||||
C call the subroutine ERFIN and will just RETURN
|
||||
C when set to any other character.
|
||||
C
|
||||
C --------------------------------------------------------------
|
||||
C
|
||||
C C.Lawson & S.Chan, JPL, 1983 Nov
|
||||
C
|
||||
C ------------------------------------------------------------------
|
||||
INTEGER IDELOC, LEVEL, IDELTA, IALPHA, INDIC
|
||||
COMMON /M77ERR/ IDELTA,IALPHA
|
||||
CHARACTER*(*) SUBNAM,MSG
|
||||
CHARACTER*1 FLAG
|
||||
SAVE /M77ERR/, IDELOC
|
||||
DATA IDELOC / 0 /
|
||||
1001 FORMAT(1X/' ',72('$')/' SUBPROGRAM ',A,' REPORTS ERROR NO. ',I4)
|
||||
c
|
||||
if (LEVEL .lt. -1000) then
|
||||
c Setting a new IDELOC.
|
||||
IDELTA = LEVEL + 10000
|
||||
IDELOC = IDELTA
|
||||
return
|
||||
end if
|
||||
IDELTA = IDELOC
|
||||
IALPHA = LEVEL + IDELTA
|
||||
IF (IALPHA.GE.-1) THEN
|
||||
c
|
||||
c Setting FILE = 'CON' works for MS/DOS systems.
|
||||
c
|
||||
c
|
||||
WRITE (*,1001) SUBNAM,INDIC
|
||||
WRITE (*,*) MSG
|
||||
IF (FLAG.EQ.'.') CALL ERFIN
|
||||
END IF
|
||||
RETURN
|
||||
C
|
||||
end
|
||||
C
|
||||
subroutine ERMSET(IDEL)
|
||||
integer IDEL
|
||||
c Call ERMSG to set IDELTA and IDELOC
|
||||
call ERMSG(' ', 0,IDEL-10000,' ',' ')
|
||||
RETURN
|
||||
END
|
||||
@@ -311,7 +311,7 @@
|
||||
call lnsrch(nunknowns,xpold,fsqsumold,
|
||||
& gfuncsum,deltax,xp,fsqsumnew,stpmax,
|
||||
& check,funcnleq1,fequ)
|
||||
if(check.eq..true..or.check.eq..TRUE.)then
|
||||
if(check.eqv..true..or.check.eqv..TRUE.)then
|
||||
do i=1,nunknowns
|
||||
call reinitialization(x0min(i),xpold(i),
|
||||
& x0max(i),xp(i),6678)
|
||||
|
||||
@@ -0,0 +1,15 @@
|
||||
subroutine IERM1(SUBNAM,INDIC,LEVEL,MSG,LABEL,VALUE,FLAG)
|
||||
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
|
||||
c ALL RIGHTS RESERVED.
|
||||
c Based on Government Sponsored Research NAS7-03001.
|
||||
C>> 1990-01-18 CLL Added Integer stmt for VALUE. Typed all variables.
|
||||
C>> 1985-08-02 IERM1 Lawson Initial code.
|
||||
C
|
||||
integer INDIC, LEVEL, VALUE
|
||||
character*(*) SUBNAM,MSG,LABEL
|
||||
character*1 FLAG
|
||||
call ERMSG(SUBNAM,INDIC,LEVEL,MSG,',')
|
||||
call IERV1(LABEL,VALUE,FLAG)
|
||||
C
|
||||
return
|
||||
end
|
||||
@@ -0,0 +1,32 @@
|
||||
SUBROUTINE IERV1(LABEL,VALUE,FLAG)
|
||||
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
|
||||
c ALL RIGHTS RESERVED.
|
||||
c Based on Government Sponsored Research NAS7-03001.
|
||||
c>> 1995-11-15 IERV1 Krogh Moved format up for C conversion.
|
||||
C>> 1985-09-20 IERV1 Lawson Initial code.
|
||||
C
|
||||
C ------------------------------------------------------------
|
||||
C SUBROUTINE ARGUMENTS
|
||||
C --------------------
|
||||
C LABEL An identifing name to be printed with VALUE.
|
||||
C
|
||||
C VALUE A integer to be printed.
|
||||
C
|
||||
C FLAG See write up for FLAG in ERMSG.
|
||||
C
|
||||
C ------------------------------------------------------------
|
||||
C
|
||||
COMMON/M77ERR/IDELTA,IALPHA
|
||||
INTEGER IDELTA,IALPHA,VALUE
|
||||
CHARACTER*(*) LABEL
|
||||
CHARACTER*1 FLAG
|
||||
SAVE /M77ERR/
|
||||
1002 FORMAT(3X,A,' = ',I5)
|
||||
C
|
||||
IF (IALPHA.GE.-1) THEN
|
||||
WRITE (*,1002) LABEL,VALUE
|
||||
IF (FLAG .EQ. '.') CALL ERFIN
|
||||
ENDIF
|
||||
RETURN
|
||||
C
|
||||
END
|
||||
Binary file not shown.
@@ -1,6 +1,6 @@
|
||||
subroutine nonsyssolver(funcnleq1,fmin_funcnleq1,
|
||||
& f1dim_funcnleq1,x0min,x0ori,xp,x0max,fp,
|
||||
& nunknowns,iwhichsolver)
|
||||
&f1dim_funcnleq1,DNQFJ_funcnleq1,x0min,x0ori,xp,x0max,fp,
|
||||
&nunknowns,iwhichsolver)
|
||||
implicit none
|
||||
integer nunknowns,iwhichsolver
|
||||
double precision x0min(nunknowns),x0ori(nunknowns),
|
||||
@@ -27,30 +27,48 @@
|
||||
! =4 solved by fixed point method 4
|
||||
! =6 solved by broydn
|
||||
! =7 Solved by multiobjective minimization.
|
||||
! =8 Solved by DNQSOL
|
||||
! =-9999 Best approximation returned. Solution may not be accurate.
|
||||
! --------- Local variables ---------------------------------------
|
||||
double precision x0(nunknowns),TOLF,stpmax,scldstpmax,
|
||||
& sum,tb,tp,xb(nunknowns),fb(nunknowns),fsqsum,
|
||||
& f1dim_funcnleq1
|
||||
integer i,irepeat,maxrepeats,IERR,notfound
|
||||
double precision x0(nunknowns),TOLF,stpmax,scldstpmax,ran2,
|
||||
&sum,tb,tp,xb(nunknowns),fb(nunknowns),fsqsum,f1dim_funcnleq1,
|
||||
&D1MACH,Warray(3+(15*nunknowns+3*nunknowns*nunknowns)/2+1)
|
||||
integer i,irepeat,maxrepeats,IERR,notfound,IOPT(5),IDIMW
|
||||
intrinsic dble
|
||||
parameter(maxrepeats=100,notfound=-9999,TOLF=1.0d-7)
|
||||
external funcnleq1,fmin_funcnleq1,f1dim_funcnleq1
|
||||
parameter(maxrepeats=100,notfound=-9999)
|
||||
external funcnleq1,fmin_funcnleq1,f1dim_funcnleq1,
|
||||
&DNQFJ_funcnleq1
|
||||
!-------------------------------------------------------------------
|
||||
stpmax=0.0d0
|
||||
sum=0.0d0
|
||||
do i=1, nunknowns
|
||||
x0(i)=x0ori(i)
|
||||
sum=sum+x0ori(i)*x0ori(i)
|
||||
stpmax=stpmax+
|
||||
& (x0min(i)-x0max(i))*(x0min(i)-x0max(i))
|
||||
xp(i)=x0ori(i)
|
||||
enddo
|
||||
stpmax=dsqrt(stpmax)/4.0d0
|
||||
scldstpmax=stpmax/dmax1(dsqrt(sum),dble(nunknowns))
|
||||
! In Numerical Recipes, scldstpmax (STPMX) is 100
|
||||
scldstpmax=dmax1(100.0d0,scldstpmax)
|
||||
iwhichsolver=notfound
|
||||
TOLF=dsqrt(D1MACH(4))
|
||||
do irepeat=1,maxrepeats
|
||||
IDIMW=3+(15*nunknowns+3*nunknowns*nunknowns)/2+1
|
||||
do i=1,5
|
||||
IOPT(i)=0
|
||||
enddo
|
||||
IOPT(4)=1
|
||||
call DNQSOL(DNQFJ_funcnleq1,nunknowns,xp,fp,TOLF,
|
||||
&IOPT,Warray,IDIMW)
|
||||
if(IOPT(1).eq.0)then
|
||||
iwhichsolver=8
|
||||
return
|
||||
endif
|
||||
do i=1,nunknowns
|
||||
x0(i)=x0min(i)+ran2()*(x0max(i)-x0min(i))
|
||||
enddo
|
||||
stpmax=0.0d0
|
||||
sum=0.0d0
|
||||
do i=1, nunknowns
|
||||
sum=sum+x0(i)*x0(i)
|
||||
stpmax=stpmax+(x0min(i)-x0max(i))*(x0min(i)-x0max(i))
|
||||
enddo
|
||||
stpmax=dsqrt(stpmax)/4.0d0
|
||||
scldstpmax=stpmax/dmax1(dsqrt(sum),dble(nunknowns))
|
||||
! In Numerical Recipes, scldstpmax (STPMX) is 100
|
||||
scldstpmax=dmax1(100.0d0,scldstpmax)
|
||||
call fixedpoint(funcnleq1,x0min,x0,xp,
|
||||
& x0max,fp,nunknowns,TOLF,stpmax,iwhichsolver)
|
||||
if(iwhichsolver.ne.notfound)return
|
||||
@@ -82,6 +100,11 @@
|
||||
return
|
||||
endif
|
||||
endif
|
||||
|
||||
do i=1,nunknowns
|
||||
xp(i)=x0min(i)+ran2()*(x0max(i)-x0min(i))
|
||||
enddo
|
||||
call funcnleq1(nunknowns,xp,fp,fsqsum)
|
||||
fsqsum=0.0d0
|
||||
do i=1,nunknowns
|
||||
fsqsum=fsqsum+fp(i)*fp(i)
|
||||
@@ -89,11 +112,11 @@
|
||||
tp=fsqsum
|
||||
call nongradopt(nunknowns,fmin_funcnleq1,
|
||||
& f1dim_funcnleq1,xp,x0min,x0max,TOLF,fsqsum)
|
||||
! if(dabs(tp-fsqsum).gt.TOLF)then
|
||||
! call RepeatCompassSearch(nunknowns,xp,fsqsum,
|
||||
! & x0min,x0max,fmin_funcnleq1,f1dim_funcnleq1,
|
||||
! & TOLF)
|
||||
! endif
|
||||
if(dabs(tp-fsqsum).gt.TOLF)then
|
||||
call RepeatCompassSearch(nunknowns,xp,fsqsum,
|
||||
& x0min,x0max,fmin_funcnleq1,f1dim_funcnleq1,
|
||||
& TOLF)
|
||||
endif
|
||||
call funcnleq1(nunknowns,xp,fp,fsqsum)
|
||||
tp=dabs(fp(1))
|
||||
do i=2,nunknowns
|
||||
@@ -109,7 +132,7 @@
|
||||
enddo
|
||||
if(IERR.eq.0)return
|
||||
do i=1,nunknowns
|
||||
x0(i)=xp(i)
|
||||
xp(i)=x0min(i)+ran2()*(x0max(i)-x0min(i))
|
||||
enddo
|
||||
enddo
|
||||
end subroutine nonsyssolver
|
||||
|
||||
Reference in New Issue
Block a user