diff --git a/src/decode/local.f b/src/decode/local.f deleted file mode 100644 index 6575810..0000000 --- a/src/decode/local.f +++ /dev/null @@ -1,390 +0,0 @@ -C ( Last modified on 23 Dec 2000 at 22:01:38 ) - SUBROUTINE HASHA ( LENGTH, ITABLE ) - INTEGER LENGTH - INTEGER ITABLE( LENGTH ) - COMMON / HASHZ / DPRIME, IEMPTY - INTEGER IEMPTY - DOUBLE PRECISION DPRIME -C -C SET UP INITIAL SCATTER TABLE (WILLIAMS, CACM 2, 21-24, 1959). -C -C ITABLE( I ) GIVES THE STATUS OF TABLE ENTRY I. -C IF STATUS = - ( LENGTH + 1 ), THE ENTRY IS UNUSED. -C -C NICK GOULD, FOR CGT PRODUCTIONS. -C 4TH JULY 1989. -C - INTEGER I, IPRIME - EXTERNAL HASHF - LOGICAL HASHF, PRIME - IEMPTY = LENGTH + 1 -C -C FIND AN APPROPRIATE PRIME NUMBER FOR THE HASH FUNCTION. -C COMPUTE THE LARGEST PRIME SMALLER THAN LENGTH. -C - IPRIME = 2 * ( ( LENGTH + 1 ) / 2 ) - 1 - 10 CONTINUE -C -C IS IPRIME PRIME? -C - PRIME = HASHF ( IPRIME ) - IF ( .NOT. PRIME ) THEN - IPRIME = IPRIME - 2 - GO TO 10 - END IF - DPRIME = IPRIME -C -C INITIALIZE EACH TABLE ENTRY AS UNFILLED. -C - DO 20 I = 1, LENGTH - ITABLE( I ) = - IEMPTY - 20 CONTINUE - RETURN -C -C END OF HASHA. -C - END -C -C -C - SUBROUTINE HASHB ( LENGTH, NCHAR, FIELD, KEY, ITABLE, IFREE ) - INTEGER NCHAR, IFREE, LENGTH - INTEGER ITABLE( LENGTH ) - CHARACTER * 1 FIELD( NCHAR ), KEY( NCHAR, LENGTH ) - COMMON / HASHZ / DPRIME, IEMPTY - INTEGER IEMPTY - DOUBLE PRECISION DPRIME -C -C INSERT IN CHAINED SCATTER TABLE (WILLIAMS, CACM 2, 21-24, 1959). -C -C ITABLE( I ) GIVES THE STATUS OF TABLE ENTRY I. -C IF STATUS = - ( LENGTH + 1 ), THE ENTRY IS UNUSED. -C IF STATUS = - K, THE ENTRY WAS USED BUT HAS BEEN DELETED. K GIVES -C THE INDEX OF THE NEXT ENTRY IN THE CHAIN. -C IF STATUS = 0, THE ENTRY IS USED AND LIES AT THE END OF A CHAIN. -C IF STATUS = K, THE ENTRY IS USED. K GIVES THE INDEX OF THE NEXT -C ENTRY IN THE CHAIN. -C IFIELD( I ) GIVES THE FIELD KEY FOR USED ENTRIES IN THE TABLE. -C -C NICK GOULD, FOR CGT PRODUCTIONS. -C 4TH JULY 1989. -C - INTEGER I, J, K, NBYTES, NOVER2 - PARAMETER ( NBYTES = ${NBYTES} ) - PARAMETER ( NOVER2 = NBYTES / 2 ) - CHARACTER * 1 BFIELD( NBYTES ) - INTEGER IVALUE( 2 ) - INTEGER HASHE - EXTERNAL HASHE - INTRINSIC MOD, IDINT, IABS, ICHAR -C -C FIND A STARTING POSITION, IFREE, FOR THE INSERTION. -C PERFORM THE HASHING ON 8 CHARACTERS OF FIELD AT A TIME. -C - IFREE = 0 - DO 30 J = 1, NCHAR, NBYTES - DO 10 I = 1, NBYTES - K = J + I - 1 - IF ( K .LE. NCHAR ) THEN - BFIELD( I ) = FIELD( K ) - ELSE - BFIELD( I ) = ' ' - END IF - 10 CONTINUE -C -C CONVERT THE CHARACTER STRING INTO TWO INTEGER NUMBERS. -C - IVALUE( 1 ) = ICHAR( BFIELD( 1 ) ) / 2 - IVALUE( 2 ) = ICHAR( BFIELD( NOVER2 + 1 ) ) / 2 - DO 20 I = 2, NOVER2 - IVALUE( 1 ) = 256 * IVALUE( 1 ) + ICHAR( BFIELD( I ) ) - IVALUE( 2 ) = 256 * IVALUE( 2 ) + - * ICHAR( BFIELD( NOVER2 + I ) ) - 20 CONTINUE -C -C CONVERT THE CHARACTER STRING INTO A DOUBLE PRECISION NUMBER. -C -C READ( UNIT = FIELD8, FMT = 1000 ) VALUE -C -C HASH AND ADD THE RESULT TO IFREE. -C - IFREE = IFREE + HASHE ( IVALUE( 1 ), DPRIME ) - 30 CONTINUE -C -C ENSURE THAT IFREE LIES WITHIN THE ALLOWED RANGE. -C - IFREE = MOD( IFREE, IDINT( DPRIME ) ) + 1 -C -C IS THERE A LIST? -C - IF ( ITABLE( IFREE ) .GE. 0 ) THEN -C -C COMPARE TO SEE IF THE KEY HAS BEEN FOUND. -C - 40 CONTINUE - DO 50 I = 1, NCHAR - IF ( FIELD( I ) .NE. KEY( I, IFREE ) ) GO TO 60 - 50 CONTINUE -C -C THE KEY ALREADY EXISTS AND THEREFORE CANNOT BE INSERTED. -C - IF ( ITABLE( IFREE ) .GE. 0 ) THEN - IFREE = - IFREE - RETURN - END IF -C -C THE KEY USED TO EXIST BUT HAS BEEN DELETED AND MUST BE RESTORED. -C - GO TO 100 -C -C ADVANCE ALONG THE CHAIN TO THE NEXT ENTRY. -C - 60 CONTINUE - IF ( ITABLE( IFREE ) .NE. 0 ) THEN - IFREE = IABS( ITABLE( IFREE ) ) - GO TO 40 - END IF -C -C THE END OF THE CHAIN HAS BEEN REACHED. FIND EMPTY ENTRY IN THE TABLE. -C - 70 CONTINUE - IEMPTY = IEMPTY - 1 - IF ( IEMPTY .EQ. 0 ) THEN - IFREE = 0 - RETURN - END IF - IF ( ITABLE( IEMPTY ) .GE. - LENGTH ) GO TO 70 - ITABLE( IFREE ) = IEMPTY - IFREE = IEMPTY - ELSE -C -C THE STARTING ENTRY FOR THE CHAIN IS UNUSED. -C - IF ( ITABLE( IFREE ) .GE. - LENGTH ) THEN - ITABLE( IFREE ) = - ITABLE ( IFREE ) - GO TO 100 - END IF - END IF -C -C THERE IS NO LINK FROM THE NEWLY INSERTED FIELD. -C - ITABLE( IFREE ) = 0 -C -C INSERT NEW KEY. -C - 100 CONTINUE - DO 110 I = 1, NCHAR - KEY( I, IFREE ) = FIELD( I ) - 110 CONTINUE - RETURN -C -C END OF HASHB. -C - END -C -C -C - SUBROUTINE HASHC ( LENGTH, NCHAR, FIELD, KEY, ITABLE, IFREE ) - INTEGER LENGTH, NCHAR, IFREE - INTEGER ITABLE( LENGTH ) - CHARACTER * 1 FIELD( NCHAR ), KEY( NCHAR, LENGTH ) - COMMON / HASHZ / DPRIME, IEMPTY - INTEGER IEMPTY - DOUBLE PRECISION DPRIME -C -C SEARCH WITHIN CHAINED SCATTER TABLE (WILLIAMS, CACM 2, 21-24, 1959). -C -C ITABLE( I ) GIVES THE STATUS OF TABLE ENTRY I. -C IF STATUS = - ( LENGTH + 1 ), THE ENTRY IS UNUSED. -C IF STATUS = - K, THE ENTRY WAS USED BUT HAS BEEN DELETED. K GIVES -C THE INDEX OF THE NEXT ENTRY IN THE CHAIN. -C IF STATUS = 0, THE ENTRY IS USED AND LIES AT THE END OF A CHAIN. -C IF STATUS = K, THE ENTRY IS USED. K GIVES THE INDEX OF THE NEXT -C ENTRY IN THE CHAIN. -C IFIELD( I ) GIVES THE FIELD KEY FOR USED ENTRIES IN THE TABLE. -C -C NICK GOULD, FOR CGT PRODUCTIONS. -C 4TH JULY 1989. -C - INTEGER I, J, K, NBYTES, NOVER2 - PARAMETER ( NBYTES = ${NBYTES} ) - PARAMETER ( NOVER2 = NBYTES / 2 ) - CHARACTER * 1 BFIELD( NBYTES ) - INTEGER IVALUE( 2 ) - INTEGER HASHE - EXTERNAL HASHE - INTRINSIC MOD, IDINT, IABS, ICHAR -C -C FIND A STARTING POSITION, IFREE, FOR THE CHAIN LEADING TO THE -C REQUIRED LOCATION. -C PERFORM THE HASHING ON NBYTES CHARACTERS OF FIELD AT A TIME. -C - IFREE = 0 - DO 30 J = 1, NCHAR, NBYTES - DO 10 I = 1, NBYTES - K = J + I - 1 - IF ( K .LE. NCHAR ) THEN - BFIELD( I ) = FIELD( K ) - ELSE - BFIELD( I ) = ' ' - END IF - 10 CONTINUE -C -C CONVERT THE CHARACTER STRING INTO TWO INTEGER NUMBERS. -C - IVALUE( 1 ) = ICHAR( BFIELD( 1 ) ) / 2 - IVALUE( 2 ) = ICHAR( BFIELD( NOVER2 + 1 ) ) / 2 - DO 20 I = 2, NOVER2 - IVALUE( 1 ) = 256 * IVALUE( 1 ) + ICHAR( BFIELD( I ) ) - IVALUE( 2 ) = 256 * IVALUE( 2 ) + - * ICHAR( BFIELD( NOVER2 + I ) ) - 20 CONTINUE -C -C CONVERT THE CHARACTER STRING INTO A DOUBLE PRECISION NUMBER. -C -C READ( UNIT = FIELD8, FMT = 1000 ) VALUE -C -C HASH AND ADD THE RESULT TO IFREE. -C - IFREE = IFREE + HASHE ( IVALUE( 1 ), DPRIME ) - 30 CONTINUE -C -C ENSURE THAT IFREE LIES WITHIN THE ALLOWED RANGE. -C - IFREE = MOD( IFREE, IDINT( DPRIME ) ) + 1 -C -C IS THERE A LIST? -C - IF ( ITABLE( IFREE ) .LT. - LENGTH ) THEN - IFREE = 0 - RETURN - END IF -C -C COMPARE TO SEE IF THE KEY HAS BEEN FOUND. -C - 40 CONTINUE - DO 50 I = 1, NCHAR - IF ( FIELD( I ) .NE. KEY( I, IFREE ) ) GO TO 60 - 50 CONTINUE -C -C CHECK THAT THE TABLE ITEM HAS NOT BEEN REMOVED. -C - IF ( ITABLE( IFREE ) .LT. 0 ) THEN - IFREE = - IFREE - END IF - RETURN -C -C ADVANCE TO NEXT. -C - 60 CONTINUE - IF ( ITABLE( IFREE ) .EQ. 0 ) THEN - IFREE = 0 - RETURN - END IF - IFREE = IABS( ITABLE( IFREE ) ) - GO TO 40 - END -C -C END OF HASHC. -C -C -C - INTEGER FUNCTION HASHE ( IVALUE, DPRIME ) - INTEGER IVALUE( 2 ) - DOUBLE PRECISION DPRIME -C -C THE HASH FUNCTION (REID, 1976). -C NICK GOULD, FOR CGT PRODUCTIONS. -C 4TH JULY 1989. -C - INTRINSIC DMOD, DBLE, IABS - HASHE = DMOD( DBLE( IVALUE( 1 ) ) + IVALUE( 2 ), DPRIME ) - HASHE = IABS( HASHE ) + 1 - RETURN -C -C END OF HASHE. -C - END -C -C -C - LOGICAL FUNCTION HASHF ( IPRIME ) - INTEGER IPRIME -C -C RETURNS THE VALUE .TRUE. IF IPRIME IS PRIME. -C -C NICK GOULD, FOR CGT PRODUCTIONS. -C 4TH JULY 1989. -C - INTEGER I - INTRINSIC MOD, DSQRT, INT, DBLE - HASHF = .FALSE. - IF ( MOD( IPRIME, 2 ) .EQ. 0 ) RETURN - DO 10 I = 3, INT( DSQRT( DBLE( IPRIME ) ) ), 2 - IF ( MOD( IPRIME, I ) .EQ. 0 ) RETURN - 10 CONTINUE - HASHF = .TRUE. - RETURN -C -C END OF HASHF. -C - END -C -C -C - REAL FUNCTION SMACHR( INUM ) - INTEGER INUM - REAL RC( 5 ) -C -C REAL CONSTANTS (SINGLE PRECISION). -C -C NICK GOULD, JULY 1988. -C - DATA RC( 1 ) / ${R1} / - DATA RC( 2 ) / ${R2} / - DATA RC( 3 ) / ${R3} / - DATA RC( 4 ) / ${R4} / - DATA RC( 5 ) / ${R5} / - - IF ( INUM .LE. 0 .OR. INUM .GE. 6 ) THEN - PRINT 2000, INUM - STOP - ELSE - SMACHR = RC( INUM ) - ENDIF - RETURN - 2000 FORMAT( ' INUM =', I3, ' OUT OF RANGE IN SMACHR.', - * ' EXECUTION TERMINATED.' ) - END -C -C -C - DOUBLE PRECISION FUNCTION DMACHR( INUM ) - INTEGER INUM - DOUBLE PRECISION RC( 5 ) -C -C REAL CONSTANTS (DOUBLE PRECISION). -C -C NICK GOULD, JULY 1988. -C -C RC(1) THE 'SMALLEST' POSITIVE NUMBER: 1 + RC(1) > 1. -C RC(2) THE 'SMALLEST' POSITIVE NUMBER: 1 - RC(2) < 1. -C RC(3) THE SMALLEST NONZERO +VE REAL NUMBER. -C RC(4) THE SMALLEST FULL PRECISION +VE REAL NUMBER. -C RC(5) THE LARGEST FINITE +VE REAL NUMBER. -C - DATA RC( 1 ) / ${D1} / - DATA RC( 2 ) / ${D2} / - DATA RC( 3 ) / ${D3} / - DATA RC( 4 ) / ${D4} / - DATA RC( 5 ) / ${D5} / - IF ( INUM .LE. 0 .OR. INUM .GE. 6 ) THEN - PRINT 2000, INUM - STOP - ELSE - DMACHR = RC( INUM ) - ENDIF - RETURN - 2000 FORMAT( ' INUM =', I3, ' OUT OF RANGE IN DMACHR.', - * ' EXECUTION TERMINATED.' ) - END diff --git a/src/select/slct_new.f b/src/select/slct_new.f deleted file mode 100644 index b643fd8..0000000 --- a/src/select/slct_new.f +++ /dev/null @@ -1,1941 +0,0 @@ -C ( Last modified on 22 Jan 2014 at 18:00:00 ) -C----------------------------------------------------------------------------- -C - PROGRAM SELECT -C -C----------------------------------------------------------------------------- -C -C The purpose of this program is to interrogate the file containing problem -C classifications (by default, $MASTSIF/CLASSF.DB) for obtaining a list -C of problems matching interactively defined characteristics. -C -C The dialog with the user is on the standard input/output. -C -C Programming: I. Bongartz, A.R. Conn and Ph. Toint for CGT Productions. -C Salford fortran by Kristjan Jonasson -C Revision: Ph. Toint, Aug 2005. -C -C--------- THE FOLLOWING SPECIFICATIONS MAY BE MODIFIED BY THE USER ---------- -C -C Standard input default definition is device 5. Standard output default -C definition is device 6. Change them to whatever values are appropriate -C on your system. -C - INTEGER STDIN, STDOUT - PARAMETER ( STDIN = 5, STDOUT = 6 ) -C -C Name of the classification database -C - CHARACTER*32 NAME - PARAMETER ( NAME = 'CLASSF.DB' ) -C -C Device number for reading the classification database -C - INTEGER CLSDVC, FLSDVC - PARAMETER ( CLSDVC = 55, FLSDVC = 56 ) -C -C default directory for classification file. -C -C Device number and file name for file containing default directory -C - INTEGER DATDVC - PARAMETER ( DATDVC = 57 ) - CHARACTER*32 DATNAM - PARAMETER ( DATNAM = 'SLCT.DAT' ) -C -C---------------- END OF THE USER MODIFIABLE SPECIFICATION ------------------ -C -C Classification constants -C - INTEGER OBJ, CON, REG, DER, INTRST, INTVAR, VARN, VARM, - * VFR, V1S, V2S, VFX, C1SL, C2SL, CEQL, C1SG, C2SG, - * CEQG, UMAX - PARAMETER ( OBJ = 1, CON = 2, REG = 3, DER = 4, - * INTRST = 5, INTVAR = 6, VARN = 7, VARM = 8, - * VFR = 9, V1S = 10, V2S = 11, VFX = 12, - * C1SL = 13, C2SL = 14, CEQL = 15, C1SG = 16, - * C2SG = 17, CEQG = 18, UMAX = 999999999 ) -C -C Maximum number of simultaneous targets in search -C - INTEGER MAXTRG - PARAMETER ( MAXTRG = 19 ) -C -C Variable definitions -C -C names for classification file - CHARACTER*72 FILEN -C default directory for classification file - CHARACTER*256 DFTDIR -C names for output listing file -C Addition by Kristjan Jonasson - CHARACTER*72 FILES - CHARACTER*200 PBCLS - CHARACTER ( len = CEQG ) TARGET( MAXTRG ) - CHARACTER*8 LIST(5) - CHARACTER*1 CHOICE, CHAR, UPPER - INTEGER I, IM1, J, L, K, NUM, NMATCH, NBT, NBI -C INTEGER SIZE, LOW(VARN:CEQG), UPP(VARN:CEQG) - INTEGER SIZE, LOW(1:CEQG), UPP(1:CEQG) - INTEGER CHOSEN( MAXTRG, VARN:CEQG ) - LOGICAL REJECT, MATCH - LOGICAL ANYFIX(1:CEQG) - INTRINSIC MIN -C -C Banner -C - WRITE ( STDOUT, 1000 ) -C -C in order that this program can give the full path name for the -C default classification file. -C -C Open the file containing the default directory name. -C - OPEN ( UNIT = DATDVC, FILE = DATNAM, STATUS = 'OLD' ) -C -C Read in the default directory -C - READ ( DATDVC, 8000 ) DFTDIR - CLOSE ( DATDVC ) - DO 910 I = 1, 256 - IF ( DFTDIR( I : I ) .EQ. ' ' ) THEN - SIZE = I - 1 - GO TO 920 - END IF - 910 CONTINUE - SIZE = 256 - 920 CONTINUE - FILEN = DFTDIR( 1 : SIZE ) // '/' // NAME - SIZE = LEN( FILEN ) -C -C MAIN LOOP -C - 1 CONTINUE -C -C Target initialization -C - DO 4 I = 1, MAXTRG - DO 3 J = VARN, CEQG - CHOSEN( I, J ) = -2 - 3 CONTINUE - TARGET(I) = 'XXXXXXXXXXXXXXXXXX' - 4 CONTINUE - TARGET(1) = '******************' - DO 21 I = VFR, VARM - ANYFIX( I ) = .FALSE. - 21 CONTINUE -C -C Bounds on the number of variables and constraints are initialized -C to be inactive. -C - DO 22 I = VFR, VARM - LOW( I ) = 0 - UPP( I ) = UMAX - 22 CONTINUE -C -C Verify the name of the classification database file -C - 77 CONTINUE - WRITE ( STDOUT, 4950 ) FILEN(1:SIZE) - WRITE ( STDOUT, 4957 ) - READ ( STDIN, '( A1 )' ) CHOICE - IF ( UPPER( CHOICE ) .EQ. 'Y' ) THEN - WRITE ( STDOUT, 4955 ) - READ ( STDIN , FMT = '( A )', ERR = 78 ) FILEN - SIZE = LEN( FILEN ) - GO TO 77 - 78 WRITE ( STDOUT, 1201 ) - GO TO 77 - ENDIF -C -C Writes the current specification -C - 5 CONTINUE - WRITE ( STDOUT, 5002 ) - NUM = NBT ( OBJ, TARGET, MAXTRG ) - WRITE ( STDOUT, 5003 ) ( TARGET(L)(OBJ:OBJ), L = 1, NUM ) - NUM = NBT ( CON, TARGET, MAXTRG ) - WRITE ( STDOUT, 5004 ) ( TARGET(L)(CON:CON), L = 1, NUM ) - WRITE ( STDOUT, 5005 ) TARGET(1)(REG:REG) - NUM = NBT ( DER, TARGET, MAXTRG ) - WRITE ( STDOUT, 5006 ) ( TARGET(L)(DER:DER), L = 1, NUM ) - NUM = NBT ( INTRST, TARGET, MAXTRG ) - WRITE ( STDOUT, 5007 ) ( TARGET(L)(INTRST:INTRST), L = 1, NUM ) - WRITE ( STDOUT, 5008 ) TARGET(1)(INTVAR:INTVAR) -C -C Number of variables -C - WRITE ( STDOUT, 5009 ) - CHAR = TARGET(1)(VFR:VFR) - IF ( CHAR .EQ. 'V' ) THEN - WRITE ( STDOUT, 5020 ) - ELSE IF ( CHAR .EQ. '*' ) THEN - WRITE ( STDOUT, 5021 ) - ELSE IF ( CHAR .EQ. 'I' ) THEN - WRITE ( STDOUT, 5022 ) LOW( VFR ), UPP( VFR ) - ELSE - IF ( ANYFIX(VFR) ) THEN - WRITE ( STDOUT, 5023 ) - ELSE - NUM = NBI ( CHOSEN( 1, VFR ), MAXTRG ) - WRITE ( STDOUT, 5024 ) ( CHOSEN( L, VFR ), L = 1, NUM ) - ENDIF - ENDIF -C - CHAR = TARGET(1)(V1S:V1S) - IF ( CHAR .EQ. 'V' ) THEN - WRITE ( STDOUT, 5025 ) - ELSE IF ( CHAR .EQ. '*' ) THEN - WRITE ( STDOUT, 5026 ) - ELSE IF ( CHAR .EQ. 'I' ) THEN - WRITE ( STDOUT, 5027 ) LOW( V1S), UPP( V1S ) - ELSE - IF ( ANYFIX(V1S) ) THEN - WRITE ( STDOUT, 5028 ) - ELSE - NUM = NBI ( CHOSEN( 1, V1S ), MAXTRG ) - WRITE ( STDOUT, 5029 ) ( CHOSEN( L, V1S ), L = 1, NUM ) - ENDIF - ENDIF -C - CHAR = TARGET(1)(V2S:V2S) - IF ( CHAR .EQ. 'V' ) THEN - WRITE ( STDOUT, 5030 ) - ELSE IF ( CHAR .EQ. '*' ) THEN - WRITE ( STDOUT, 5031 ) - ELSE IF ( CHAR .EQ. 'I' ) THEN - WRITE ( STDOUT, 5032 ) LOW( V2S ), UPP( V2S ) - ELSE - IF ( ANYFIX(V2S) ) THEN - WRITE ( STDOUT, 5033 ) - ELSE - NUM = NBI ( CHOSEN( 1, V2S ), MAXTRG ) - WRITE ( STDOUT, 5034 ) ( CHOSEN( L, V2S ), L = 1, NUM ) - ENDIF - ENDIF -C - CHAR = TARGET(1)(VFX:VFX) - IF ( CHAR .EQ. 'V' ) THEN - WRITE ( STDOUT, 5035 ) - ELSE IF ( CHAR .EQ. '*' ) THEN - WRITE ( STDOUT, 5036 ) - ELSE IF ( CHAR .EQ. 'I' ) THEN - WRITE ( STDOUT, 5037 ) LOW( VFX ), UPP( VFX ) - ELSE - IF ( ANYFIX(VFX) ) THEN - WRITE ( STDOUT, 5038 ) - ELSE - NUM = NBI ( CHOSEN( 1, VFX ), MAXTRG ) - WRITE ( STDOUT, 5039 ) ( CHOSEN( L, VFX ), L = 1, NUM ) - ENDIF - ENDIF -C - CHAR = TARGET(1)(VARN:VARN) - IF ( CHAR .EQ. 'V' ) THEN - WRITE ( STDOUT, 5040 ) - ELSE IF ( CHAR .EQ. '*' ) THEN - WRITE ( STDOUT, 5041 ) - ELSE IF ( CHAR .EQ. 'I' ) THEN - WRITE ( STDOUT, 5042 ) LOW( VARN ), UPP( VARN ) - ELSE - IF ( ANYFIX(VARN) ) THEN - WRITE ( STDOUT, 5043 ) - ELSE - NUM = NBI ( CHOSEN( 1, VARN ), MAXTRG ) - WRITE ( STDOUT, 5044 ) ( CHOSEN( L, VARN ), L = 1, NUM ) - ENDIF - ENDIF -C -C Numbers of linear constraints -C - WRITE ( STDOUT, 5050 ) - CHAR = TARGET(1)(C1SL:C1SL) - IF ( CHAR .EQ. 'V' ) THEN - WRITE ( STDOUT, 5025 ) - ELSE IF ( CHAR .EQ. '*' ) THEN - WRITE ( STDOUT, 5026 ) - ELSE IF ( CHAR .EQ. 'I' ) THEN - WRITE ( STDOUT, 5027 ) LOW( C1SL ), UPP( C1SL ) - ELSE - IF ( ANYFIX(C1SL) ) THEN - WRITE ( STDOUT, 5028 ) - ELSE - NUM = NBI ( CHOSEN( 1, C1SL ), MAXTRG ) - WRITE ( STDOUT, 5029 ) ( CHOSEN( L, C1SL ), L = 1, NUM ) - ENDIF - ENDIF -C - CHAR = TARGET(1)(C2SL:C2SL) - IF ( CHAR .EQ. 'V' ) THEN - WRITE ( STDOUT, 5030 ) - ELSE IF ( CHAR .EQ. '*' ) THEN - WRITE ( STDOUT, 5031 ) - ELSE IF ( CHAR .EQ. 'I' ) THEN - WRITE ( STDOUT, 5032 ) LOW( C2SL ), UPP( C2SL ) - ELSE - IF ( ANYFIX(C2SL) ) THEN - WRITE ( STDOUT, 5033 ) - ELSE - NUM = NBI( CHOSEN( 1, C2SL ), MAXTRG ) - WRITE ( STDOUT, 5034 ) ( CHOSEN( L, C2SL ), L = 1, NUM ) - ENDIF - ENDIF -C - CHAR = TARGET(1)(CEQL:CEQL) - IF ( CHAR .EQ. 'V' ) THEN - WRITE ( STDOUT, 5045 ) - ELSE IF ( CHAR .EQ. '*' ) THEN - WRITE ( STDOUT, 5046 ) - ELSE IF ( CHAR .EQ. 'I' ) THEN - WRITE ( STDOUT, 5047 ) LOW( CEQL ), UPP( CEQL ) - ELSE - IF ( ANYFIX(CEQL) ) THEN - WRITE ( STDOUT, 5048 ) - ELSE - NUM = NBI ( CHOSEN( 1, CEQL ), MAXTRG ) - WRITE ( STDOUT, 5049 ) ( CHOSEN( L, CEQL ), L = 1, NUM ) - ENDIF - ENDIF -C -C Numbers of general constraints -C - WRITE ( STDOUT, 5051 ) - CHAR = TARGET(1)(C1SG:C1SG) - IF ( CHAR .EQ. 'V' ) THEN - WRITE ( STDOUT, 5025 ) - ELSE IF ( CHAR .EQ. '*' ) THEN - WRITE ( STDOUT, 5026 ) - ELSE IF ( CHAR .EQ. 'I' ) THEN - WRITE ( STDOUT, 5027 ) LOW( C1SG ), UPP( C1SG ) - ELSE - IF ( ANYFIX(C1SG) ) THEN - WRITE ( STDOUT, 5028 ) - ELSE - NUM = NBI ( CHOSEN( 1, C1SG ), MAXTRG ) - WRITE ( STDOUT, 5029 ) ( CHOSEN( L, C1SG ), L = 1, NUM ) - ENDIF - ENDIF -C - CHAR = TARGET(1)(C2SG:C2SG) - IF ( CHAR .EQ. 'V' ) THEN - WRITE ( STDOUT, 5030 ) - ELSE IF ( CHAR .EQ. '*' ) THEN - WRITE ( STDOUT, 5031 ) - ELSE IF ( CHAR .EQ. 'I' ) THEN - WRITE ( STDOUT, 5032 ) LOW( C2SG ), UPP( C2SG ) - ELSE - IF ( ANYFIX(C2SG) ) THEN - WRITE ( STDOUT, 5033 ) - ELSE - NUM = NBI ( CHOSEN( 1, C2SG ), MAXTRG ) - WRITE ( STDOUT, 5034 ) ( CHOSEN( L, C2SG ), L = 1, NUM ) - ENDIF - ENDIF -C - CHAR = TARGET(1)(CEQG:CEQG) - IF ( CHAR .EQ. 'V' ) THEN - WRITE ( STDOUT, 5045 ) - ELSE IF ( CHAR .EQ. '*' ) THEN - WRITE ( STDOUT, 5046 ) - ELSE IF ( CHAR .EQ. 'I' ) THEN - WRITE ( STDOUT, 5047 ) LOW( CEQG ), UPP( CEQG ) - ELSE - IF ( ANYFIX(CEQG) ) THEN - WRITE ( STDOUT, 5048 ) - ELSE - NUM = NBI ( CHOSEN( 1, CEQG ), MAXTRG ) - WRITE ( STDOUT, 5049 ) ( CHOSEN( L, CEQG ), L = 1, NUM ) - ENDIF - ENDIF -C - CHAR = TARGET(1)(VARM:VARM) - IF ( CHAR .EQ. 'V' ) THEN - WRITE ( STDOUT, 5040 ) - ELSE IF ( CHAR .EQ. '*' ) THEN - WRITE ( STDOUT, 5041 ) - ELSE IF ( CHAR .EQ. 'I' ) THEN - WRITE ( STDOUT, 5042 ) LOW( VARM ), UPP( VARM ) - ELSE - IF ( ANYFIX(VARM)) THEN - WRITE ( STDOUT, 5043 ) - ELSE - NUM = NBI ( CHOSEN( 1, VARM ), MAXTRG ) - WRITE ( STDOUT, 5044 ) ( CHOSEN( L, VARM ), L = 1, NUM ) - ENDIF - ENDIF -C -C Open the classification file. -C - OPEN( UNIT = CLSDVC, FILE = FILEN, STATUS = 'OLD' ) -C -C Read in the problem characteristic one wishes to specify -C - WRITE ( STDOUT, 5000 ) - 6 CONTINUE - WRITE ( STDOUT, 5001 ) - READ ( STDIN, '( A1 )', ERR = 2 ) CHAR - CHAR = UPPER( CHAR ) -C -C Get objective function target types -C - IF ( CHAR .EQ. 'O' ) THEN - 41 CONTINUE - NUM = 0 - WRITE ( STDOUT, 1002 ) - DO 30 I = 1, MIN( MAXTRG, 6 ) - 10 CONTINUE - IF ( NUM .EQ. 0) WRITE ( STDOUT, 1103 ) - IF ( NUM .GT. 0) WRITE ( STDOUT, 1003 ) - READ ( STDIN , FMT = '( A1 )', ERR = 20 ) CHOICE - CHOICE = UPPER( CHOICE ) - IF ( REJECT( CHOICE, OBJ, NUM ) ) GO TO 20 - IF ( I .GT. 1 ) THEN - IM1 = I - 1 - DO 35 J = 1, IM1 - IF ( TARGET(J)(OBJ:OBJ) .EQ. CHOICE ) THEN - WRITE ( STDOUT, 1101 ) - GO TO 10 - END IF - 35 CONTINUE - ENDIF - TARGET(I)(OBJ:OBJ) = CHOICE - IF ( CHOICE .NE. ' ' ) NUM = NUM + 1 - IF ( CHOICE .EQ. ' ' .OR. CHOICE .EQ. '*' ) GO TO 40 - GO TO 30 - 20 CONTINUE - WRITE ( STDOUT, 1001 ) - GO TO 10 - 30 CONTINUE -C -C Verify the type of objective function -C - 40 CONTINUE - IF ( NUM .EQ. 0 ) THEN - WRITE ( STDOUT, 2102 ) - GO TO 41 - ELSE - WRITE ( STDOUT, 2002 ) ( TARGET(K)(OBJ:OBJ), K = 1, NUM ) - ENDIF - WRITE ( STDOUT, 2003 ) - READ ( STDIN, '( A1 )' ) CHOICE - IF ( UPPER( CHOICE ) .EQ. 'Y' ) GO TO 41 -C -C Get constraints target types -C - ELSE IF ( CHAR .EQ. 'C' ) THEN - 111 CONTINUE - NUM = 0 - WRITE ( STDOUT, 1004 ) - DO 130 I = 1, MIN( MAXTRG, 6 ) - 110 CONTINUE - IF ( NUM .EQ. 0) WRITE ( STDOUT, 1105 ) - IF ( NUM .GT. 0) WRITE ( STDOUT, 1005 ) - READ ( STDIN , FMT = '( A1 )', ERR = 120 ) CHOICE - CHOICE = UPPER( CHOICE ) - IF ( REJECT( CHOICE, CON, NUM ) ) GO TO 120 - IF ( I .GT. 1 ) THEN - IM1 = I - 1 - DO 135 J = 1, IM1 - IF ( TARGET(J)(CON:CON) .EQ. CHOICE ) THEN - WRITE ( STDOUT, 1101 ) - GO TO 110 - END IF - 135 CONTINUE - ENDIF - TARGET(I)(CON:CON) = CHOICE - IF ( CHOICE .NE. ' ' ) NUM = NUM + 1 - IF ( CHOICE .EQ. ' ' .OR. CHOICE .EQ. '*' ) GO TO 140 - GO TO 130 - 120 CONTINUE - WRITE ( STDOUT, 1001 ) - GO TO 110 - 130 CONTINUE -C -C Verify the type of constraints -C - 140 CONTINUE - IF ( NUM .EQ. 0 ) THEN - WRITE ( STDOUT, 2104 ) - GO TO 111 - ELSE - WRITE ( STDOUT, 2004 ) ( TARGET(K)(CON:CON), K = 1, NUM ) - ENDIF - WRITE ( STDOUT, 2003 ) - READ ( STDIN, '( A1 )' ) CHOICE - IF ( UPPER( CHOICE ) .EQ. 'Y' ) GO TO 111 -C -C Get regularity target types -C - ELSE IF ( CHAR .EQ. 'R' ) THEN - 211 CONTINUE - WRITE ( STDOUT, 1006 ) - 210 CONTINUE - WRITE ( STDOUT, 1007 ) - READ ( STDIN , FMT = '( A1 )', ERR = 220 ) CHOICE - CHOICE = UPPER( CHOICE ) - IF ( REJECT( CHOICE, REG, 0 ) ) GO TO 220 - TARGET(1)(REG:REG) = CHOICE - GO TO 240 - 220 CONTINUE - WRITE ( STDOUT, 1001 ) - GO TO 210 - 240 CONTINUE -C -C Verify the problem's regularity -C - WRITE ( STDOUT, 2005 ) TARGET(1)(REG:REG) - WRITE ( STDOUT, 2003 ) - READ ( STDIN, '( A1 )' ) CHOICE - IF ( UPPER( CHOICE ) .EQ. 'Y' ) GO TO 211 -C -C Get derivative degree -C - ELSE IF ( CHAR .EQ. 'D' ) THEN - 311 CONTINUE - NUM = 0 - WRITE ( STDOUT, 1008 ) - DO 330 I = 1, MIN( MAXTRG, 3 ) - 310 CONTINUE - IF ( NUM .EQ. 0 ) WRITE ( STDOUT, 1109 ) - IF ( NUM .GT. 0 ) WRITE ( STDOUT, 1009 ) - READ ( STDIN , '( A1 )', ERR = 320 ) CHOICE - CHOICE = UPPER( CHOICE ) - IF ( REJECT( CHOICE, DER, NUM ) ) GO TO 320 - IF ( I .GT. 1 ) THEN - IM1 = I - 1 - DO 335 J = 1, IM1 - IF ( TARGET(J)(DER:DER) .EQ. CHOICE ) THEN - WRITE ( STDOUT, 1101 ) - GO TO 310 - END IF - 335 CONTINUE - ENDIF - TARGET(I)(DER:DER) = CHOICE - IF ( CHOICE .NE. ' ' ) NUM = NUM + 1 - IF ( CHOICE .EQ. ' ' .OR. CHOICE .EQ. '*' ) GO TO 340 - GO TO 330 - 320 CONTINUE - WRITE ( STDOUT, 1001 ) - GO TO 310 - 330 CONTINUE -C -C Verify the degree of available derivatives -C - 340 CONTINUE - IF ( NUM .EQ. 0 ) THEN - WRITE ( STDOUT, 2106 ) - GO TO 311 - ELSE - WRITE ( STDOUT, 2006 ) ( TARGET(K)(DER:DER), K = 1, NUM ) - ENDIF - WRITE ( STDOUT, 2003 ) - READ ( STDIN, '( A1 )' ) CHOICE - IF ( UPPER( CHOICE ) .EQ. 'Y' ) GO TO 311 -C -C Get problem interest -C - ELSE IF ( CHAR .EQ. 'I' ) THEN - 411 CONTINUE - NUM = 0 - WRITE ( STDOUT, 1010 ) - DO 430 I = 1, MIN( MAXTRG, 3 ) - 410 CONTINUE - IF ( NUM .EQ. 0 ) WRITE ( STDOUT, 1111 ) - IF ( NUM .GT. 0 ) WRITE ( STDOUT, 1011 ) - READ ( STDIN , FMT = '( A1 )', ERR = 420 ) CHOICE - CHOICE = UPPER( CHOICE ) - IF ( REJECT( CHOICE, INTRST, NUM ) ) GO TO 420 - IF ( I .GT. 1 ) THEN - IM1 = I - 1 - DO 435 J = 1, IM1 - IF ( TARGET(J)(INTRST:INTRST) .EQ. CHOICE ) THEN - WRITE ( STDOUT, 1101 ) - GO TO 410 - END IF - 435 CONTINUE - ENDIF - TARGET(I)(INTRST:INTRST) = CHOICE - IF ( CHOICE .NE. ' ' ) NUM = NUM + 1 - IF ( CHOICE .EQ. ' ' .OR. CHOICE .EQ. '*' ) GO TO 440 - GO TO 430 - 420 CONTINUE - WRITE ( STDOUT, 1001 ) - GO TO 410 - 430 CONTINUE -C -C Verify the problem's interest -C - 440 CONTINUE - IF ( NUM .EQ. 0 ) THEN - WRITE ( STDOUT, 2107 ) - GO TO 411 - ELSE - WRITE ( STDOUT, 2007 ) ( TARGET(K)(INTRST:INTRST), K = 1, NUM) - ENDIF - WRITE ( STDOUT, 2003 ) - READ ( STDIN, '( A1 )' ) CHOICE - IF ( UPPER( CHOICE ) .EQ. 'Y' ) GO TO 411 -C -C Get the internal variables indicator -C - ELSE IF ( CHAR .EQ. 'S' ) THEN - 511 CONTINUE - WRITE ( STDOUT, 1012 ) - 510 CONTINUE - WRITE ( STDOUT, 1013 ) - READ ( STDIN , '( A1 )', ERR = 520 ) CHOICE - CHOICE = UPPER( CHOICE ) - IF ( REJECT( CHOICE, INTVAR, 0 ) ) GO TO 520 - TARGET(1)(INTVAR:INTVAR) = CHOICE - GO TO 540 - 520 CONTINUE - WRITE ( STDOUT, 1001 ) - GO TO 510 -C -C Verify the indicator for explicit internal variables -C - 540 CONTINUE - IF ( CHOICE .EQ. 'Y' ) THEN - WRITE ( STDOUT, 2008 ) - ELSE IF ( CHOICE .EQ. 'N' ) THEN - WRITE ( STDOUT, 2018 ) - ELSE - WRITE ( STDOUT, 2017 ) - ENDIF - WRITE ( STDOUT, 2003 ) - READ ( STDIN, '( A1 )' ) CHOICE - IF ( UPPER( CHOICE ) .EQ. 'Y' ) GO TO 511 -C -C Get the number of variables -C - ELSE IF ( CHAR .EQ. 'F' ) THEN - - CALL GETDIM( VFR, TARGET(1)(VFR:VFR), ANYFIX(VFR), - 1 CHOSEN(1,VFR), LOW(VFR), UPP(VFR), MAXTRG, - 1 STDIN, STDOUT, UMAX, - 1 'free variables+ ' ) - ELSE IF ( CHAR .EQ. 'A' ) THEN - - CALL GETDIM( V1S, TARGET(1)(V1S:V1S), ANYFIX(V1S), - 1 CHOSEN(1,V1S), LOW(V1S), UPP(V1S), MAXTRG, - 1 STDIN, STDOUT, UMAX, - 1 'variables bounded below or above+ ' ) - - ELSE IF ( CHAR .EQ. 'B' ) THEN - CALL GETDIM( V2S, TARGET(1)(V2S:V2S), ANYFIX(V2S), - 1 CHOSEN(1,V2S), LOW(V2S), UPP(V2S), MAXTRG, - 1 STDIN, STDOUT, UMAX, - 1 'variables bounded below and above+' ) - - ELSE IF ( CHAR .EQ. 'X' ) THEN - - CALL GETDIM( VFX, TARGET(1)(VFX:VFX), ANYFIX(VFX), - 1 CHOSEN(1,VFX), LOW(VFX), UPP(VFX), MAXTRG, - 1 STDIN, STDOUT, UMAX, - 1 'fixed variables+ ' ) - - ELSE IF ( CHAR .EQ. 'N' ) THEN - - CALL GETDIM( VARN, TARGET(1)(VARN:VARN), ANYFIX(VARN), - 1 CHOSEN(1,VARN), LOW(VARN), UPP(VARN), MAXTRG, - 1 STDIN, STDOUT, UMAX, - 1 'variables+ ' ) -C -C Get the number of constraints -C - ELSE IF ( CHAR .EQ. 'P' ) THEN - CALL GETDIM( C1SL, TARGET(1)(C1SL:C1SL), ANYFIX(C1SL), - 1 CHOSEN(1,C1SL), LOW(C1SL), UPP(C1SL), MAXTRG, - 1 STDIN, STDOUT, UMAX, - 1 'one-sided linear constraints+ ' ) - - ELSE IF ( CHAR .EQ. 'Q' ) THEN - CALL GETDIM( C2SL, TARGET(1)(C2SL:C2SL), ANYFIX(C2SL), - 1 CHOSEN(1,C2SL), LOW(C2SL), UPP(C2SL), MAXTRG, - 1 STDIN, STDOUT, UMAX, - 1 'two-sided linear constraints+ ' ) - - ELSE IF ( CHAR .EQ. 'E' ) THEN - CALL GETDIM( CEQL, TARGET(1)(CEQL:CEQL), ANYFIX(CEQL), - 1 CHOSEN(1,CEQL), LOW(CEQL), UPP(CEQL), MAXTRG, - 1 STDIN, STDOUT, UMAX, - 1 'linear equality constraints+ ' ) - - ELSE IF ( CHAR .EQ. 'V' ) THEN - CALL GETDIM( C1SG, TARGET(1)(C1SG:C1SG), ANYFIX(C1SG), - 1 CHOSEN(1,C1SG), LOW(C1SG), UPP(C1SG), MAXTRG, - 1 STDIN, STDOUT, UMAX, - 1 'one-sided general constraints+ ' ) - - ELSE IF ( CHAR .EQ. 'W' ) THEN - CALL GETDIM( C2SG, TARGET(1)(C2SG:C2SG), ANYFIX(C2SG), - 1 CHOSEN(1,C2SG), LOW(C2SG), UPP(C2SG), MAXTRG, - 1 STDIN, STDOUT, UMAX, - 1 'two-sided general constraints+ ' ) - - ELSE IF ( CHAR .EQ. 'G' ) THEN - CALL GETDIM( CEQG, TARGET(1)(CEQG:CEQG), ANYFIX(CEQG), - 1 CHOSEN(1,CEQG), LOW(CEQG), UPP(CEQG), MAXTRG, - 1 STDIN, STDOUT, UMAX, - 1 'general equality constraints+ ' ) - - ELSE IF ( CHAR .EQ. 'M' ) THEN - CALL GETDIM( VARM, TARGET(1)(VARM:VARM), ANYFIX(VARM), - 1 CHOSEN(1,VARM), LOW(VARM), UPP(VARM), MAXTRG, - 1 STDIN, STDOUT, UMAX, - 1 'constraints+ ' ) -C -C All characteristics have been recorded. Quit -C - ELSE IF ( CHAR .EQ. ' ' ) THEN - GO TO 7 -C -C Error in the choice of characteristic -C - ELSE - GO TO 2 - ENDIF -C -C Loop for another characteristic -C - CLOSE ( CLSDVC ) - GO TO 5 -C -C Handle the error in characteristic choice -C - 2 CONTINUE - WRITE ( STDOUT, 1001 ) - GO TO 6 -C -C The target(s) are now defined. -C - 7 CONTINUE - WRITE (STDOUT, 4001 ) -C -C Loop on the problem classification and print names of matching ones -C in lots of 5. Also accumulate the number of matching problems found. -C - NMATCH = 0 - L = 0 - 3000 CONTINUE - READ ( CLSDVC, '( A200 )', END = 3010 ) PBCLS - IF ( PBCLS(1:1) .NE. '*' ) THEN - IF ( MATCH( PBCLS, TARGET, MAXTRG, ANYFIX, CHOSEN, - 1 LOW, UPP) ) THEN - NMATCH = NMATCH + 1 - L = L + 1 - LIST(L) = PBCLS(1:8) - IF ( L .EQ. 5 ) THEN - WRITE ( STDOUT, 4002 ) ( LIST(I), I = 1, 5 ) - L = 0 - END IF - END IF - ENDIF - GO TO 3000 -C -C End of the database processing for the main loop. -C -C Print selected problem names still -C in waiting list for output. -C - 3010 CONTINUE - IF ( L .GE. 1 ) WRITE ( STDOUT, 4002 ) ( LIST(I), I = 1, L ) - WRITE ( STDOUT, 4000 ) NMATCH - CLOSE ( CLSDVC ) - WRITE ( STDOUT, 7001 ) - READ ( STDIN, '( A1 )' ) CHOICE - IF ( UPPER( CHOICE ) .EQ. 'Y' ) THEN - OPEN( UNIT = CLSDVC, FILE = FILEN, STATUS = 'OLD' ) - WRITE ( STDOUT, 4955 ) - READ ( STDIN , FMT = '( A )' ) FILES - SIZE = LEN( FILES ) - OPEN( UNIT = FLSDVC, FILE = FILES, STATUS = 'UNKNOWN' ) - 3020 CONTINUE - READ ( CLSDVC, '( A36 )', END = 3050 ) PBCLS - IF ( PBCLS(1:1) .NE. '*' ) THEN - IF ( MATCH( PBCLS, TARGET, MAXTRG, ANYFIX, CHOSEN, - 1 LOW, UPP ) ) THEN - NBLK = 8 - DO 3030 NLBK = 8, 2, -1 - IF ( PBCLS(NBLK:NBLK) .NE. ' ' ) GO TO 3040 - 3030 CONTINUE - 3040 CONTINUE - WRITE ( FLSDVC, '(A)' ) PBCLS(1:NBLK) - END IF - END IF - GO TO 3020 - 3050 CLOSE ( FLSDVC ) - CLOSE ( CLSDVC ) - ENDIF - WRITE ( STDOUT, 7000 ) - READ ( STDIN, '( A1 )' ) CHOICE - IF ( UPPER( CHOICE ) .EQ. 'Y' ) GO TO 1 -C -C End of the database processing. -C - STOP -C -C Non excutable statements -C - 1000 FORMAT( /' *************************************************' - 1 /' * *' - 1 /' * Constrained and Unconstrained *' - 1 /' * Testing Environment *' - 1 /' * using safe threads *' - 1 /' * *' - 1 /' * ( CUTEst ) *' - 1 /' * *' - 1 /' * interactive problem selection *' - 1 /' * *' - 1 /' * CGT/GOR productions 1992,2014 *' - 1 /' * *' - 1 /' *************************************************' - 1 / ) - 1101 FORMAT( ' *** THIS SELECTION IS A REPETITION. Please choose ', - 1 'again.' - 1 / ) - 1201 FORMAT( ' *** YOU USED MORE THAN 32 CHARACTERS. Please choose', - 1 ' again.' - 1 / ) - 1001 FORMAT( ' *** YOUR ANSWER IS NOT ALLOWED. Please choose again.' - 1 / ) - 4950 FORMAT( /' Your current classification file is : ', - 1 A ) - 4957 FORMAT( /' Do you wish to change this [ = N] ?', - 1 ' (N/Y)') - 4955 FORMAT( ' Input the filename you want (up to 32 characters): ') - 5000 FORMAT( /' CHOOSE A PROBLEM CHARACTERISTIC THAT YOU WANT', - 1 ' TO SPECIFY :' - 1 /' ---------------------------------------------', - 1 '-------------' ) - 5001 FORMAT( /' O : Objective type C : Constraint', - 1 ' type' - 1 /' R : Regularity I : Problem', - 1 ' interest' - 1 /' D : Degree of available analytic derivatives' - 1 /' S : Presence of explicit internal variables' - 1 /' F : Number of free variables' - 1 /' A : Number of variables bounded below OR above' - 1 /' B : Number of variables bounded below AND above' - 1 /' X : Number of fixed variables' - 1 /' N : Total number of variables' - 1 /' P : Number of 1-sided linear inequality ', - 1 'constraints' - 1 /' Q : Number of 2-sided linear inequality ', - 1 'constraints' - 1 /' E : Number of linear equality constraints' - 1 /' V : Number of 1-sided general inequality ', - 1 'constraints' - 1 /' W : Number of 2-sided general inequality ', - 1 'constraints' - 1 /' G : Number of general equality constraints' - 1 /' M : Total number of constraints' - 1 /' : No further characteristic, perform', - 1 ' selection' - 1 /' ' - 1 /' Your choice :' ) - 5002 FORMAT( /' Your current problem selection key is:' - 1 /' ( * = anything goes )' ) - 5003 FORMAT( /' Objective function type : ', - 1 10 ( A1, 1X ) ) - 5004 FORMAT( ' Constraints type : ', - 1 10 ( A1, 1X ) ) - 5005 FORMAT( ' Regularity : ', - 1 10 ( A1, 1X ) ) - 5006 FORMAT( ' Degree of available derivatives : ', - 1 10 ( A1, 1X ) ) - 5007 FORMAT( ' Problem interest : ', - 1 10 ( A1, 1X ) ) - 5008 FORMAT( ' Explicit internal variables : ', - 1 10 ( A1, 1X ) ) - 5009 FORMAT( ' Number of variables' ) - 5020 FORMAT( ' Free : v' ) - 5021 FORMAT( ' Free : *' ) - 5022 FORMAT( ' Free : in [ ', - 1 I9,', ',I9,' ]' ) - 5023 FORMAT( ' Free : ', - 1 'any fixed number ') - 5024 FORMAT( ' Free :', 3( 1X, I9 ), - 1 /' ', 3( 1X, I9 ) ) - 5025 FORMAT( ' Bounded below OR above : v' ) - 5026 FORMAT( ' Bounded below OR above : *' ) - 5027 FORMAT( ' Bounded below OR above : in [ ', - 1 I9,', ',I9,' ]' ) - 5028 FORMAT( ' Bounded below OR above : ', - 1 'any fixed number ') - 5029 FORMAT( ' Bounded below OR above :', 3( 1X, I9 ), - 1 /' ', 3( 1X, I9 ) ) - 5030 FORMAT( ' Bounded below AND above : v' ) - 5031 FORMAT( ' Bounded below AND above : *' ) - 5032 FORMAT( ' Bounded below AND above : in [ ', - 1 I9,', ',I9,' ]' ) - 5033 FORMAT( ' Bounded below AND above : ', - 1 'any fixed number ') - 5034 FORMAT( ' Bounded below AND above :', 3( 1X, I9 ), - 1 /' ', 3( 1X, I9 ) ) - 5035 FORMAT( ' Fixed : v' ) - 5036 FORMAT( ' Fixed : *' ) - 5037 FORMAT( ' Fixed : in [ ', - 1 I9,', ',I9,' ]' ) - 5038 FORMAT( ' Fixed : ', - 1 'any fixed number ') - 5039 FORMAT( ' Fixed :', 3( 1X, I9 ), - 1 /' ', 3( 1X, I9 ) ) - 5040 FORMAT( ' Total : v' ) - 5041 FORMAT( ' Total : *' ) - 5042 FORMAT( ' Total : in [ ', - 1 I9,', ',I9,' ]' ) - 5043 FORMAT( ' Total : ', - 1 'any fixed number ') - 5044 FORMAT( ' Total :', 3( 1X, I9 ), - 1 /' ', 3( 1X, I9 ) ) - 5045 FORMAT( ' Equalities : v' ) - 5046 FORMAT( ' Equalities : *' ) - 5047 FORMAT( ' Equalities : in [ ', - 1 I9,', ',I9,' ]' ) - 5048 FORMAT( ' Equalities : ', - 1 'any fixed number ') - 5049 FORMAT( ' Equalities :', 3( 1X, I9 ), - 1 /' ', 3( 1X, I9 ) ) - 5050 FORMAT( ' Number of constraints ',/,' Linear:' ) - 5051 FORMAT( ' General:' ) - 1002 FORMAT( /' OBJECTIVE FUNCTION TYPE :' - 1 /' -------------------------' ) - 1103 FORMAT( /' C : Constant L : Linear' - 1 /' Q : Quadratic S : Sum of squares' - 1 /' N : No objective' - 1 /' O : Other (that is none of the above)' - 1 /' : Any of the above (*)' - 1 /' ' - 1 /' Your choice :' ) - 1003 FORMAT( /' C : Constant L : Linear' - 1 /' Q : Quadratic S : Sum of squares' - 1 /' N : No objective' - 1 /' O : Other (that is none of the above)' - 1 /' : No further type' - 1 /' ' - 1 /' Your choice :' ) - 1004 FORMAT( /' CONSTRAINTS TYPE :' - 1 /' ------------------' ) - 1105 FORMAT( /' U : No constraint X : Fixed variables', - 1 ' only' - 1 /' B : Bounds only N : Linear network' - 1 /' L : Linear Q : Quadratic' - 1 /' O : Other (that is more general than any of the', - 1 ' above alone)' - 1 /' : Any of the above (*)' - 1 /' ' - 1 /' Your choice :' ) - 1005 FORMAT( /' U : No constraint X : Fixed variables', - 1 ' only' - 1 /' B : Bounds only N : Linear network' - 1 /' L : Linear Q : Quadratic' - 1 /' O : Other (that is more general than any of the', - 1 ' above alone)' - 1 /' : No further type' - 1 /' ' - 1 /' Your choice :' ) - 1006 FORMAT( /' PROBLEM REGULARITY TYPE :' - 1 /' -------------------------' ) - 1007 FORMAT( /' R : Twice continuously differentiable' - 1 /' I : Other' - 1 /' : Any of the above (*)' - 1 /' ' - 1 /' Your choice :' ) - 1008 FORMAT( /' DEGREE OF AVAILABLE ANALYTICAL DERIVATIVES :' - 1 /' --------------------------------------------' ) - 1109 FORMAT( /' 0 : No analytical der. 1 : Analytical first' - 1 /' 2 : Analytical second' - 1 /' : Any of the above (*)' - 1 /' ' - 1 /' Your choice :' ) - 1009 FORMAT( /' 0 : No analytical der. 1 : Analytical first' - 1 /' 2 : Analytical second' - 1 /' : No further degree' - 1 /' ' - 1 /' Your choice :' ) - 1010 FORMAT( /' PROBLEM INTEREST TYPE :' - 1 /' -----------------------' ) - 1111 FORMAT( /' A : Academic R : Real application' - 1 /' M : Modelling' - 1 /' : Any of the above (*)' - 1 /' ' - 1 /' Your choice :' ) - 1011 FORMAT( /' A : Academic R : Real application' - 1 /' M : Modelling' - 1 /' : No further type' - 1 /' ' - 1 /' Your choice :' ) - 1012 FORMAT( /' PRESENCE OF EXPLICIT INTERNAL VARIABLES :' - 1 /' -----------------------------------------' ) - 1013 FORMAT( /' Y : Yes N : No' - 1 /' : Any of the above (*)' - 1 /' ' - 1 /' Your choice :' ) - 2002 FORMAT( /' You have specified objective of type(s): ', - 1 10( A1, 1X ) ) - 2102 FORMAT( /' *** Please choose an objective function type.' ) - 2003 FORMAT( ' Do you wish to reconsider your choice [ = N] ?', - 1 ' (N/Y)') - 2004 FORMAT( /' You have specified constraints of type(s): ', - 1 10( A1, 1X ) ) - 2104 FORMAT( /' *** Please choose a constraint type.' ) - 2005 FORMAT( /' You have specified regularity of type: ', A1 ) - 2006 FORMAT( /' You have specified derivatives of degree: ', - 1 10( A1, 1X ) ) - 2106 FORMAT(/' *** Please choose a degree of available derivatives.') - 2007 FORMAT( /' You have specified problem interest of type: ', - 1 10( A1, 1X ) ) - 2107 FORMAT( /' *** Please choose a problem interest type.' ) - 2008 FORMAT( /' You have specified problems with explicit', - 1 ' internal variables.' ) - 2018 FORMAT( /' You have specified problems without explicit', - 1 ' internal variables.' ) - 2017 FORMAT( /' You have specified problems with or without', - 1 ' explicit internal variables.' ) - 4000 FORMAT( /' ', I5, ' Problem(s) match(es) the specification.' / ) - 4001 FORMAT( /' MATCHING PROBLEMS :' - 1 /' -------------------' / ) - 4002 FORMAT( ' ', 5( A8, 3X ) ) -C Added by Kristjan Jonasson. - 7001 FORMAT( /' Do you wish to save the problem names to a file', - 1 ' [ = N] ? (N/Y)') - 7000 FORMAT( /' Do you wish to make another selection [ = N] ?', - 1 ' (N/Y)') - 8000 FORMAT( A256 ) - END -C -C----------------------------------------------------------------------------- -C - SUBROUTINE GETDIM( IDX, T, ANYIDX, NIDX, LOW, UPP, MAXTRG, - 1 STDIN, STDOUT, UMAX, THING ) -C -C----------------------------------------------------------------------------- -C -C The purpose of this function is to obtain the target for one particular -C problem dimension. -C -C Programming: Ph. Toint, Aug 2005. -C -C----------------------------------------------------------------------------- -C -C Arguments -C - INTEGER IDX, MAXTRG, STDOUT, STDIN, UMAX, NIDX( MAXTRG ), - 1 LOW, UPP - LOGICAL ANYIDX - CHARACTER*1 T - CHARACTER*34 THING -C -C Other variables -C - INTEGER NUM, I, J, IM1, K, LTH, CONVERT - LOGICAL REJECT - CHARACTER*1 CHOICE, UPPER - CHARACTER*34 UTHING, UNDER - CHARACTER*80 LINE -C - DO 100 I = 1, 34 - IF ( THING(I:I) .NE. '+' ) THEN - LTH = I - UTHING(I:I) = UPPER( THING(I:I) ) - UNDER(I:I) = '-' - ELSE - GO TO 611 - END IF - 100 CONTINUE -C -C Get the number of objects. -C - 611 CONTINUE - WRITE( STDOUT, 1014 ) UTHING(1:LTH), UNDER(1:LTH) - NUM = 0 - 610 CONTINUE - WRITE ( STDOUT, 1015 ) THING(1:LTH) - READ ( STDIN , FMT = '( A1 )', ERR = 620 ) CHOICE - CHOICE = UPPER( CHOICE ) - IF ( REJECT( CHOICE, IDX, 0 ) ) GO TO 620 - T = CHOICE - GO TO 640 - 620 CONTINUE - WRITE ( STDOUT, 1001 ) - GO TO 610 -C -C Verify the number type -C - 640 CONTINUE - IF ( CHOICE .EQ. 'F' ) THEN - WRITE ( STDOUT, 2009 ) THING(1:LTH) - ELSE IF ( CHOICE .EQ. 'V' ) THEN - WRITE ( STDOUT, 2019 ) THING(1:LTH) - ELSE IF ( CHOICE .EQ. 'I' ) THEN - WRITE ( STDOUT, 4009 ) THING(1:LTH) - ELSE - WRITE ( STDOUT, 2029 ) THING(1:LTH) - ENDIF - WRITE ( STDOUT, 2003 ) - READ ( STDIN, '( A1 )' ) CHOICE - IF ( UPPER( CHOICE ) .EQ. 'Y' ) GO TO 611 -C -C Get the fixed number -C - IF ( T .EQ. 'F' ) THEN - 641 CONTINUE - NUM = 0 - DO 670 I = 1, MAXTRG - WRITE( STDOUT, 1018 ) UTHING(1:LTH), UNDER(1:LTH) - 650 CONTINUE - IF ( NUM .EQ. 0) - 1 WRITE( STDOUT, 1119 ) THING(1:LTH), THING(1:LTH) - IF ( NUM .GT. 0) - 1 WRITE( STDOUT, 1019 ) THING(1:LTH), THING(1:LTH) - READ ( STDIN , '( A80 )', ERR = 660 ) LINE - CHOICE = UPPER( LINE(1:1) ) - IF ( NUM .EQ. 0 ) - 1 ANYIDX = CHOICE .EQ. '*' .OR. CHOICE .EQ. ' ' - IF ( NUM .NE. 0 ) ANYIDX = CHOICE .EQ. '*' - IF ( CHOICE .EQ. ' ' .OR. ANYIDX ) GO TO 695 - NIDX( I ) = CONVERT( LINE(1:9),9 ) - IF ( I .GT. 1 ) THEN - IM1 = I - 1 - DO 655 J = 1, IM1 - IF ( NIDX( J ) .EQ. NIDX( I ) ) GO TO 665 - 655 CONTINUE - ENDIF - IF ( NIDX( I ) .LT. 0 .OR. NIDX( I ) .GT. UMAX ) GO TO 660 - NUM = NUM + 1 - GO TO 670 - 660 CONTINUE - WRITE ( STDOUT, 1001 ) - GO TO 650 - 665 CONTINUE - WRITE ( STDOUT, 1101 ) - GO TO 650 - 670 CONTINUE -C -C Verify the number -C - 695 CONTINUE - IF ( ANYIDX ) THEN - WRITE ( STDOUT, 2020 ) THING(1:LTH) - ELSE - IF ( NUM .EQ. 0 ) THEN - WRITE ( STDOUT, 2110 ) THING(1:LTH) - GO TO 641 - ELSE - WRITE ( STDOUT, 2010 ) - 1 THING(1:LTH), ( NIDX( K ), K = 1, NUM ) - ENDIF - ENDIF - WRITE ( STDOUT, 2003 ) - READ ( STDIN, '( A1 )' ) CHOICE - IF ( UPPER( CHOICE ) .EQ. 'Y' ) GO TO 641 -C -C Get an interval for the number -C a) lower bound -C - ELSE IF ( T .EQ. 'I' ) THEN - 800 CONTINUE - LOW = 0 - UPP = UMAX - WRITE ( STDOUT, 4003 ) UTHING(1:LTH), UNDER(1:LTH) - 801 CONTINUE - WRITE ( STDOUT, 4004 ) THING(1:LTH), THING(1:LTH) - READ ( STDIN, '( A80 ) ', ERR = 802 ) LINE - CHOICE = UPPER( LINE(1:1) ) - IF ( CHOICE .NE. ' ' ) THEN - LOW = CONVERT( LINE(1:9),9 ) - IF ( LOW .LT. 0 .OR. LOW. GT. UMAX ) GO TO 802 - ENDIF - GO TO 805 - 802 CONTINUE - WRITE ( STDOUT, 1001 ) - GO TO 801 -C -C b) upper bound -C - 805 CONTINUE - WRITE ( STDOUT, 4005 ) UTHING(1:LTH), UNDER(1:LTH) - 803 CONTINUE - WRITE ( STDOUT, 4006 ) THING(1:LTH), THING(1:LTH) - READ ( STDIN, '( A80 ) ', ERR = 804 ) LINE - CHOICE = UPPER( LINE(1:1) ) - IF ( CHOICE .NE. ' ' ) THEN - UPP = CONVERT( LINE(1:9),9 ) - IF ( UPP .LT. 0 .OR. UPP. GT. UMAX .OR. LOW. GT. UPP ) - 1 GO TO 804 - ENDIF - GO TO 806 - 804 CONTINUE - WRITE ( STDOUT, 1001 ) - GO TO 803 -C -C Verify the bounds on the number -C - 806 CONTINUE - WRITE ( STDOUT, 4007 ) THING(1:LTH), LOW, UPP - WRITE ( STDOUT, 2003 ) - READ ( STDIN, '( A1 )' ) CHOICE - IF ( UPPER( CHOICE ) .EQ. 'Y' ) GO TO 800 - ENDIF - RETURN -C -C Non executable statements -C - 1001 FORMAT( ' *** YOUR ANSWER IS NOT ALLOWED. Please choose again.' - 1 / ) - 1101 FORMAT( ' *** THIS SELECTION IS A REPETITION. Please choose ', - 1 'again.' - 1 / ) - 1014 FORMAT( /' NUMBER OF ',A,':' - 1 /' -----------',A ) - 1015 FORMAT( /' F : Fixed V : Variable' - 1 /' I : In an interval' - 1 /' : Any number of ',A,' (*)' - 1 /' ' - 1 /' Your choice :' ) - 1018 FORMAT( /' SELECT A NUMBER OF ', A,':' - 1 /' --------------------', A ) - 1119 FORMAT( /' (INT) : Select only problems with (INT) ',A10, - 1 /' (minimum 0, maximum 999999999, multiple ', - 1 'choices are allowed)' - 1 /' : Any fixed number of ',A,' (*)' - 1 /' ' - 1 /' Your choice :' ) - 1019 FORMAT( /' (INT) : Select only problems with (INT) ', A, - 1 /' (minimum 0, maximum 999999999, multiple ', - 1 'choices are allowed)' - 1 /' * : Any fixed number of ', A, - 1 /' : No further selection', - 1 /' ' - 1 /' Your choice :' ) - 2003 FORMAT( ' Do you wish to reconsider your choice [ = N] ?', - 1 ' (N/Y)') - 2009 FORMAT( /' You have specified a fixed number of ',A,'.' ) - 2019 FORMAT( /' You have specified a variable number of ',A,'.' ) - 2029 FORMAT( /' You have specified any number of ',A,'.' ) - 2010 FORMAT( /' You have specified a number of ',A, - 1 ' in the set: ', - 1 /' ', 6( I9, 1X ) ) - 2020 FORMAT( /' You have specified any fixed number of ',A,'.' ) - 2110 FORMAT( /' *** Please choose a number of ',A,'.' ) - 4003 FORMAT( /' LOWER BOUND ON THE NUMBER OF ', A,':' - 1 /' ------------------------------', A ) - 4004 FORMAT( /' (INT) : Problems with at least (INT) ',A, - 1 /' : No lower bound on the number of ', A, - 1 /' ' - 1 /' Your choice : ' ) - 4005 FORMAT( /' UPPER BOUND ON THE NUMBER OF ', A,':' - 1 /' ------------------------------', A ) - 4006 FORMAT( /' (INT) : Problems with at most (INT) ',A, - 1 /' : No upper bound on the number of ',A, - 1 /' ' - 1 /' Your choice : ' ) - 4007 FORMAT( /' You have specified a number of ', A, - 1 /' in the interval [ ',I9,', ',I9,' ]' ) - 4009 FORMAT( /' You have specified an interval for the number of', - 1 /' ',A,'.' ) -C - END -C -C----------------------------------------------------------------------------- -C - LOGICAL FUNCTION REJECT( CHOICE, ITEM, NUM ) -C -C----------------------------------------------------------------------------- -C -C The purpose of this function is to verify if the character CHOICE -C is a valid specification for item ITEM, where ITEM is one of -C 1 = objective type, -C 2 = constraints type, -C 3 = problem regularity, -C 4 = degree of available derivatives, -C 5 = problem interest, -C 6 = presence of explicit internal variables, -C 7 = number of variables, -C 8 = number of constraints, -C 9 = number of free variables, -C 10 = number of variables bounded below or above, -C 11 = number of variables bounded below and above, -C 12 = number of fixed variables, -C 13 = number of 1-sided linear constraints, -C 14 = number of 2-sided linear constraints, -C 15 = number of linear equality constraints, -C 16 = number of 1-sided general constraints, -C 17 = number of 2-sided gereral constraints, -C 18 = number of general equality constraints, -C -C Programming: A. R. Conn and Ph. Toint for CGT Productions. -C -C----------------------------------------------------------------------------- -C -C -C Classification constants -C - INTEGER OBJ, CON, REG, DER, INTRST, INTVAR, VARN - PARAMETER ( OBJ = 1, CON = 2, REG = 3, DER = 4, INTRST = 5, - 1 INTVAR = 6, VARN = 7 ) -C -C Arguments -C - CHARACTER*1 CHOICE - INTEGER ITEM, NUM -C -C Other variables -C - LOGICAL ADMIT -C -C Control choices -C - IF ( ( CHOICE .EQ. ' ' .OR. CHOICE .EQ. '*' ) - 1 .AND. NUM .EQ. 0 ) THEN - CHOICE = '*' - REJECT = .FALSE. - RETURN -C -C Objective function type -C - ELSE IF ( ITEM .EQ. OBJ ) THEN - ADMIT = CHOICE .EQ. 'N' .OR. CHOICE .EQ. 'C' .OR. - 1 CHOICE .EQ. 'L' .OR. CHOICE .EQ. 'Q' .OR. - 1 CHOICE .EQ. 'S' .OR. CHOICE .EQ. 'O' .OR. - 1 CHOICE .EQ. ' ' -C -C Constraint type -C - ELSE IF ( ITEM .EQ. CON ) THEN - ADMIT = CHOICE .EQ. 'U' .OR. CHOICE .EQ. 'B' .OR. - 1 CHOICE .EQ. 'N' .OR. CHOICE .EQ. 'L' .OR. - 1 CHOICE .EQ. 'Q' .OR. CHOICE .EQ. 'O' .OR. - 1 CHOICE .EQ. 'X' .OR. CHOICE .EQ. ' ' -C -C Problem regularity -C - ELSE IF ( ITEM .EQ. REG ) THEN - ADMIT = CHOICE .EQ. 'R' .OR. CHOICE .EQ. 'I' -C -C Degree of analytical derivatives -C - ELSE IF ( ITEM .EQ. DER ) THEN - ADMIT = CHOICE .EQ. '0' .OR. CHOICE .EQ. '1' .OR. - 1 CHOICE .EQ. '2' .OR. CHOICE .EQ. ' ' -C -C Problem interest -C - ELSE IF ( ITEM .EQ. INTRST ) THEN - ADMIT = CHOICE .EQ. 'A' .OR. CHOICE .EQ. 'R' .OR. - 1 CHOICE .EQ. 'M' .OR. CHOICE .EQ. ' ' -C -C Presence of explicit internal variables -C - ELSE IF ( ITEM .EQ. INTVAR ) THEN - ADMIT = CHOICE .EQ. 'Y' .OR. CHOICE .EQ. 'N' -C -C Number of variables and constraints -C - ELSE IF ( ITEM .GE. VARN ) THEN - ADMIT = CHOICE .EQ. 'F' .OR. CHOICE .EQ. 'V' .OR. - 1 CHOICE .EQ. 'I' - ENDIF - REJECT = .NOT. ADMIT - RETURN - END -C -C----------------------------------------------------------------------------- -C - LOGICAL FUNCTION MATCH( C, T, MAXTRG, ANYFIX, CHOSEN, LOW, UPP ) -C -C----------------------------------------------------------------------------- -C -C The purpose of this function is to check if the classification C -C matches one of the targets specified by T, ANYFIX, CHOSEN, LOW and -C UPP. -C -C Programming: Ph. Toint, Dec 1991, for CGT Productions. Revised Aug 2005. -C -C----------------------------------------------------------------------------- -C - INTEGER OBJ, CON, REG, DER, INTR, INTV, VARN, VARM, - * VFR, V1S, V2S, VFX, C1SL, C2SL, CEQL, C1SG, C2SG, - * CEQG - PARAMETER ( OBJ = 1, CON = 2, REG = 3, DER = 4, - * INTR = 5, INTV = 6, VARN = 7, VARM = 8, - * VFR = 9, V1S = 10, V2S = 11, VFX = 12, - * C1SL = 13, C2SL = 14, CEQL = 15, C1SG = 16, - * C2SG = 17, CEQG = 18 ) -C -C Arguments -C - CHARACTER ( len = CEQG ) T( MAXTRG ) - CHARACTER*27 C - LOGICAL ANYFIX( 18 ) - INTEGER CHOSEN( MAXTRG, 18 ), MAXTRG, LOW( 18 ), UPP( 18 ) -C -C Other variables -C - CHARACTER*8 PBNAME - CHARACTER*1 OBJTYP, CONTYP, REGTYP, DERLVL, INTRST, INTVAR - INTEGER PBN, PBM, PBNFX, PBN1S, PBN2S, PBNFR, PBM1SL, - 1 PBM2SL, PBMEQL, PBM1SG, PBM2SG, PBMEQG - INTEGER I - LOGICAL ERROR, MATCHD - CHARACTER*1 CH - INTEGER WRONG, UNKNWN, VARIAB - PARAMETER ( WRONG = -10, UNKNWN = -5, VARIAB = -1 ) - - MATCH = .FALSE. -C -C Parse the current classification record. -C -c write(*,*) ' C = ', C - CALL PARSE ( C, PBNAME, OBJTYP, CONTYP, REGTYP, - 1 DERLVL, INTRST, INTVAR, PBN, PBM, PBNFR, - 2 PBN1S, PBN2S, PBNFX, PBM1SL, PBM2SL, PBMEQL, - 3 PBM1SG, PBM2SG, PBMEQG, ERROR ) - IF ( ERROR ) RETURN -c write(*,*) ' PBMEQL = ', PBMEQL -c write(*,*) ' PBMEQG = ', PBMEQG -C -C Match objective function type -C - DO 10 I = 1, MAXTRG - CH = T(I)(OBJ:OBJ) - IF ( CH .EQ. ' ' ) GO TO 20 - MATCH = MATCH .OR. CH .EQ. OBJTYP .OR. CH .EQ. '*' - 10 CONTINUE - 20 CONTINUE - IF ( .NOT. MATCH ) RETURN -C -C Match constraint type -C - MATCH = .FALSE. - DO 30 I = 1, MAXTRG - CH = T(I)(CON:CON) - IF ( CH .EQ. ' ' ) GO TO 40 - MATCH = MATCH .OR. CH .EQ. CONTYP .OR. CH .EQ. '*' - 30 CONTINUE - 40 CONTINUE - IF ( .NOT. MATCH ) RETURN -C -C Match regularity type -C - CH = T(1)(REG:REG) - MATCH = CH .EQ. REGTYP .OR. CH .EQ. '*' - IF ( .NOT. MATCH ) RETURN -C -C Match degree of available derivatives -C - MATCH = .FALSE. - DO 50 I = 1, MAXTRG - CH = T(I)(DER:DER) - IF ( CH .EQ. ' ' ) GO TO 60 - MATCH = MATCH .OR. CH .EQ. DERLVL .OR. CH .EQ. '*' - 50 CONTINUE - 60 CONTINUE - IF ( .NOT. MATCH ) RETURN -C -C Match interest of the problem -C - MATCH = .FALSE. - DO 70 I = 1, MAXTRG - CH = T(I)(INTR:INTR) - IF ( CH .EQ. ' ' ) GO TO 80 - MATCH = MATCH .OR. CH .EQ. INTRST .OR. CH .EQ. '*' - 70 CONTINUE - 80 CONTINUE - IF ( .NOT. MATCH ) RETURN -C -C Match for explicit internal variables -C - CH = T(1)(INTV:INTV) - MATCH = CH .EQ. INTVAR .OR. CH .EQ. '*' - IF ( .NOT. MATCH ) RETURN -C -C Match the numbers of variables -C - MATCH = MATCHD( PBNFR, T(1)(VFR:VFR), ANYFIX(VFR), LOW(VFR), - 1 UPP(VFR), CHOSEN(1,VFR), MAXTRG ) - IF ( .NOT. MATCH ) RETURN -C - MATCH = MATCHD( PBN1S, T(1)(V1S:V1S), ANYFIX(V1S), LOW(V1S), - 1 UPP(V1S), CHOSEN(1,V1S), MAXTRG ) - IF ( .NOT. MATCH ) RETURN -C - MATCH = MATCHD( PBN2S, T(1)(V2S:V2S), ANYFIX(V2S), LOW(V2S), - 1 UPP(V2S), CHOSEN(1,V2S), MAXTRG ) - IF ( .NOT. MATCH ) RETURN -C - MATCH = MATCHD( PBNFX, T(1)(VFX:VFX), ANYFIX(VFX), LOW(VFX), - 1 UPP(VFX), CHOSEN(1,VFX), MAXTRG ) - IF ( .NOT. MATCH ) RETURN -C - MATCH = MATCHD( PBN, T(1)(VARN:VARN), ANYFIX(VARN), LOW(VARN), - 1 UPP(VARN), CHOSEN(1,VARN), MAXTRG ) - IF ( .NOT. MATCH ) RETURN -C -C Match the numbers of constraints -C - MATCH = MATCHD( PBM1SL, T(1)(C1SL:C1SL), ANYFIX(C1SL), LOW(C1SL), - 1 UPP(C1SL), CHOSEN(1,C1SL), MAXTRG ) - IF ( .NOT. MATCH ) RETURN -C - MATCH = MATCHD( PBM2SL, T(1)(C2SL:C2SL), ANYFIX(C2SL), LOW(C2SL), - 1 UPP(C2SL), CHOSEN(1,C2SL), MAXTRG ) - IF ( .NOT. MATCH ) RETURN -C - MATCH = MATCHD( PBMEQL, T(1)(CEQL:CEQL), ANYFIX(CEQL), LOW(CEQL), - 1 UPP(CEQL), CHOSEN(1,CEQL), MAXTRG ) - IF ( .NOT. MATCH ) RETURN -C - MATCH = MATCHD( PBM1SG, T(1)(C1SG:C1SG), ANYFIX(C1SG), LOW(C1SG), - 1 UPP(C1SG), CHOSEN(1,C1SG), MAXTRG ) - IF ( .NOT. MATCH ) RETURN -C - MATCH = MATCHD( PBM2SG, T(1)(C2SG:C2SG), ANYFIX(C2SG), LOW(C2SG), - 1 UPP(C2SG), CHOSEN(1,C2SG), MAXTRG ) - IF ( .NOT. MATCH ) RETURN -C - MATCH = MATCHD( PBMEQG, T(1)(CEQG:CEQG), ANYFIX(CEQG), LOW(CEQG), - 1 UPP(CEQG), CHOSEN(1,CEQG), MAXTRG ) - IF ( .NOT. MATCH ) RETURN -C - MATCH = MATCHD( PBM, T(1)(VARM:VARM), ANYFIX(VARM), LOW(VARM), - 1 UPP(VARM), CHOSEN(1,VARM), MAXTRG ) - - RETURN - END -C -C----------------------------------------------------------------------------- -C - SUBROUTINE PARSE ( CLASSF, PBNAME, OBJTYP, CONTYP, REGTYP, - 1 DERLVL, INTRST, INTVAR, PBN, PBM, PBNFR, - 2 PBN1S, PBN2S, PBNFX, PBM1SL, PBM2SL, PBMEQL, - 3 PBM1SG, PBM2SG, PBMEQG, ERROR ) -C -C----------------------------------------------------------------------------- -C -C The purpose of this function is to parse one line of the CLASSF.DB -C database into its components, i.e. a problem name and the problem's -C caracteristics. It assumes the separators are either one hyphen or -C a string of at least one blank. -C -C Programming: Ph. Toint, Aug 2005. -C -C----------------------------------------------------------------------------- -C -C Arguments -C -C CHARACTER*200 CLASSF - CHARACTER*27 CLASSF - CHARACTER*8 PBNAME - CHARACTER*1 OBJTYP, CONTYP, REGTYP, DERLVL, INTRST, INTVAR - INTEGER PBN, PBM, PBNFX, PBN1S, PBN2S, PBNFR, PBM1SL, - 1 PBM2SL, PBMEQL, PBM1SG, PBM2SG, PBMEQG - LOGICAL ERROR -C -C Other variables -C - INTEGER IOBJ, IINT, IN, IM, INFX, IN1S, IN2S, INFR, IM1SL, - 1 IM2SL, IMEQL, IM1SG, IM2SG, IMEQG, JOBJ, JINT, JN, - 1 JM, JNFX, JN1S, JN2S, JNFR, JM1SL, JM2SL, JMEQL, - 1 JM1SG, JM2SG, JMEQG, L, MAXL - INTEGER CONVERT - PARAMETER ( MAXL = 200 ) - INTEGER WRONG, UNKNWN, VARIAB - PARAMETER ( WRONG = -10, UNKNWN = -5, VARIAB = -1 ) -C - ERROR = .FALSE. -C -C Get the problem name. -C - PBNAME = CLASSF(1:8) -C -C Find the start of each field. -C - CALL NXTSTR( CLASSF, 9, IOBJ, JOBJ ) -C write(*,*) ' IOBJ, JOBJ = ', IOBJ, JOBJ - IF ( IOBJ .LT. 0 ) GO TO 40 - CALL NXTSTR( CLASSF, JOBJ+2, IINT, JINT ) -C write(*,*) ' IINT, JINT = ', IINT, JINT - IF ( IINT .LT. 0 ) GO TO 40 - CALL NXTSTR( CLASSF, JINT+2, IN, JN ) -C write(*,*) ' IN, JN = ', IN, JN - IF ( IN .LT. 0 ) GO TO 40 - CALL NXTSTR( CLASSF, JN+2, IM, JM ) -C write(*,*) ' IM, JM = ', IM, JM - IF ( IM .LT. 0 ) GO TO 40 - CALL NXTSTR( CLASSF, JM+2, INFR, JNFR ) -C write(*,*) ' INFR, JNFR = ', INFR, JNFR - IF ( INFR .GT. 0 ) THEN - CALL NXTSTR( CLASSF, JNFR+2, IN1S, JN1S ) -C write(*,*) ' IN1S, JN1S = ', IN1S, JN1S - IF ( IN1S .LT. 0 ) GO TO 40 - CALL NXTSTR( CLASSF, JN1S+2, IN2S, JN2S ) -C write(*,*) ' IN2S, JN2S = ', IN2S, JN2S - IF ( IN2S .LT. 0 ) GO TO 40 - CALL NXTSTR( CLASSF, JN2S+2, INFX, JNFX ) -C write(*,*) ' INFX, JNFX = ', INFX, JNFX - IF ( INFX .LT. 0 ) GO TO 40 - CALL NXTSTR( CLASSF, JNFX+2, IM1SL, JM1SL ) -C write(*,*) ' IM1SL, JM1SL = ', IM1SL, JM1SL - IF ( IM1SL .LT. 0 ) GO TO 40 - CALL NXTSTR( CLASSF, JM1SL+2, IM2SL, JM2SL ) -C write(*,*) ' IM2SL, JM2SL = ', IM2SL, JM2SL - IF ( IM2SL .LT. 0 ) GO TO 40 - CALL NXTSTR( CLASSF, JM2SL+2, IMEQL, JMEQL ) -C write(*,*) ' IMEQL, JMEQL = ', IMEQL, JMEQL - IF ( IMEQL .LT. 0 ) GO TO 40 - CALL NXTSTR( CLASSF, JMEQL+2, IM1SG, JM1SG ) -C write(*,*) ' IM1SG, JM1SG = ', IM1SG, JM1SG - IF ( IM1SG .LT. 0 ) GO TO 40 - CALL NXTSTR( CLASSF, JM1SG+2, IM2SG, JM2SG ) -C write(*,*) ' IM2SG, JM2SG = ', IM2SG, JM2SG - IF ( IM2SG .LT. 0 ) GO TO 40 - CALL NXTSTR( CLASSF, JM2SG+2, IMEQG, JMEQG ) -C write(*,*) ' IMEQG, JMEQG = ', IMEQG, JMEQG - IF ( IMEQG .LT. 0 ) GO TO 40 - END IF -C -C Decrypt the objective string. -C - L = IOBJ - OBJTYP = CLASSF(L:L) - L = L + 1 - CONTYP = CLASSF(L:L) - L = L + 1 - REGTYP = CLASSF(L:L) - L = L + 1 - DERLVL = CLASSF(L:L) -C -C Decrypt the interest string. -C - L = IINT - INTRST = CLASSF(L:L) - L = L + 1 - INTVAR = CLASSF(L:L) -C -C Convert the remaining fields, if present. -C - PBN = CONVERT( CLASSF(IN:JN), JN-IN+1 ) - IF ( PBN .EQ. WRONG ) GO TO 40 - PBM = CONVERT( CLASSF(IM:JM), JM-IM+1 ) - IF ( PBM .EQ. WRONG ) GO TO 40 - IF ( INFR .GT. 0 ) THEN - PBNFR = CONVERT( CLASSF(INFR:JNFR), JNFR-INFR+1 ) - IF ( PBNFR .EQ. WRONG ) GO TO 40 - PBN1S = CONVERT( CLASSF(IN1S:JN1S), JN1S-IN1S+1 ) - IF ( PBN1S .EQ. WRONG ) GO TO 40 - PBN2S = CONVERT( CLASSF(IN2S:JN2S), JN2S-IN2S+1 ) - IF ( PBN2S .EQ. WRONG ) GO TO 40 - PBNFX = CONVERT( CLASSF(INFX:JNFX), JNFX-INFX+1 ) - IF ( PBNFX .EQ. WRONG ) GO TO 40 - PBM1SL = CONVERT( CLASSF(IM1SL:JM1SL), JM1SL-IM1SL+1 ) - IF ( PBM1SL .EQ. WRONG ) GO TO 40 - PBM2SL = CONVERT( CLASSF(IM2SL:JM2SL), JM2SL-IM2SL+1 ) - IF ( PBM2SL .EQ. WRONG ) GO TO 40 - PBMEQL = CONVERT( CLASSF(IMEQL:JMEQL), JMEQL-IMEQL+1 ) - IF ( PBMEQL .EQ. WRONG ) GO TO 40 - PBM1SG = CONVERT( CLASSF(IM1SG:JM1SG), JM1SG-IM1SG+1 ) - IF ( PBM1SG .EQ. WRONG ) GO TO 40 - PBM2SG = CONVERT( CLASSF(IM2SG:JM2SG), JM2SG-IM2SG+1 ) - IF ( PBM2SG .EQ. WRONG ) GO TO 40 - PBMEQG = CONVERT( CLASSF(IMEQG:JMEQG), JMEQG-IMEQG+1 ) - IF ( PBMEQG .EQ. WRONG ) GO TO 40 - ELSE - PBNFR = UNKNWN - PBN1S = UNKNWN - PBN2S = UNKNWN - PBNFX = UNKNWN - PBM1SL = UNKNWN - PBM2SL = UNKNWN - PBMEQL = UNKNWN - PBM1SG = UNKNWN - PBM2SG = UNKNWN - PBMEQG = UNKNWN - END IF - RETURN -C -C Error -C - 40 CONTINUE - ERROR = .TRUE. - RETURN - END -C -C----------------------------------------------------------------------------- -C - LOGICAL FUNCTION MATCHD( PVAL, T, ANYFIX, LOW, UPP, - * CHOSEN, MAXTRG ) -C -C----------------------------------------------------------------------------- -C -C The purpose of this function is to decide if the information -C on a problem contained in PVAL matches the pattern specified -C by ANYFIX, LOW, UPP and CHOSEN. -C -C Programming: Ph. Toint, Aug 2005. -C -C----------------------------------------------------------------------------- -C -C Arguments -C - INTEGER PVAL, LOW, UPP, MAXTRG, CHOSEN( MAXTRG ) - LOGICAL ANYFIX - CHARACTER*1 T -C - INTEGER VARIAB - PARAMETER ( VARIAB = -1 ) -C -C Match the number of constraints -C - MATCHD = .FALSE. - IF ( T .EQ. '*' ) THEN - MATCHD = .TRUE. - ELSE IF ( T .EQ. 'V' ) THEN - MATCHD = PVAL .EQ. VARIAB - ELSE IF ( T .EQ. 'I' ) THEN -C interval. A variable number of constraints is no longer considered to -C match a number in an interval. - IF ( PVAL .NE. VARIAB ) THEN - MATCHD = PVAL. GE. LOW .AND. PVAL .LE. UPP - ENDIF - ELSE - IF ( ANYFIX ) THEN - MATCHD = .TRUE. - ELSE -C A variable number of constraints is no longer considered to match a fixed -C number. - IF ( PVAL .NE. VARIAB ) THEN - DO 110 I = 1, MAXTRG - IF ( CHOSEN(I) .LT. 0 ) GO TO 110 - MATCHD = CHOSEN(I) .EQ. PVAL - IF ( MATCHD ) GO TO 120 - 110 CONTINUE - 120 CONTINUE - ENDIF - ENDIF - ENDIF - RETURN - END -C -C----------------------------------------------------------------------------- -C - SUBROUTINE NXTSTR ( STRING, IPOS, ISTART, ISTOP ) -C -C----------------------------------------------------------------------------- -C -C The purpose of this function is to find the position of the next separator -C ('-' or ' ') in STRING, after the next meaningful substring (i.e. not -C containing separators). If no meaningful substring is found, NXTSEP = -1 -C is returned. -C -C Programming: Ph. Toint, Aug 2005. -C -C----------------------------------------------------------------------------- -C -C Arguments -C -C CHARACTER*200 STRING - CHARACTER*27 STRING - INTEGER IPOS, ISTART, ISTOP -C -C Other variables -C - INTEGER J, MAXL -C PARAMETER ( MAXL = 200 ) - PARAMETER ( MAXL = 27 ) -C -C Remove initial blanks -C - ISTOP = -1 - DO 5 ISTART = IPOS, MAXL - IF ( STRING(ISTART:ISTART) .NE. ' ' ) GO TO 15 - 5 CONTINUE - ISTART = -1 - RETURN -C -C Find the end of the meaningful string. -C - 15 CONTINUE - J = ISTART - 1 - 100 CONTINUE - J = J + 1 - IF ( STRING(J:J) .NE. ' ' .AND. STRING(J:J) .NE. '-' ) THEN - ISTOP = 0 - ELSE - IF ( ISTOP .EQ. 0 ) THEN - ISTOP = J - 1 - RETURN - END IF - END IF - IF ( J .LE. MAXL ) GO TO 100 - RETURN - END -C -C----------------------------------------------------------------------------- -C - INTEGER FUNCTION CONVERT( LINE, LENL ) -C -C----------------------------------------------------------------------------- -C -C The purpose of this function is to convert the nonnegative integer contained -C in the string LINE into a proper integer. -C UNKNWN is returned in case of unknown number, -C VARIAB for a variable number, -C WRONG in case of error. -C -C Programming: Ph. Toint, Aug 2005, for CGT Productions. -C -C----------------------------------------------------------------------------- -C -C Arguments -C - CHARACTER*200 LINE - INTEGER LENL -C -C Other variables -C - INTEGER IS, IE, L - INTEGER WRONG, UNKNWN, VARIAB - PARAMETER ( WRONG = -10, UNKNWN = -5, VARIAB = -1 ) -C -C Remove trailing blanks -C - DO 5 IS = 1, LENL - IF ( LINE(IS:IS) .NE. ' ' ) GO TO 15 - 5 CONTINUE - GO TO 30 - 15 CONTINUE - DO 10 IE= LENL, 1, -1 - IF ( LINE(IE:IE) .NE. ' ' ) GO TO 20 - 10 CONTINUE - GO TO 30 -C -C Read the integer -C - 20 CONTINUE - L = IE - IS + 1 - IF ( L .EQ. 1 ) THEN - IF ( LINE(IS:IE) .EQ. '?' ) THEN - CONVERT = UNKNWN - ELSE IF ( LINE(IS:IE) .EQ. 'V' ) THEN - CONVERT = VARIAB - ELSE - READ ( LINE(IS:IE), '( I1 )', ERR = 30 ) CONVERT - END IF - ELSE IF ( L .EQ. 2 ) THEN - READ ( LINE(IS:IE), '( I2 )', ERR = 30 ) CONVERT - ELSE IF ( L .EQ. 3 ) THEN - READ ( LINE(IS:IE), '( I3 )', ERR = 30 ) CONVERT - ELSE IF ( L .EQ. 4 ) THEN - READ ( LINE(IS:IE), '( I4 )', ERR = 30 ) CONVERT - ELSE IF ( L .EQ. 5 ) THEN - READ ( LINE(IS:IE), '( I5 )', ERR = 30 ) CONVERT - ELSE IF ( L .EQ. 6 ) THEN - READ ( LINE(IS:IE), '( I6 )', ERR = 30 ) CONVERT - ELSE IF ( L .EQ. 7 ) THEN - READ ( LINE(IS:IE), '( I7 )', ERR = 30 ) CONVERT - ELSE IF ( L .EQ. 8 ) THEN - READ ( LINE(IS:IE), '( I8 )', ERR = 30 ) CONVERT - ELSE - READ ( LINE(IS:IE), '( I9 )', ERR = 30 ) CONVERT - ENDIF - RETURN -C -C Error -C - 30 CONTINUE - CONVERT = WRONG - RETURN - END -C -C----------------------------------------------------------------------------- -C - INTEGER FUNCTION NBT ( I, T, MX ) -C -C----------------------------------------------------------------------------- -C -C The purpose of this function is to return the number of non trivial -C choices of item I specified in the target list T. -C -C Programming: Ph. Toint, Dec 1991, for CGT Productions. -C -C----------------------------------------------------------------------------- -C -C Arguments -C - CHARACTER ( len = 18 ) T( MX ) - INTEGER I, MX -C -C Other variables -C - INTEGER L -C - NBT = 1 - DO 10 L = 2, MX - IF ( T(L)(I:I) .EQ. 'X' ) RETURN - NBT = NBT + 1 - 10 CONTINUE - RETURN - END -C -C----------------------------------------------------------------------------- -C - INTEGER FUNCTION NBI ( N, MX ) -C -C----------------------------------------------------------------------------- -C -C The purpose of this function is to return the number of non trivial -C dimensions specified in the integer dimension vector N. -C -C Programming: Ph. Toint, Dec 1991, for CGT Productions. -C -C----------------------------------------------------------------------------- -C -C Arguments -C - INTEGER N( MX ), MX -C -C Other variables -C - INTEGER L -C - NBI = 0 - DO 10 L = 1, MX - IF ( N(L) .LT. 0 ) RETURN - NBI = NBI + 1 - 10 CONTINUE - RETURN - END -C -C----------------------------------------------------------------------------- -C - CHARACTER*1 FUNCTION UPPER( CH ) -C -C----------------------------------------------------------------------------- -C -C The purpose of this function is to transform the character CH -C to upper case, if it is not already. -C -C Programming: Ph. Toint, Dec 1991, for CGT Productions. -C -C----------------------------------------------------------------------------- -C - CHARACTER*1 CH -C - INTRINSIC ICHAR, CHAR -C - INTEGER ICH, LSTART -C - LSTART = ICHAR( 'a' ) - ICH = ICHAR( CH ) - IF ( ICH .GE. LSTART .AND. ICH .LE. ICHAR( 'z' ) ) THEN - UPPER = CHAR( ICHAR( 'A' ) + ICH - LSTART ) - ELSE - UPPER = CH - ENDIF - RETURN - END -C -C----------------------------------------------------------------------------- -C diff --git a/src/select/slct_old.f b/src/select/slct_old.f deleted file mode 100644 index ef6f4c7..0000000 --- a/src/select/slct_old.f +++ /dev/null @@ -1,1438 +0,0 @@ -C ( Last modified on 22 Jan 2014 at 19:23:33 ) -C----------------------------------------------------------------------------- -C - PROGRAM SELECT -C -C----------------------------------------------------------------------------- -C -C The purpose of this program is to interrogate the file containing problem -C classifications (by default, $MASTSIF/CLASSF.DB) for obtaining a list -C of problems matching interactively defined characteristics. -C -C The dialog with the user is on the standard input/output. -C -C Programming: I. Bongartz, A.R. Conn and Ph. Toint for CGT Productions. -C Salford fortran by Kristjan Jonasson -C -C--------- THE FOLLOWING SPECIFICATIONS MAY BE MODIFIED BY THE USER ---------- -C -C Standard input default definition is device 5. Standard output default -C definition is device 6. Change them to whatever values are appropriate -C on your system. -C - INTEGER STDIN, STDOUT - PARAMETER ( STDIN = 5, STDOUT = 6 ) -C -C Name of the classification database -C - CHARACTER*32 NAME - PARAMETER ( NAME = 'CLASSF.DB' ) -C -C Device number for reading the classification database -C - INTEGER CLSDVC, FLSDVC - PARAMETER ( CLSDVC = 55, FLSDVC = 56 ) -C -C default directory for classification file. -C -C Device number and file name for file containing default directory -C - INTEGER DATDVC - PARAMETER ( DATDVC = 57 ) - CHARACTER*32 DATNAM - PARAMETER ( DATNAM = 'SLCT.DAT' ) -C -C---------------- END OF THE USER MODIFIABLE SPECIFICATION ------------------ -C -C Classification constants -C - INTEGER OBJ, CON, REG, DER, INTRST, INTVAR, VARN, VARM - PARAMETER ( OBJ = 1, CON = 2, REG = 3, DER = 4, INTRST = 5, - * INTVAR = 6, VARN = 7, VARM = 8 ) -C -C Maximum number of simultaneous targets in search -C - INTEGER MAXTRG - PARAMETER ( MAXTRG = 7 ) -C -C Variable definitions -C - CHARACTER*80 LINE -C names for classification file - CHARACTER*72 FILEN -C default directory for classification file - CHARACTER*256 DFTDIR -C names for output listing file -C Addition by Kristjan Jonasson - CHARACTER*72 FILES - CHARACTER*36 PBCLS - CHARACTER*8 TARGET( MAXTRG ), LIST(5) - CHARACTER*1 CHOICE, CHAR, UPPER - INTEGER I, IM1, J, NVAR( MAXTRG ), NCON( MAXTRG ), L, K, NUM, - * NMATCH, CONVERT, NBT, NBI, LN, UN, LM, SIZE, UM, - * NBLK - LOGICAL REJECT, ANYFNV, ANYFNC, MATCH - INTRINSIC MIN -C -C Banner -C - WRITE ( STDOUT, 1000 ) -C -C in order that this program can give the full path name for the -C default classification file. -C -C Open the file containing the default directory name. -C - OPEN ( UNIT = DATDVC, FILE = DATNAM, STATUS = 'OLD' ) -C -C Read in the default directory -C - READ ( DATDVC, 8000 ) DFTDIR - CLOSE ( DATDVC ) - DO 910 I = 1, 256 - IF ( DFTDIR( I : I ) .EQ. ' ' ) THEN - SIZE = I - 1 - GO TO 920 - END IF - 910 CONTINUE - SIZE = 256 - 920 CONTINUE - FILEN = DFTDIR( 1 : SIZE ) // '/' // NAME - SIZE = LEN( FILEN ) -C -C MAIN LOOP -C - 1 CONTINUE -C -C Target initialization -C - DO 4 I = 1, MAXTRG - NVAR(I) = -2 - NCON(I) = -2 - TARGET(I) = 'XXXXXXXX' - 4 CONTINUE - TARGET(1) = '********' - ANYFNV = .FALSE. - ANYFNC = .FALSE. -C -C Bounds on the number of variables and constraints are initialized -C to be inactive. -C - LN = 0 - LM = 0 - UN = 99999999 - UM = 99999999 -C -C Verify the name of the classification database file -C - 77 CONTINUE - WRITE ( STDOUT, 4950 ) FILEN(1:SIZE) - WRITE ( STDOUT, 4957 ) - READ ( STDIN, '( A1 )' ) CHOICE - IF ( UPPER( CHOICE ) .EQ. 'Y' ) THEN - WRITE ( STDOUT, 4955 ) - READ ( STDIN , FMT = '( A )', ERR = 78 ) FILEN - SIZE = LEN( FILEN ) - GO TO 77 - 78 WRITE ( STDOUT, 1201 ) - GO TO 77 - ENDIF -C -C Writes the current specification -C - 5 CONTINUE - WRITE ( STDOUT, 5002 ) - NUM = NBT ( OBJ, TARGET, MAXTRG ) - WRITE ( STDOUT, 5003 ) ( TARGET(L)(OBJ:OBJ), L = 1, NUM ) - NUM = NBT ( CON, TARGET, MAXTRG ) - WRITE ( STDOUT, 5004 ) ( TARGET(L)(CON:CON), L = 1, NUM ) - WRITE ( STDOUT, 5005 ) TARGET(1)(REG:REG) - NUM = NBT ( DER, TARGET, MAXTRG ) - WRITE ( STDOUT, 5006 ) ( TARGET(L)(DER:DER), L = 1, NUM ) - NUM = NBT ( INTRST, TARGET, MAXTRG ) - WRITE ( STDOUT, 5007 ) ( TARGET(L)(INTRST:INTRST), L = 1, NUM ) - WRITE ( STDOUT, 5008 ) TARGET(1)(INTVAR:INTVAR) - IF ( TARGET(1)(VARN:VARN) .EQ. 'V' ) THEN - WRITE ( STDOUT, 5009 ) - ELSE IF ( TARGET(1)(VARN:VARN) .EQ. '*' ) THEN - WRITE ( STDOUT, 5010 ) - ELSE IF ( TARGET(1)(VARN:VARN) .EQ. 'I' ) THEN - WRITE ( STDOUT, 4008 ) LN, UN - ELSE - IF ( ANYFNV ) THEN - WRITE ( STDOUT, 5011 ) - ELSE - NUM = NBI ( NVAR, MAXTRG ) - WRITE ( STDOUT, 5012 ) ( NVAR(L), l = 1, NUM ) - ENDIF - ENDIF - IF ( TARGET(1)(VARM:VARM) .EQ. 'V' ) THEN - WRITE ( STDOUT, 5013 ) - ELSE IF ( TARGET(1)(VARM:VARM) .EQ. '*' ) THEN - WRITE ( STDOUT, 5014 ) - ELSE IF ( TARGET(1)(VARM:VARM) .EQ. 'I' ) THEN - WRITE ( STDOUT, 6008 ) LM, UM - ELSE - IF ( ANYFNV ) THEN - WRITE ( STDOUT, 5015 ) - ELSE - NUM = NBI ( NCON, MAXTRG ) - WRITE ( STDOUT, 5016 ) ( NCON(L), l = 1, NUM ) - ENDIF - ENDIF -C -C Open the classification file. -C - OPEN( UNIT = CLSDVC, FILE = FILEN, STATUS = 'OLD' ) -C -C Read in the problem characteristic one wishes to specify -C - WRITE ( STDOUT, 5000 ) - 6 CONTINUE - WRITE ( STDOUT, 5001 ) - READ ( STDIN, '( A1 )', ERR = 2 ) CHAR - CHAR = UPPER( CHAR ) -C -C Get objective function target types -C - IF ( CHAR .EQ. 'O' ) THEN - 41 CONTINUE - NUM = 0 - WRITE ( STDOUT, 1002 ) - DO 30 I = 1, MIN( MAXTRG, 6 ) - 10 CONTINUE - IF ( NUM .EQ. 0) WRITE ( STDOUT, 1103 ) - IF ( NUM .GT. 0) WRITE ( STDOUT, 1003 ) - READ ( STDIN , FMT = '( A1 )', ERR = 20 ) CHOICE - CHOICE = UPPER( CHOICE ) - IF ( REJECT( CHOICE, OBJ, NUM ) ) GO TO 20 - IF ( I .GT. 1 ) THEN - IM1 = I - 1 - DO 35 J = 1, IM1 - IF ( TARGET(J)(OBJ:OBJ) .EQ. CHOICE ) GO TO 25 - 35 CONTINUE - ENDIF - TARGET(I)(OBJ:OBJ) = CHOICE - IF ( CHOICE .NE. ' ' ) NUM = NUM + 1 - IF ( CHOICE .EQ. ' ' .OR. CHOICE .EQ. '*' ) GO TO 40 - GO TO 30 - 20 CONTINUE - WRITE ( STDOUT, 1001 ) - GO TO 10 - 25 CONTINUE - WRITE ( STDOUT, 1101 ) - GO TO 10 - 30 CONTINUE -C -C Verify the type of objective function -C - 40 CONTINUE - IF ( NUM .EQ. 0 ) THEN - WRITE ( STDOUT, 2102 ) - GO TO 41 - ELSE - WRITE ( STDOUT, 2002 ) ( TARGET(K)(OBJ:OBJ), K = 1, NUM ) - ENDIF - WRITE ( STDOUT, 2003 ) - READ ( STDIN, '( A1 )' ) CHOICE - IF ( UPPER( CHOICE ) .EQ. 'Y' ) GO TO 41 -C -C Get constraints target types -C - ELSE IF ( CHAR .EQ. 'C' ) THEN - 111 CONTINUE - NUM = 0 - WRITE ( STDOUT, 1004 ) - DO 130 I = 1, MIN( MAXTRG, 6 ) - 110 CONTINUE - IF ( NUM .EQ. 0) WRITE ( STDOUT, 1105 ) - IF ( NUM .GT. 0) WRITE ( STDOUT, 1005 ) - READ ( STDIN , FMT = '( A1 )', ERR = 120 ) CHOICE - CHOICE = UPPER( CHOICE ) - IF ( REJECT( CHOICE, CON, NUM ) ) GO TO 120 - IF ( I .GT. 1 ) THEN - IM1 = I - 1 - DO 135 J = 1, IM1 - IF ( TARGET(J)(CON:CON) .EQ. CHOICE ) GO TO 125 - 135 CONTINUE - ENDIF - TARGET(I)(CON:CON) = CHOICE - IF ( CHOICE .NE. ' ' ) NUM = NUM + 1 - IF ( CHOICE .EQ. ' ' .OR. CHOICE .EQ. '*' ) GO TO 140 - GO TO 130 - 120 CONTINUE - WRITE ( STDOUT, 1001 ) - GO TO 110 - 125 CONTINUE - WRITE ( STDOUT, 1101 ) - GO TO 110 - 130 CONTINUE -C -C Verify the type of constraints -C - 140 CONTINUE - IF ( NUM .EQ. 0 ) THEN - WRITE ( STDOUT, 2104 ) - GO TO 111 - ELSE - WRITE ( STDOUT, 2004 ) ( TARGET(K)(CON:CON), K = 1, NUM ) - ENDIF - WRITE ( STDOUT, 2003 ) - READ ( STDIN, '( A1 )' ) CHOICE - IF ( UPPER( CHOICE ) .EQ. 'Y' ) GO TO 111 -C -C Get regularity target types -C - ELSE IF ( CHAR .EQ. 'R' ) THEN - 211 CONTINUE - WRITE ( STDOUT, 1006 ) - 210 CONTINUE - WRITE ( STDOUT, 1007 ) - READ ( STDIN , FMT = '( A1 )', ERR = 220 ) CHOICE - CHOICE = UPPER( CHOICE ) - IF ( REJECT( CHOICE, REG, 0 ) ) GO TO 220 - TARGET(1)(REG:REG) = CHOICE - GO TO 240 - 220 CONTINUE - WRITE ( STDOUT, 1001 ) - GO TO 210 - 240 CONTINUE -C -C Verify the problem's regularity -C - WRITE ( STDOUT, 2005 ) TARGET(1)(REG:REG) - WRITE ( STDOUT, 2003 ) - READ ( STDIN, '( A1 )' ) CHOICE - IF ( UPPER( CHOICE ) .EQ. 'Y' ) GO TO 211 -C -C Get derivative degree -C - ELSE IF ( CHAR .EQ. 'D' ) THEN - 311 CONTINUE - NUM = 0 - WRITE ( STDOUT, 1008 ) - DO 330 I = 1, MIN( MAXTRG, 3 ) - 310 CONTINUE - IF ( NUM .EQ. 0 ) WRITE ( STDOUT, 1109 ) - IF ( NUM .GT. 0 ) WRITE ( STDOUT, 1009 ) - READ ( STDIN , '( A1 )', ERR = 320 ) CHOICE - CHOICE = UPPER( CHOICE ) - IF ( REJECT( CHOICE, DER, NUM ) ) GO TO 320 - IF ( I .GT. 1 ) THEN - IM1 = I - 1 - DO 335 J = 1, IM1 - IF ( TARGET(J)(DER:DER) .EQ. CHOICE ) GO TO 325 - 335 CONTINUE - ENDIF - TARGET(I)(DER:DER) = CHOICE - IF ( CHOICE .NE. ' ' ) NUM = NUM + 1 - IF ( CHOICE .EQ. ' ' .OR. CHOICE .EQ. '*' ) GO TO 340 - GO TO 330 - 320 CONTINUE - WRITE ( STDOUT, 1001 ) - GO TO 310 - 325 CONTINUE - WRITE ( STDOUT, 1101 ) - GO TO 310 - 330 CONTINUE -C -C Verify the degree of available derivatives -C - 340 CONTINUE - IF ( NUM .EQ. 0 ) THEN - WRITE ( STDOUT, 2106 ) - GO TO 311 - ELSE - WRITE ( STDOUT, 2006 ) ( TARGET(K)(DER:DER), K = 1, NUM ) - ENDIF - WRITE ( STDOUT, 2003 ) - READ ( STDIN, '( A1 )' ) CHOICE - IF ( UPPER( CHOICE ) .EQ. 'Y' ) GO TO 311 -C -C Get problem interest -C - ELSE IF ( CHAR .EQ. 'I' ) THEN - 411 CONTINUE - NUM = 0 - WRITE ( STDOUT, 1010 ) - DO 430 I = 1, MIN( MAXTRG, 3 ) - 410 CONTINUE - IF ( NUM .EQ. 0 ) WRITE ( STDOUT, 1111 ) - IF ( NUM .GT. 0 ) WRITE ( STDOUT, 1011 ) - READ ( STDIN , FMT = '( A1 )', ERR = 420 ) CHOICE - CHOICE = UPPER( CHOICE ) - IF ( REJECT( CHOICE, INTRST, NUM ) ) GO TO 420 - IF ( I .GT. 1 ) THEN - IM1 = I - 1 - DO 435 J = 1, IM1 - IF ( TARGET(J)(INTRST:INTRST) .EQ. CHOICE ) GO TO 425 - 435 CONTINUE - ENDIF - TARGET(I)(INTRST:INTRST) = CHOICE - IF ( CHOICE .NE. ' ' ) NUM = NUM + 1 - IF ( CHOICE .EQ. ' ' .OR. CHOICE .EQ. '*' ) GO TO 440 - GO TO 430 - 420 CONTINUE - WRITE ( STDOUT, 1001 ) - GO TO 410 - 425 CONTINUE - WRITE ( STDOUT, 1101 ) - GO TO 410 - 430 CONTINUE -C -C Verify the problem's interest -C - 440 CONTINUE - IF ( NUM .EQ. 0 ) THEN - WRITE ( STDOUT, 2107 ) - GO TO 411 - ELSE - WRITE ( STDOUT, 2007 ) ( TARGET(K)(INTRST:INTRST), K = 1, NUM) - ENDIF - WRITE ( STDOUT, 2003 ) - READ ( STDIN, '( A1 )' ) CHOICE - IF ( UPPER( CHOICE ) .EQ. 'Y' ) GO TO 411 -C -C Get the internal variables indicator -C - ELSE IF ( CHAR .EQ. 'S' ) THEN - 511 CONTINUE - WRITE ( STDOUT, 1012 ) - 510 CONTINUE - WRITE ( STDOUT, 1013 ) - READ ( STDIN , '( A1 )', ERR = 520 ) CHOICE - CHOICE = UPPER( CHOICE ) - IF ( REJECT( CHOICE, INTVAR, 0 ) ) GO TO 520 - TARGET(1)(INTVAR:INTVAR) = CHOICE - GO TO 540 - 520 CONTINUE - WRITE ( STDOUT, 1001 ) - GO TO 510 -C -C Verify the indicator for explicit internal variables -C - 540 CONTINUE - IF ( CHOICE .EQ. 'Y' ) THEN - WRITE ( STDOUT, 2008 ) - ELSE IF ( CHOICE .EQ. 'N' ) THEN - WRITE ( STDOUT, 2018 ) - ELSE - WRITE ( STDOUT, 2017 ) - ENDIF - WRITE ( STDOUT, 2003 ) - READ ( STDIN, '( A1 )' ) CHOICE - IF ( UPPER( CHOICE ) .EQ. 'Y' ) GO TO 511 -C -C Get the number of variables -C - ELSE IF ( CHAR .EQ. 'N' ) THEN - 611 CONTINUE - NUM = 0 - WRITE ( STDOUT, 1014 ) - 610 CONTINUE - WRITE ( STDOUT, 1015 ) - READ ( STDIN , FMT = '( A1 )', ERR = 620 ) CHOICE - CHOICE = UPPER( CHOICE ) - IF ( REJECT( CHOICE, VARN, 0 ) ) GO TO 620 - TARGET(1)(VARN:VARN) = CHOICE - GO TO 640 - 620 CONTINUE - WRITE ( STDOUT, 1001 ) - GO TO 610 -C -C Verify the number of variables type -C - 640 CONTINUE - IF ( CHOICE .EQ. 'F' ) THEN - WRITE ( STDOUT, 2009 ) - ELSE IF ( CHOICE .EQ. 'V' ) THEN - WRITE ( STDOUT, 2019 ) - ELSE IF ( CHOICE .EQ. 'I' ) THEN - WRITE ( STDOUT, 4009 ) - ELSE - WRITE ( STDOUT, 2029 ) - ENDIF - WRITE ( STDOUT, 2003 ) - READ ( STDIN, '( A1 )' ) CHOICE - IF ( UPPER( CHOICE ) .EQ. 'Y' ) GO TO 611 -C -C Get the fixed number of variables -C - IF ( TARGET(1)(VARN:VARN) .EQ. 'F' ) THEN - 641 CONTINUE - NUM = 0 - DO 670 I = 1, MAXTRG - WRITE( STDOUT, 1018 ) - 650 CONTINUE - IF ( NUM .EQ. 0) WRITE( STDOUT, 1119 ) - IF ( NUM .GT. 0) WRITE( STDOUT, 1019 ) - READ ( STDIN , '( A80 )', ERR = 660 ) LINE - CHOICE = UPPER( LINE(1:1) ) - IF ( NUM .EQ. 0 ) ANYFNV = - 1 CHOICE .EQ. '*' .OR. CHOICE .EQ. ' ' - IF ( NUM .NE. 0 ) ANYFNV = CHOICE .EQ. '*' - IF ( CHOICE .EQ. ' ' .OR. ANYFNV ) GO TO 695 - NVAR( I ) = CONVERT( LINE(1:5) ) - IF ( I .GT. 1 ) THEN - IM1 = I - 1 - DO 655 J = 1, IM1 - IF ( NVAR(J) .EQ. NVAR(I) ) GO TO 665 - 655 CONTINUE - ENDIF - IF ( NVAR(I) .LT. 0 .OR. NVAR(I) .GT. 99999999 ) GO TO 660 - NUM = NUM + 1 - GO TO 670 - 660 CONTINUE - WRITE ( STDOUT, 1001 ) - GO TO 650 - 665 CONTINUE - WRITE ( STDOUT, 1101 ) - GO TO 650 - 670 CONTINUE -C -C Verify the number of variables -C - 695 CONTINUE - IF ( ANYFNV ) THEN - WRITE ( STDOUT, 2020 ) - ELSE - IF ( NUM .EQ. 0 ) THEN - WRITE ( STDOUT, 2110 ) - GO TO 641 - ELSE - WRITE ( STDOUT, 2010 ) ( NVAR(K), K = 1, NUM ) - ENDIF - ENDIF - WRITE ( STDOUT, 2003 ) - READ ( STDIN, '( A1 )' ) CHOICE - IF ( UPPER( CHOICE ) .EQ. 'Y' ) GO TO 641 -C -C Get an interval for the number of variables -C a) lower bound -C - ELSE IF ( TARGET(1)(VARN:VARN) .EQ. 'I' ) THEN - 800 CONTINUE - LN = 0 - UN = 99999999 - WRITE ( STDOUT, 4003 ) - 801 CONTINUE - WRITE ( STDOUT, 4004 ) - READ ( STDIN, '( A80 ) ', ERR = 802 ) LINE - CHOICE = UPPER( LINE(1:1) ) - IF ( CHOICE .NE. ' ' ) THEN - LN = CONVERT( LINE(1:5) ) - IF ( LN .LT. 0 .OR. LN. GT. 99999999 ) GO TO 802 - ENDIF - GO TO 805 - 802 CONTINUE - WRITE ( STDOUT, 1001 ) - GO TO 801 -C -C b) upper bound -C - 805 CONTINUE - WRITE ( STDOUT, 4005 ) - 803 CONTINUE - WRITE ( STDOUT, 4006 ) - READ ( STDIN, '( A80 ) ', ERR = 804 ) LINE - CHOICE = UPPER( LINE(1:1) ) - IF ( CHOICE .NE. ' ' ) THEN - UN = CONVERT( LINE(1:5) ) - IF ( UN .LT. 0 .OR. UN. GT. 99999999 .OR. LN. GT. UN ) - 1 GO TO 804 - ENDIF - GO TO 806 - 804 CONTINUE - WRITE ( STDOUT, 1001 ) - GO TO 803 -C -C Verify the bounds on the number of variables -C - 806 CONTINUE - WRITE ( STDOUT, 4007 ) LN, UN - WRITE ( STDOUT, 2003 ) - READ ( STDIN, '( A1 )' ) CHOICE - IF ( UPPER( CHOICE ) .EQ. 'Y' ) GO TO 800 - ENDIF -C -C Get the number of constraints -C - ELSE IF ( CHAR .EQ. 'M' ) THEN - NUM = 0 - 711 CONTINUE - WRITE ( STDOUT, 1016 ) - 710 CONTINUE - WRITE ( STDOUT, 1017 ) - READ ( STDIN , FMT = '( A1 )', ERR = 720 ) CHOICE - CHOICE = UPPER( CHOICE ) - IF ( REJECT( CHOICE, VARM, 0 ) ) GO TO 720 - TARGET(1)(VARM:VARM) = CHOICE - GO TO 740 - 720 CONTINUE - WRITE ( STDOUT, 1001 ) - GO TO 710 -C -C Verify the constraints number type -C - 740 CONTINUE - IF ( CHOICE .EQ. 'F' ) THEN - WRITE ( STDOUT, 2011 ) - ELSE IF ( CHOICE .EQ. 'V' ) THEN - WRITE ( STDOUT, 2021 ) - ELSE IF ( CHOICE .EQ. 'I' ) THEN - WRITE ( STDOUT, 6009 ) - ELSE - WRITE ( STDOUT, 2031 ) - ENDIF - WRITE ( STDOUT, 2003 ) - READ ( STDIN, '( A1 )' ) CHOICE - IF ( UPPER( CHOICE ) .EQ. 'Y' ) GO TO 711 -C -C Get the fixed number of constraints -C - IF ( TARGET(1)(VARM:VARM) .EQ. 'F' ) THEN - 741 CONTINUE - NUM = 0 - DO 770 I = 1, MAXTRG - WRITE( STDOUT, 1020 ) - 750 CONTINUE - IF ( NUM .EQ. 0) WRITE( STDOUT, 1121 ) - IF ( NUM .GT. 0) WRITE( STDOUT, 1021 ) - READ ( STDIN , FMT = '( A80 )', ERR = 760 ) LINE - CHOICE = UPPER( LINE(1:1) ) - IF ( NUM .EQ. 0 ) ANYFNC = - 1 CHOICE .EQ. '*' .OR. CHOICE .EQ. ' ' - IF ( NUM .NE. 0 ) ANYFNC = CHOICE .EQ. '*' - IF ( CHOICE .EQ. ' ' .OR. ANYFNC ) GO TO 795 - NCON(I) = CONVERT( LINE(1:5) ) - IF ( I .GT. 1 ) THEN - IM1 = I - 1 - DO 755 J = 1, IM1 - IF ( NCON(J) .EQ. NCON(I) ) GO TO 765 - 755 CONTINUE - ENDIF - IF ( NCON(I) .LT. 0 .OR. NCON(I) .GT. 99999999 ) GO TO 760 - NUM = NUM + 1 - GO TO 770 - 760 CONTINUE - WRITE ( STDOUT, 1001 ) - GO TO 750 - 765 CONTINUE - WRITE ( STDOUT, 1101 ) - GO TO 750 - 770 CONTINUE -C -C Verify the number of constraints -C - 795 CONTINUE - IF ( ANYFNC ) THEN - WRITE ( STDOUT, 2022 ) - ELSE - IF ( NUM .EQ. 0 ) THEN - WRITE ( STDOUT, 2120 ) - GO TO 741 - ELSE - WRITE ( STDOUT, 2012 ) ( NCON(K), K = 1, NUM ) - ENDIF - ENDIF - WRITE ( STDOUT, 2003 ) - READ ( STDIN, '( A1 )' ) CHOICE - IF ( UPPER( CHOICE ) .EQ. 'Y' ) GO TO 741 -C -C Get an interval for the number of constraints -C a) lower bound -C - ELSE IF ( TARGET(1)(VARM:VARM) .EQ. 'I' ) THEN - 900 CONTINUE - LM = 0 - UM = 99999999 - WRITE ( STDOUT, 6003 ) - 901 CONTINUE - WRITE ( STDOUT, 6004 ) - READ ( STDIN, '( A80 ) ', ERR = 902 ) LINE - CHOICE = UPPER( LINE(1:1) ) - IF ( CHOICE .NE. ' ' ) THEN - LM = CONVERT( LINE(1:5) ) - IF ( LM .LT. 0 .OR. LM. GT. 99999999 ) GO TO 902 - ENDIF - GO TO 905 - 902 CONTINUE - WRITE ( STDOUT, 1001 ) - GO TO 901 -C -C b) upper bound -C - 905 CONTINUE - WRITE ( STDOUT, 6005 ) - 903 CONTINUE - WRITE ( STDOUT, 6006 ) - READ ( STDIN, '( A80 ) ', ERR = 904 ) LINE - CHOICE = UPPER( LINE(1:1) ) - IF ( CHOICE .NE. ' ' ) THEN - UM = CONVERT( LINE(1:5) ) - IF ( UM .LT. 0 .OR. UM. GT. 99999999 .OR. LM. GT. UM ) - 1 GO TO 904 - ENDIF - GO TO 906 - 904 CONTINUE - WRITE ( STDOUT, 1001 ) - GO TO 903 -C -C Verify the bounds on the number of constraints -C - 906 CONTINUE - WRITE ( STDOUT, 6007 ) LM, UM - WRITE ( STDOUT, 2003 ) - READ ( STDIN, '( A1 )' ) CHOICE - IF ( UPPER( CHOICE ) .EQ. 'Y' ) GO TO 900 - ENDIF -C -C All characteristics have been recorded. Quit -C - ELSE IF ( CHAR .EQ. ' ' ) THEN - GO TO 7 -C -C Error in the choice of characteristic -C - ELSE - GO TO 2 - ENDIF -C -C Loop for another characteristic -C - CLOSE ( CLSDVC ) - GO TO 5 -C -C Handle the error in characteristic choice -C - 2 CONTINUE - WRITE ( STDOUT, 1001 ) - GO TO 6 -C -C The target(s) are now defined. -C - 7 CONTINUE - WRITE (STDOUT, 4001 ) -C -C Loop on the problem classification and print names of matching ones -C in lots of 5. Also accumulate the number of matching problems found. -C - NMATCH = 0 - L = 0 - 3000 CONTINUE - READ ( CLSDVC, '( A36 )', END = 3010 ) PBCLS - IF ( MATCH( PBCLS(10:36), TARGET, MAXTRG, ANYFNV, ANYFNC, - 1 NVAR, NCON, LN, UN, LM, UM ) ) THEN - NMATCH = NMATCH + 1 - L = L + 1 - LIST(L) = PBCLS(1:8) - IF ( L .EQ. 5 ) THEN - WRITE ( STDOUT, 4002 ) ( LIST(I), I = 1, 5 ) - L = 0 - ENDIF - ENDIF - GO TO 3000 -C -C End of the database processing for the main loop. -C -C Print selected problem names still -C in waiting list for output. -C - 3010 CONTINUE - IF ( L .GE. 1 ) WRITE ( STDOUT, 4002 ) ( LIST(I), I = 1, L ) - WRITE ( STDOUT, 4000 ) NMATCH - CLOSE ( CLSDVC ) - WRITE ( STDOUT, 7001 ) - READ ( STDIN, '( A1 )' ) CHOICE - IF ( UPPER( CHOICE ) .EQ. 'Y' ) THEN - OPEN( UNIT = CLSDVC, FILE = FILEN, STATUS = 'OLD' ) - WRITE ( STDOUT, 4955 ) - READ ( STDIN , FMT = '( A )' ) FILES - SIZE = LEN( FILES ) - OPEN( UNIT = FLSDVC, FILE = FILES, STATUS = 'UNKNOWN' ) - 3020 CONTINUE - READ ( CLSDVC, '( A36 )', END = 3050 ) PBCLS - IF ( MATCH( PBCLS(10:36), TARGET, MAXTRG, ANYFNV, ANYFNC, - 1 NVAR, NCON, LN, UN, LM, UM ) ) THEN - NBLK = 8 - DO 3030 NBLK = 8, 2, -1 - IF ( PBCLS(NBLK:NBLK) .NE. ' ' ) GO TO 3040 - 3030 CONTINUE - 3040 CONTINUE - WRITE ( FLSDVC, '(A)' ) PBCLS(1:NBLK) - ENDIF - GO TO 3020 - 3050 CONTINUE - CLOSE ( FLSDVC ) - CLOSE ( CLSDVC ) - ENDIF - WRITE ( STDOUT, 7000 ) - READ ( STDIN, '( A1 )' ) CHOICE - IF ( UPPER( CHOICE ) .EQ. 'Y' ) GO TO 1 -C -C End of the database processing. -C - STOP -C -C Non excutable statements -C - 1000 FORMAT( /' *************************************************' - 1 /' * *' - 1 /' * Constrained and Unconstrained *' - 1 /' * Testing Environment *' - 1 /' * *' - 1 /' * ( CUTEst ) *' - 1 /' * *' - 1 /' * interactive problem selection *' - 1 /' * *' - 1 /' * CGT/GOR productions 1992,2013 *' - 1 /' * *' - 1 /' *************************************************' - 1 / ) - 1101 FORMAT( ' *** THIS SELECTION IS REPETITION. Please choose ', - 1 'again.' - 1 / ) - 1201 FORMAT( ' *** YOU USED MORE THAN 32 CHARACTERS. Please choose', - 1 ' again.' - 1 / ) - 1001 FORMAT( ' *** YOUR ANSWER IS NOT ALLOWED. Please choose again.' - 1 / ) - 4950 FORMAT( /' Your current classification file is : ', - 1 A ) - 4957 FORMAT( /' Do you wish to change this [ = N] ?', - 1 ' (N/Y)') - 4955 FORMAT( ' Input the filename you want (up to 32 characters): ') - 5000 FORMAT( /' CHOOSE A PROBLEM CHARACTERISTIC THAT YOU WANT', - 1 ' TO SPECIFY :' - 1 /' ---------------------------------------------', - 1 '-------------' ) - 5001 FORMAT( /' O : Objective type C : Constraint', - 1 ' type' - 1 /' R : Regularity I : Problem', - 1 ' interest' - 1 /' N : Number of variables M : Number of', - 1 ' constraints' - 1 /' D : Degree of available analytic derivatives' - 1 /' S : Presence of explicit internal variables' - 1 /' : No further characteristic, perform', - 1 ' selection' - 1 /' ' - 1 /' Your choice :' ) - 5002 FORMAT( /' Your current problem selection key is:' - 1 /' ( * = anything goes )' ) - 5003 FORMAT( /' Objective function type : ', - 1 10 ( A1, 1X ) ) - 5004 FORMAT( ' Constraints type : ', - 1 10 ( A1, 1X ) ) - 5005 FORMAT( ' Regularity : ', - 1 10 ( A1, 1X ) ) - 5006 FORMAT( ' Degree of available derivatives : ', - 1 10 ( A1, 1X ) ) - 5007 FORMAT( ' Problem interest : ', - 1 10 ( A1, 1X ) ) - 5008 FORMAT( ' Explicit internal variables : ', - 1 10 ( A1, 1X ) ) - 5009 FORMAT( ' Number of variables : v' ) - 5010 FORMAT( ' Number of variables : *' ) - 5011 FORMAT( ' Number of variables : any fixed number - 1 ') - 5012 FORMAT( ' Number of variables : ', - 1 10 ( I5, 1X ) ) - 5013 FORMAT( ' Number of constraints : v' ) - 5014 FORMAT( ' Number of constraints : *' ) - 5015 FORMAT( ' Number of constraints : any fixed number - 1 ') - 5016 FORMAT( ' Number of constraints : ', - 1 10 ( I5, 1X ) ) - 1002 FORMAT( /' OBJECTIVE FUNCTION TYPE :' - 1 /' -------------------------' ) - 1103 FORMAT( /' C : Constant L : Linear' - 1 /' Q : Quadratic S : Sum of squares' - 1 /' N : No objective' - 1 /' O : Other (that is none of the above)' - 1 /' : Any of the above (*)' - 1 /' ' - 1 /' Your choice :' ) - 1003 FORMAT( /' C : Constant L : Linear' - 1 /' Q : Quadratic S : Sum of squares' - 1 /' N : No objective' - 1 /' O : Other (that is none of the above)' - 1 /' : No further type' - 1 /' ' - 1 /' Your choice :' ) - 1004 FORMAT( /' CONSTRAINTS TYPE :' - 1 /' ------------------' ) - 1105 FORMAT( /' U : No constraint X : Fixed variables', - 1 ' only' - 1 /' B : Bounds only N : Linear network' - 1 /' L : Linear Q : Quadratic' - 1 /' O : Other (that is more general than any of the', - 1 ' above alone)' - 1 /' : Any of the above (*)' - 1 /' ' - 1 /' Your choice :' ) - 1005 FORMAT( /' U : No constraint X : Fixed variables', - 1 ' only' - 1 /' B : Bounds only N : Linear network' - 1 /' L : Linear Q : Quadratic' - 1 /' O : Other (that is more general than any of the', - 1 ' above alone)' - 1 /' : No further type' - 1 /' ' - 1 /' Your choice :' ) - 1006 FORMAT( /' PROBLEM REGULARITY TYPE :' - 1 /' -------------------------' ) - 1007 FORMAT( /' R : Twice continuously differentiable' - 1 /' I : Other' - 1 /' : Any of the above (*)' - 1 /' ' - 1 /' Your choice :' ) - 1008 FORMAT( /' DEGREE OF AVAILABLE ANALYTICAL DERIVATIVES :' - 1 /' --------------------------------------------' ) - 1109 FORMAT( /' 0 : No analytical der. 1 : Analytical first' - 1 /' 2 : Analytical second' - 1 /' : Any of the above (*)' - 1 /' ' - 1 /' Your choice :' ) - 1009 FORMAT( /' 0 : No analytical der. 1 : Analytical first' - 1 /' 2 : Analytical second' - 1 /' : No further degree' - 1 /' ' - 1 /' Your choice :' ) - 1010 FORMAT( /' PROBLEM INTEREST TYPE :' - 1 /' -----------------------' ) - 1111 FORMAT( /' A : Academic R : Real application' - 1 /' M : Modelling' - 1 /' : Any of the above (*)' - 1 /' ' - 1 /' Your choice :' ) - 1011 FORMAT( /' A : Academic R : Real application' - 1 /' M : Modelling' - 1 /' : No further type' - 1 /' ' - 1 /' Your choice :' ) - 1012 FORMAT( /' PRESENCE OF EXPLICIT INTERNAL VARIABLES :' - 1 /' -----------------------------------------' ) - 1013 FORMAT( /' Y : Yes N : No' - 1 /' : Any of the above (*)' - 1 /' ' - 1 /' Your choice :' ) - 1014 FORMAT( /' NUMBER OF VARIABLES :' - 1 /' ---------------------' ) - 1015 FORMAT( /' F : Fixed V : Variable' - 1 /' I : In an interval' - 1 /' : Any number of variables (*)' - 1 /' ' - 1 /' Your choice :' ) - 1016 FORMAT( /' NUMBER OF CONSTRAINTS :' - 1 /' -----------------------' ) - 1017 FORMAT( /' F : Fixed V : Variable' - 1 /' I : In an interval' - 1 /' : Any number of constraints (*)' - 1 /' ' - 1 /' Your choice :' ) - 1018 FORMAT( /' SELECT A NUMBER OF VARIABLES:' - 1 /' -----------------------------' ) - 1119 FORMAT( /' (INT) : Select only problems with (INT) variables' - 1 /' (minimum 0, maximum 99999999, multiple ', - 1 'choices are allowed)' - 1 /' : Any fixed number of variables (*)' - 1 /' ' - 1 /' Your choice :' ) - 1019 FORMAT( /' (INT) : Select only problems with (INT) variables' - 1 /' (minimum 0, maximum 99999999, multiple ', - 1 'choices are allowed)' - 1 /' * : Any fixed number of variables' - 1 /' : No further selection', - 1 /' ' - 1 /' Your choice :' ) - 1020 FORMAT( /' SELECT A NUMBER OF CONSTRAINTS:' - 1 /' -------------------------------' ) - 1121 FORMAT( /' (INT) : Select only problems with (INT) constraints' - 1 /' (minimum 0, maximum 99999999, multiple ', - 1 'choices are allowed)' - 1 /' : Any fixed number of variables (*)' - 1 /' ' - 1 /' Your choice :' ) - 1021 FORMAT( /' (INT) : Select only problems with (INT) constraints' - 1 /' (minimum 0, maximum 99999999, multiple ', - 1 'choices are allowed)' - 1 /' * : Any fixed number of variables ' - 1 /' : No further selection', - 1 /' ' - 1 /' Your choice :' ) - 2002 FORMAT( /' You have specified objective of type(s): ', - 1 10( A1, 1X ) ) - 2102 FORMAT( /' *** Please choose an objective function type.' ) - 2003 FORMAT( ' Do you wish to reconsider your choice [ = N] ?', - 1 ' (N/Y)') - 2004 FORMAT( /' You have specified constraints of type(s): ', - 1 10( A1, 1X ) ) - 2104 FORMAT( /' *** Please choose a constraint type.' ) - 2005 FORMAT( /' You have specified regularity of type: ', A1 ) - 2006 FORMAT( /' You have specified derivatives of degree: ', - 1 10( A1, 1X ) ) - 2106 FORMAT(/' *** Please choose a degree of available derivatives.') - 2007 FORMAT( /' You have specified problem interest of type: ', - 1 10( A1, 1X ) ) - 2107 FORMAT( /' *** Please choose a problem interest type.' ) - 2008 FORMAT( /' You have specified problems with explicit', - 1 ' internal variables.' ) - 2018 FORMAT( /' You have specified problems without explicit', - 1 ' internal variables.' ) - 2017 FORMAT( /' You have specified problems with or without', - 1 ' explicit internal variables.' ) - 2009 FORMAT( /' You have specified a fixed number of variables.' ) - 2019 FORMAT( /' You have specified a variable number of variables.' ) - 2029 FORMAT( /' You have specified any number of variables.' ) - 2010 FORMAT( /' You have specified a number of variables', - 1 ' in the set: ', - 1 /' ', 10( I5, 1X ) ) - 2020 FORMAT( /' You have specified any fixed number of variables.' ) - 2110 FORMAT( /' *** Please choose a number of variables.' ) - 2011 FORMAT( /' You have specified a fixed number of constraints.' ) - 2021 FORMAT(/' You have specified a variable number of constraints.') - 2031 FORMAT( /' You have specified any number of constraints.' ) - 2012 FORMAT( /' You have specified a number of constraints', - 1 ' in the set: ', - 1 /' ', 10( I5, 1X ) ) - 2022 FORMAT( /' You have specified any fixed number of constraints.') - 2120 FORMAT( /' *** Please choose a number of constraints.' ) - 4000 FORMAT( /' ', I5, ' Problem(s) match(es) the specification.' / ) - 4001 FORMAT( /' MATCHING PROBLEMS :' - 1 /' -------------------' / ) - 4002 FORMAT( ' ', 5( A8, 3X ) ) - 4003 FORMAT( /' LOWER BOUND ON THE NUMBER OF VARIABLES :' - 1 /' ----------------------------------------' ) - 4004 FORMAT( /' (INT) : Problems with at least (INT) variables' - 1 /' : No lower bound on the number of variables' - 1 /' ' - 1 /' Your choice : ' ) - 4005 FORMAT( /' UPPER BOUND ON THE NUMBER OF VARIABLES :' - 1 /' ----------------------------------------' ) - 4006 FORMAT( /' (INT) : Problems with at most (INT) variables' - 1 /' : No upper bound on the number of variables' - 1 /' ' - 1 /' Your choice : ' ) - 4007 FORMAT( /' You have specified a number of variables in [ ', - 1 I5,', ',I5,' ]' ) - 4008 FORMAT( ' Number of variables : in [ ', - 1 I5,', ',I5,' ]' ) - 4009 FORMAT( /' You have specified an interval for the number of', - 1 ' variables.' ) - 6003 FORMAT( /' LOWER BOUND ON THE NUMBER OF CONSTRAINTS :' - 1 /' -----------------------------------------' ) - 6004 FORMAT( /' (INT) : Problems with at least (INT) constraints' - 1 /' : No lower bound on the number of constraints' - 1 /' ' - 1 /' Your choice : ' ) - 6005 FORMAT( /' UPPER BOUND ON THE NUMBER OF CONSTRAINTS :' - 1 /' -----------------------------------------' ) - 6006 FORMAT( /' (INT) : Problems with at most (INT) constraints' - 1 /' : No upper bound on the number of constraints' - 1 /' ' - 1 /' Your choice : ' ) - 6007 FORMAT( /' You have specified a number of constraints in [ ', - 1 I5,', ',I5,' ]' ) - 6008 FORMAT( ' Number of constraints : in [ ', - 1 I5,', ',I5,' ]' ) - 6009 FORMAT( /' You have specified an interval for the number of', - 1 ' constraints.' ) -C Added by Kristjan Jonasson. - 7001 FORMAT( /' Do you wish to save the problem names to a file', - 1 ' [ = N] ? (N/Y)') - 7000 FORMAT( /' Do you wish to make another selection [ = N] ?', - 1 ' (N/Y)') - 8000 FORMAT( A256 ) - END -C -C----------------------------------------------------------------------------- -C - LOGICAL FUNCTION REJECT( CHOICE, ITEM, NUM) -C -C----------------------------------------------------------------------------- -C -C The purpose of this function is to verify if the character CHOICE -C is a valid specification for item ITEM, where ITEM is one of -C 1 = objective type, -C 2 = constraints type, -C 3 = problem regularity, -C 4 = degree of available derivatives, -C 5 = problem interest, -C 6 = presence of explicit internal variables, -C 7 = number of variables, -C 8 = number of constraints. -C -C Programming: A. R. Conn and Ph. Toint for CGT Productions. -C -C----------------------------------------------------------------------------- -C -C -C Classification constants -C - INTEGER OBJ, CON, REG, DER, INTRST, INTVAR, VARN, VARM - PARAMETER ( OBJ = 1, CON = 2, REG = 3, DER = 4, INTRST = 5, - 1 INTVAR = 6, VARN = 7, VARM = 8 ) -C -C Arguments -C - CHARACTER*1 CHOICE - INTEGER ITEM, NUM -C -C Other variables -C - LOGICAL ADMIT -C -C Control choices -C - IF ( ( CHOICE .EQ. ' ' .OR. CHOICE .EQ. '*' ) - 1 .AND. NUM .EQ. 0 ) THEN - CHOICE = '*' - REJECT = .FALSE. - RETURN -C -C Objective function type -C - ELSE IF ( ITEM .EQ. OBJ ) THEN - ADMIT = CHOICE .EQ. 'N' .OR. CHOICE .EQ. 'C' .OR. - 1 CHOICE .EQ. 'L' .OR. CHOICE .EQ. 'Q' .OR. - 1 CHOICE .EQ. 'S' .OR. CHOICE .EQ. 'O' .OR. - 1 CHOICE .EQ. ' ' -C -C Constraint type -C - ELSE IF ( ITEM .EQ. CON ) THEN - ADMIT = CHOICE .EQ. 'U' .OR. CHOICE .EQ. 'B' .OR. - 1 CHOICE .EQ. 'N' .OR. CHOICE .EQ. 'L' .OR. - 1 CHOICE .EQ. 'Q' .OR. CHOICE .EQ. 'O' .OR. - 1 CHOICE .EQ. 'X' .OR. CHOICE .EQ. ' ' -C -C Problem regularity -C - ELSE IF ( ITEM .EQ. REG ) THEN - ADMIT = CHOICE .EQ. 'R' .OR. CHOICE .EQ. 'I' -C -C Degree of analytical derivatives -C - ELSE IF ( ITEM .EQ. DER ) THEN - ADMIT = CHOICE .EQ. '0' .OR. CHOICE .EQ. '1' .OR. - 1 CHOICE .EQ. '2' .OR. CHOICE .EQ. ' ' -C -C Problem interest -C - ELSE IF ( ITEM .EQ. INTRST ) THEN - ADMIT = CHOICE .EQ. 'A' .OR. CHOICE .EQ. 'R' .OR. - 1 CHOICE .EQ. 'M' .OR. CHOICE .EQ. ' ' -C -C Presence of explicit internal variables -C - ELSE IF ( ITEM .EQ. INTVAR ) THEN - ADMIT = CHOICE .EQ. 'Y' .OR. CHOICE .EQ. 'N' -C -C Number of variables and constraints -C - ELSE IF ( ITEM .EQ. VARN .OR. ITEM .EQ. VARM ) THEN - ADMIT = CHOICE .EQ. 'F' .OR. CHOICE .EQ. 'V' .OR. - 1 CHOICE .EQ. 'I' - ENDIF - REJECT = .NOT. ADMIT - RETURN - END -C -C----------------------------------------------------------------------------- -C - LOGICAL FUNCTION MATCH ( C, T, MAXTRG, ANYFNV, ANYFNC, NV, NC, - 1 LN, UN, LM, UM ) -C -C----------------------------------------------------------------------------- -C -C The purpose of this function is to check if the classification C -C matches one of the targets specified by T, ANYFNV, ANYFNC, NV, NC, LN -C UN, LM and UM. -C -C Programming: Ph. Toint, Dec 1991, for CGT Productions. -C -C----------------------------------------------------------------------------- -C -C Arguments -C - LOGICAL ANYFNV, ANYFNC - INTEGER MAXTRG, LN, UN, LM, UM - CHARACTER*27 C - INTEGER NV( MAXTRG ), NC( MAXTRG ) - CHARACTER*8 T( MAXTRG ) -C -C Other variables -C - INTEGER I, J, CONVERT - CHARACTER*1 CH -C -C Match objective function type -C - MATCH = .FALSE. - DO 10 I = 1, MAXTRG - CH = T(I)(1:1) - IF ( CH .EQ. ' ' ) GO TO 20 - MATCH = MATCH .OR. CH .EQ. C(1:1) .OR. CH .EQ. '*' - 10 CONTINUE - 20 CONTINUE - IF ( .NOT. MATCH ) RETURN -C -C Match constraint type -C - MATCH = .FALSE. - DO 30 I = 1, MAXTRG - CH = T(I)(2:2) - IF ( CH .EQ. ' ' ) GO TO 40 - MATCH = MATCH .OR. CH .EQ. C(2:2) .OR. CH .EQ. '*' - 30 CONTINUE - 40 CONTINUE - IF ( .NOT. MATCH ) RETURN -C -C Match regularity type -C - CH = T(1)(3:3) - MATCH = CH .EQ. C(3:3) .OR. CH .EQ. '*' - IF ( .NOT. MATCH ) RETURN -C -C Match degree of available derivatives -C - MATCH = .FALSE. - DO 50 I = 1, MAXTRG - CH = T(I)(4:4) - IF ( CH .EQ. ' ' ) GO TO 60 - MATCH = MATCH .OR. CH .EQ. C(4:4) .OR. CH .EQ. '*' - 50 CONTINUE - 60 CONTINUE - IF ( .NOT. MATCH ) RETURN -C -C Match interest of the problem -C - MATCH = .FALSE. - DO 70 I = 1, MAXTRG - CH = T(I)(5:5) - IF ( CH .EQ. ' ' ) GO TO 80 - MATCH = MATCH .OR. CH .EQ. C(6:6) .OR. CH .EQ. '*' - 70 CONTINUE - 80 CONTINUE - IF ( .NOT. MATCH ) RETURN -C -C Match for explicit internal variables -C - CH = T(1)(6:6) - MATCH = CH .EQ. C(7:7) .OR. CH .EQ. '*' - IF ( .NOT. MATCH ) RETURN -C -C Match the number of variables -C - MATCH = .FALSE. - CH = T(1)(7:7) - IF ( CH .EQ. '*' ) THEN - MATCH = .TRUE. - ELSE IF ( CH .EQ. 'V' ) THEN - MATCH = C(13:13) .EQ. 'V' - ELSE IF ( CH .EQ. 'I' ) THEN -C interval. A variable number of variables is no longer considered to -C match a number in an interval. - IF ( C(17:17) .NE. 'V' ) THEN - I = CONVERT( C(9:17) ) - MATCH = I. GE. LN .AND. I .LE. UN - ENDIF - ELSE - IF ( ANYFNV ) THEN - MATCH = .TRUE. - ELSE -C A variable number of variables is no longer considered to match a fixed -C number. - IF ( C(17:17) .NE. 'V' ) THEN - J = CONVERT( C(9:17) ) - DO 90 I = 1, MAXTRG - IF ( NV(I) .LT. 0 ) GO TO 90 - MATCH = NV(I) .EQ. J - IF ( MATCH ) GO TO 100 - 90 CONTINUE - 100 CONTINUE - ENDIF - ENDIF - ENDIF - IF ( .NOT. MATCH ) RETURN -C -C Match the number of constraints -C - MATCH = .FALSE. - CH = T(1)(8:8) - IF ( CH .EQ. '*' ) THEN - MATCH = .TRUE. - ELSE IF ( CH .EQ. 'V' ) THEN - MATCH = C(27:27) .EQ. 'V' - ELSE IF ( CH .EQ. 'I' ) THEN -C interval. A variable number of constraints is no longer considered to -C match a number in an interval. - IF ( C(19:19) .NE. 'V' ) THEN - I = CONVERT( C(19:27) ) - MATCH = I. GE. LM .AND. I .LE. UM - ENDIF - ELSE - IF ( ANYFNC ) THEN - MATCH = .TRUE. - ELSE -C A variable number of constraints is no longer considered to match a fixed -C number. - IF ( C(27:27) .NE. 'V' ) THEN - J = CONVERT( C(19:27) ) - DO 110 I = 1, MAXTRG - IF ( NC(I) .LT. 0 ) GO TO 110 - MATCH = NC(I) .EQ. J - IF ( MATCH ) GO TO 120 - 110 CONTINUE - 120 CONTINUE - ENDIF - ENDIF - ENDIF - RETURN - END -C -C----------------------------------------------------------------------------- -C - INTEGER FUNCTION CONVERT( LINE ) -C -C----------------------------------------------------------------------------- -C -C The purpose of this function is to convert the nonnegative integer contained -C in the first 5 characters of the string LINE into a proper integer. -C -1 is returned in case of error. -C -C Programming: Ph. Toint, Dec 1991, for CGT Productions. -C -C----------------------------------------------------------------------------- -C -C Arguments -C - CHARACTER*5 LINE -C -C Other variables -C - INTEGER L -C -C Remove trailing blanks -C - DO 10 L= 5, 1, -1 - IF ( LINE(L:L) .NE. ' ' ) GO TO 20 - 10 CONTINUE - GO TO 30 -C -C Read the integer -C - 20 CONTINUE - IF ( L .EQ. 1 ) THEN - READ ( LINE(1:1), '( I1 )', ERR = 30 ) CONVERT - ELSE IF ( L .EQ. 2 ) THEN - READ ( LINE(1:2), '( I2 )', ERR = 30 ) CONVERT - ELSE IF ( L .EQ. 3 ) THEN - READ ( LINE(1:3), '( I3 )', ERR = 30 ) CONVERT - ELSE IF ( L .EQ. 4 ) THEN - READ ( LINE(1:4), '( I4 )', ERR = 30 ) CONVERT - ELSE - READ ( LINE(1:5), '( I5 )', ERR = 30 ) CONVERT - ENDIF - RETURN -C -C Error -C - 30 CONTINUE - CONVERT = -1 - RETURN - END -C -C----------------------------------------------------------------------------- -C - INTEGER FUNCTION NBT ( I, T, MX ) -C -C----------------------------------------------------------------------------- -C -C The purpose of this function is to return the number of non trivial -C choices of item I specified in the target list T. -C -C Programming: Ph. Toint, Dec 1991, for CGT Productions. -C -C----------------------------------------------------------------------------- -C -C Arguments -C - INTEGER I, MX - CHARACTER*8 T( MX ) -C -C Other variables -C - INTEGER L -C - NBT = 1 - DO 10 L = 2, MX - IF ( T(L)(I:I) .EQ. 'X' ) RETURN - NBT = NBT + 1 - 10 CONTINUE - RETURN - END -C -C----------------------------------------------------------------------------- -C - INTEGER FUNCTION NBI ( N, MX ) -C -C----------------------------------------------------------------------------- -C -C The purpose of this function is to return the number of non trivial -C dimensions specified in the integer dimension vector N. -C -C Programming: Ph. Toint, Dec 1991, for CGT Productions. -C -C----------------------------------------------------------------------------- -C -C Arguments -C - INTEGER MX - INTEGER N( MX ) -C -C Other variables -C - INTEGER L -C - NBI = 0 - DO 10 L = 1, MX - IF ( N(L) .LT. 0 ) RETURN - NBI = NBI + 1 - 10 CONTINUE - RETURN - END -C -C----------------------------------------------------------------------------- -C - CHARACTER*1 FUNCTION UPPER( CH ) -C -C----------------------------------------------------------------------------- -C -C The purpose of this function is to transform the character CH -C to upper case, if it is not already. -C -C Programming: Ph. Toint, Dec 1991, for CGT Productions. -C -C----------------------------------------------------------------------------- -C - CHARACTER*1 CH -C - INTRINSIC ICHAR, CHAR -C - INTEGER ICH, LSTART -C - LSTART = ICHAR( 'a' ) - ICH = ICHAR( CH ) - IF ( ICH .GE. LSTART .AND. ICH .LE. ICHAR( 'z' ) ) THEN - UPPER = CHAR( ICHAR( 'A' ) + ICH - LSTART ) - ELSE - UPPER = CH - ENDIF - RETURN - END - -C -C----------------------------------------------------------------------------- -C diff --git a/src/select/slct_older.f b/src/select/slct_older.f deleted file mode 100644 index 18170c3..0000000 --- a/src/select/slct_older.f +++ /dev/null @@ -1,1434 +0,0 @@ -C ( Last modified on 14 Jan 2001 at 19:03:33 ) -C----------------------------------------------------------------------------- -C - PROGRAM SELECT -C -C----------------------------------------------------------------------------- -C -C The purpose of this program is to interrogate the file containing problem -C classifications (by default, $MASTSIF/CLASSF.DB) for obtaining a list -C of problems matching interactively defined characteristics. -C -C The dialog with the user is on the standard input/output. -C -C Programming: I. Bongartz, A.R. Conn and Ph. Toint for CGT Productions. -C Salford fortran by Kristjan Jonasson -C -C--------- THE FOLLOWING SPECIFICATIONS MAY BE MODIFIED BY THE USER ---------- -C -C Standard input default definition is device 5. Standard output default -C definition is device 6. Change them to whatever values are appropriate -C on your system. -C - INTEGER STDIN, STDOUT - PARAMETER ( STDIN = 5, STDOUT = 6 ) -C -C Name of the classification database -C - CHARACTER*32 NAME - PARAMETER ( NAME = 'CLASSF.DB' ) -C -C Device number for reading the classification database -C - INTEGER CLSDVC, FLSDVC - PARAMETER ( CLSDVC = 55, FLSDVC = 56 ) -C -C default directory for classification file. -C -C Device number and file name for file containing default directory -C - INTEGER DATDVC - PARAMETER ( DATDVC = 57 ) - CHARACTER*32 DATNAM - PARAMETER ( DATNAM = 'SLCT.DAT' ) -C -C---------------- END OF THE USER MODIFIABLE SPECIFICATION ------------------ -C -C Classification constants -C - INTEGER OBJ, CON, REG, DER, INTRST, INTVAR, VARN, VARM - PARAMETER ( OBJ = 1, CON = 2, REG = 3, DER = 4, INTRST = 5, - * INTVAR = 6, VARN = 7, VARM = 8 ) -C -C Maximum number of simultaneous targets in search -C - INTEGER MAXTRG - PARAMETER ( MAXTRG = 7 ) -C -C Variable definitions -C - CHARACTER*80 LINE -C names for classification file - CHARACTER*72 FILEN -C default directory for classification file - CHARACTER*256 DFTDIR -C names for output listing file -C Addition by Kristjan Jonasson - CHARACTER*72 FILES - CHARACTER*28 PBCLS - CHARACTER*8 TARGET( MAXTRG ), LIST(5) - CHARACTER*1 CHOICE, CHAR, UPPER - INTEGER I, IM1, J, NVAR( MAXTRG ), NCON( MAXTRG ), L, K, NUM, - * NMATCH, CONVERT, NBT, NBI, LN, UN, LM, SIZE, UM - LOGICAL REJECT, ANYFNV, ANYFNC, MATCH - INTRINSIC MIN -C -C Banner -C - WRITE ( STDOUT, 1000 ) -C -C in order that this program can give the full path name for the -C default classification file. -C -C Open the file containing the default directory name. -C - OPEN ( UNIT = DATDVC, FILE = DATNAM, STATUS = 'OLD' ) -C -C Read in the default directory -C - READ ( DATDVC, 8000 ) DFTDIR - CLOSE ( DATDVC ) - DO 910 I = 1, 256 - IF ( DFTDIR( I : I ) .EQ. ' ' ) THEN - SIZE = I - 1 - GO TO 920 - END IF - 910 CONTINUE - SIZE = 256 - 920 CONTINUE - FILEN = DFTDIR( 1 : SIZE ) // '/' // NAME - SIZE = LEN( FILEN ) -C -C MAIN LOOP -C - 1 CONTINUE -C -C Target initialization -C - DO 4 I = 1, MAXTRG - NVAR(I) = -2 - NCON(I) = -2 - TARGET(I) = 'XXXXXXXX' - 4 CONTINUE - TARGET(1) = '********' - ANYFNV = .FALSE. - ANYFNC = .FALSE. -C -C Bounds on the number of variables and constraints are initialized -C to be inactive. -C - LN = 0 - LM = 0 - UN = 99999999 - UM = 99999999 -C -C Verify the name of the classification database file -C - 77 CONTINUE - WRITE ( STDOUT, 4950 ) FILEN(1:SIZE) - WRITE ( STDOUT, 4957 ) - READ ( STDIN, '( A1 )' ) CHOICE - IF ( UPPER( CHOICE ) .EQ. 'Y' ) THEN - WRITE ( STDOUT, 4955 ) - READ ( STDIN , FMT = '( A )', ERR = 78 ) FILEN - SIZE = LEN( FILEN ) - GO TO 77 - 78 WRITE ( STDOUT, 1201 ) - GO TO 77 - ENDIF -C -C Writes the current specification -C - 5 CONTINUE - WRITE ( STDOUT, 5002 ) - NUM = NBT ( OBJ, TARGET, MAXTRG ) - WRITE ( STDOUT, 5003 ) ( TARGET(L)(OBJ:OBJ), L = 1, NUM ) - NUM = NBT ( CON, TARGET, MAXTRG ) - WRITE ( STDOUT, 5004 ) ( TARGET(L)(CON:CON), L = 1, NUM ) - WRITE ( STDOUT, 5005 ) TARGET(1)(REG:REG) - NUM = NBT ( DER, TARGET, MAXTRG ) - WRITE ( STDOUT, 5006 ) ( TARGET(L)(DER:DER), L = 1, NUM ) - NUM = NBT ( INTRST, TARGET, MAXTRG ) - WRITE ( STDOUT, 5007 ) ( TARGET(L)(INTRST:INTRST), L = 1, NUM ) - WRITE ( STDOUT, 5008 ) TARGET(1)(INTVAR:INTVAR) - IF ( TARGET(1)(VARN:VARN) .EQ. 'V' ) THEN - WRITE ( STDOUT, 5009 ) - ELSE IF ( TARGET(1)(VARN:VARN) .EQ. '*' ) THEN - WRITE ( STDOUT, 5010 ) - ELSE IF ( TARGET(1)(VARN:VARN) .EQ. 'I' ) THEN - WRITE ( STDOUT, 4008 ) LN, UN - ELSE - IF ( ANYFNV ) THEN - WRITE ( STDOUT, 5011 ) - ELSE - NUM = NBI ( NVAR, MAXTRG ) - WRITE ( STDOUT, 5012 ) ( NVAR(L), l = 1, NUM ) - ENDIF - ENDIF - IF ( TARGET(1)(VARM:VARM) .EQ. 'V' ) THEN - WRITE ( STDOUT, 5013 ) - ELSE IF ( TARGET(1)(VARM:VARM) .EQ. '*' ) THEN - WRITE ( STDOUT, 5014 ) - ELSE IF ( TARGET(1)(VARM:VARM) .EQ. 'I' ) THEN - WRITE ( STDOUT, 6008 ) LM, UM - ELSE - IF ( ANYFNV ) THEN - WRITE ( STDOUT, 5015 ) - ELSE - NUM = NBI ( NCON, MAXTRG ) - WRITE ( STDOUT, 5016 ) ( NCON(L), l = 1, NUM ) - ENDIF - ENDIF -C -C Open the classification file. -C - OPEN( UNIT = CLSDVC, FILE = FILEN, STATUS = 'OLD' ) -C -C Read in the problem characteristic one wishes to specify -C - WRITE ( STDOUT, 5000 ) - 6 CONTINUE - WRITE ( STDOUT, 5001 ) - READ ( STDIN, '( A1 )', ERR = 2 ) CHAR - CHAR = UPPER( CHAR ) -C -C Get objective function target types -C - IF ( CHAR .EQ. 'O' ) THEN - 41 CONTINUE - NUM = 0 - WRITE ( STDOUT, 1002 ) - DO 30 I = 1, MIN( MAXTRG, 6 ) - 10 CONTINUE - IF ( NUM .EQ. 0) WRITE ( STDOUT, 1103 ) - IF ( NUM .GT. 0) WRITE ( STDOUT, 1003 ) - READ ( STDIN , FMT = '( A1 )', ERR = 20 ) CHOICE - CHOICE = UPPER( CHOICE ) - IF ( REJECT( CHOICE, OBJ, NUM ) ) GO TO 20 - IF ( I .GT. 1 ) THEN - IM1 = I - 1 - DO 35 J = 1, IM1 - IF ( TARGET(J)(OBJ:OBJ) .EQ. CHOICE ) GO TO 25 - 35 CONTINUE - ENDIF - TARGET(I)(OBJ:OBJ) = CHOICE - IF ( CHOICE .NE. ' ' ) NUM = NUM + 1 - IF ( CHOICE .EQ. ' ' .OR. CHOICE .EQ. '*' ) GO TO 40 - GO TO 30 - 20 CONTINUE - WRITE ( STDOUT, 1001 ) - GO TO 10 - 25 CONTINUE - WRITE ( STDOUT, 1101 ) - GO TO 10 - 30 CONTINUE -C -C Verify the type of objective function -C - 40 CONTINUE - IF ( NUM .EQ. 0 ) THEN - WRITE ( STDOUT, 2102 ) - GO TO 41 - ELSE - WRITE ( STDOUT, 2002 ) ( TARGET(K)(OBJ:OBJ), K = 1, NUM ) - ENDIF - WRITE ( STDOUT, 2003 ) - READ ( STDIN, '( A1 )' ) CHOICE - IF ( UPPER( CHOICE ) .EQ. 'Y' ) GO TO 41 -C -C Get constraints target types -C - ELSE IF ( CHAR .EQ. 'C' ) THEN - 111 CONTINUE - NUM = 0 - WRITE ( STDOUT, 1004 ) - DO 130 I = 1, MIN( MAXTRG, 6 ) - 110 CONTINUE - IF ( NUM .EQ. 0) WRITE ( STDOUT, 1105 ) - IF ( NUM .GT. 0) WRITE ( STDOUT, 1005 ) - READ ( STDIN , FMT = '( A1 )', ERR = 120 ) CHOICE - CHOICE = UPPER( CHOICE ) - IF ( REJECT( CHOICE, CON, NUM ) ) GO TO 120 - IF ( I .GT. 1 ) THEN - IM1 = I - 1 - DO 135 J = 1, IM1 - IF ( TARGET(J)(CON:CON) .EQ. CHOICE ) GO TO 125 - 135 CONTINUE - ENDIF - TARGET(I)(CON:CON) = CHOICE - IF ( CHOICE .NE. ' ' ) NUM = NUM + 1 - IF ( CHOICE .EQ. ' ' .OR. CHOICE .EQ. '*' ) GO TO 140 - GO TO 130 - 120 CONTINUE - WRITE ( STDOUT, 1001 ) - GO TO 110 - 125 CONTINUE - WRITE ( STDOUT, 1101 ) - GO TO 110 - 130 CONTINUE -C -C Verify the type of constraints -C - 140 CONTINUE - IF ( NUM .EQ. 0 ) THEN - WRITE ( STDOUT, 2104 ) - GO TO 111 - ELSE - WRITE ( STDOUT, 2004 ) ( TARGET(K)(CON:CON), K = 1, NUM ) - ENDIF - WRITE ( STDOUT, 2003 ) - READ ( STDIN, '( A1 )' ) CHOICE - IF ( UPPER( CHOICE ) .EQ. 'Y' ) GO TO 111 -C -C Get regularity target types -C - ELSE IF ( CHAR .EQ. 'R' ) THEN - 211 CONTINUE - WRITE ( STDOUT, 1006 ) - 210 CONTINUE - WRITE ( STDOUT, 1007 ) - READ ( STDIN , FMT = '( A1 )', ERR = 220 ) CHOICE - CHOICE = UPPER( CHOICE ) - IF ( REJECT( CHOICE, REG, 0 ) ) GO TO 220 - TARGET(1)(REG:REG) = CHOICE - GO TO 240 - 220 CONTINUE - WRITE ( STDOUT, 1001 ) - GO TO 210 - 240 CONTINUE -C -C Verify the problem's regularity -C - WRITE ( STDOUT, 2005 ) TARGET(1)(REG:REG) - WRITE ( STDOUT, 2003 ) - READ ( STDIN, '( A1 )' ) CHOICE - IF ( UPPER( CHOICE ) .EQ. 'Y' ) GO TO 211 -C -C Get derivative degree -C - ELSE IF ( CHAR .EQ. 'D' ) THEN - 311 CONTINUE - NUM = 0 - WRITE ( STDOUT, 1008 ) - DO 330 I = 1, MIN( MAXTRG, 3 ) - 310 CONTINUE - IF ( NUM .EQ. 0 ) WRITE ( STDOUT, 1109 ) - IF ( NUM .GT. 0 ) WRITE ( STDOUT, 1009 ) - READ ( STDIN , '( A1 )', ERR = 320 ) CHOICE - CHOICE = UPPER( CHOICE ) - IF ( REJECT( CHOICE, DER, NUM ) ) GO TO 320 - IF ( I .GT. 1 ) THEN - IM1 = I - 1 - DO 335 J = 1, IM1 - IF ( TARGET(J)(DER:DER) .EQ. CHOICE ) GO TO 325 - 335 CONTINUE - ENDIF - TARGET(I)(DER:DER) = CHOICE - IF ( CHOICE .NE. ' ' ) NUM = NUM + 1 - IF ( CHOICE .EQ. ' ' .OR. CHOICE .EQ. '*' ) GO TO 340 - GO TO 330 - 320 CONTINUE - WRITE ( STDOUT, 1001 ) - GO TO 310 - 325 CONTINUE - WRITE ( STDOUT, 1101 ) - GO TO 310 - 330 CONTINUE -C -C Verify the degree of available derivatives -C - 340 CONTINUE - IF ( NUM .EQ. 0 ) THEN - WRITE ( STDOUT, 2106 ) - GO TO 311 - ELSE - WRITE ( STDOUT, 2006 ) ( TARGET(K)(DER:DER), K = 1, NUM ) - ENDIF - WRITE ( STDOUT, 2003 ) - READ ( STDIN, '( A1 )' ) CHOICE - IF ( UPPER( CHOICE ) .EQ. 'Y' ) GO TO 311 -C -C Get problem interest -C - ELSE IF ( CHAR .EQ. 'I' ) THEN - 411 CONTINUE - NUM = 0 - WRITE ( STDOUT, 1010 ) - DO 430 I = 1, MIN( MAXTRG, 3 ) - 410 CONTINUE - IF ( NUM .EQ. 0 ) WRITE ( STDOUT, 1111 ) - IF ( NUM .GT. 0 ) WRITE ( STDOUT, 1011 ) - READ ( STDIN , FMT = '( A1 )', ERR = 420 ) CHOICE - CHOICE = UPPER( CHOICE ) - IF ( REJECT( CHOICE, INTRST, NUM ) ) GO TO 420 - IF ( I .GT. 1 ) THEN - IM1 = I - 1 - DO 435 J = 1, IM1 - IF ( TARGET(J)(INTRST:INTRST) .EQ. CHOICE ) GO TO 425 - 435 CONTINUE - ENDIF - TARGET(I)(INTRST:INTRST) = CHOICE - IF ( CHOICE .NE. ' ' ) NUM = NUM + 1 - IF ( CHOICE .EQ. ' ' .OR. CHOICE .EQ. '*' ) GO TO 440 - GO TO 430 - 420 CONTINUE - WRITE ( STDOUT, 1001 ) - GO TO 410 - 425 CONTINUE - WRITE ( STDOUT, 1101 ) - GO TO 410 - 430 CONTINUE -C -C Verify the problem's interest -C - 440 CONTINUE - IF ( NUM .EQ. 0 ) THEN - WRITE ( STDOUT, 2107 ) - GO TO 411 - ELSE - WRITE ( STDOUT, 2007 ) ( TARGET(K)(INTRST:INTRST), K = 1, NUM) - ENDIF - WRITE ( STDOUT, 2003 ) - READ ( STDIN, '( A1 )' ) CHOICE - IF ( UPPER( CHOICE ) .EQ. 'Y' ) GO TO 411 -C -C Get the internal variables indicator -C - ELSE IF ( CHAR .EQ. 'S' ) THEN - 511 CONTINUE - WRITE ( STDOUT, 1012 ) - 510 CONTINUE - WRITE ( STDOUT, 1013 ) - READ ( STDIN , '( A1 )', ERR = 520 ) CHOICE - CHOICE = UPPER( CHOICE ) - IF ( REJECT( CHOICE, INTVAR, 0 ) ) GO TO 520 - TARGET(1)(INTVAR:INTVAR) = CHOICE - GO TO 540 - 520 CONTINUE - WRITE ( STDOUT, 1001 ) - GO TO 510 -C -C Verify the indicator for explicit internal variables -C - 540 CONTINUE - IF ( CHOICE .EQ. 'Y' ) THEN - WRITE ( STDOUT, 2008 ) - ELSE IF ( CHOICE .EQ. 'N' ) THEN - WRITE ( STDOUT, 2018 ) - ELSE - WRITE ( STDOUT, 2017 ) - ENDIF - WRITE ( STDOUT, 2003 ) - READ ( STDIN, '( A1 )' ) CHOICE - IF ( UPPER( CHOICE ) .EQ. 'Y' ) GO TO 511 -C -C Get the number of variables -C - ELSE IF ( CHAR .EQ. 'N' ) THEN - 611 CONTINUE - NUM = 0 - WRITE ( STDOUT, 1014 ) - 610 CONTINUE - WRITE ( STDOUT, 1015 ) - READ ( STDIN , FMT = '( A1 )', ERR = 620 ) CHOICE - CHOICE = UPPER( CHOICE ) - IF ( REJECT( CHOICE, VARN, 0 ) ) GO TO 620 - TARGET(1)(VARN:VARN) = CHOICE - GO TO 640 - 620 CONTINUE - WRITE ( STDOUT, 1001 ) - GO TO 610 -C -C Verify the number of variables type -C - 640 CONTINUE - IF ( CHOICE .EQ. 'F' ) THEN - WRITE ( STDOUT, 2009 ) - ELSE IF ( CHOICE .EQ. 'V' ) THEN - WRITE ( STDOUT, 2019 ) - ELSE IF ( CHOICE .EQ. 'I' ) THEN - WRITE ( STDOUT, 4009 ) - ELSE - WRITE ( STDOUT, 2029 ) - ENDIF - WRITE ( STDOUT, 2003 ) - READ ( STDIN, '( A1 )' ) CHOICE - IF ( UPPER( CHOICE ) .EQ. 'Y' ) GO TO 611 -C -C Get the fixed number of variables -C - IF ( TARGET(1)(VARN:VARN) .EQ. 'F' ) THEN - 641 CONTINUE - NUM = 0 - DO 670 I = 1, MAXTRG - WRITE( STDOUT, 1018 ) - 650 CONTINUE - IF ( NUM .EQ. 0) WRITE( STDOUT, 1119 ) - IF ( NUM .GT. 0) WRITE( STDOUT, 1019 ) - READ ( STDIN , '( A80 )', ERR = 660 ) LINE - CHOICE = UPPER( LINE(1:1) ) - IF ( NUM .EQ. 0 ) ANYFNV = - 1 CHOICE .EQ. '*' .OR. CHOICE .EQ. ' ' - IF ( NUM .NE. 0 ) ANYFNV = CHOICE .EQ. '*' - IF ( CHOICE .EQ. ' ' .OR. ANYFNV ) GO TO 695 - NVAR( I ) = CONVERT( LINE(1:5) ) - IF ( I .GT. 1 ) THEN - IM1 = I - 1 - DO 655 J = 1, IM1 - IF ( NVAR(J) .EQ. NVAR(I) ) GO TO 665 - 655 CONTINUE - ENDIF - IF ( NVAR(I) .LT. 0 .OR. NVAR(I) .GT. 99999999 ) GO TO 660 - NUM = NUM + 1 - GO TO 670 - 660 CONTINUE - WRITE ( STDOUT, 1001 ) - GO TO 650 - 665 CONTINUE - WRITE ( STDOUT, 1101 ) - GO TO 650 - 670 CONTINUE -C -C Verify the number of variables -C - 695 CONTINUE - IF ( ANYFNV ) THEN - WRITE ( STDOUT, 2020 ) - ELSE - IF ( NUM .EQ. 0 ) THEN - WRITE ( STDOUT, 2110 ) - GO TO 641 - ELSE - WRITE ( STDOUT, 2010 ) ( NVAR(K), K = 1, NUM ) - ENDIF - ENDIF - WRITE ( STDOUT, 2003 ) - READ ( STDIN, '( A1 )' ) CHOICE - IF ( UPPER( CHOICE ) .EQ. 'Y' ) GO TO 641 -C -C Get an interval for the number of variables -C a) lower bound -C - ELSE IF ( TARGET(1)(VARN:VARN) .EQ. 'I' ) THEN - 800 CONTINUE - LN = 0 - UN = 99999999 - WRITE ( STDOUT, 4003 ) - 801 CONTINUE - WRITE ( STDOUT, 4004 ) - READ ( STDIN, '( A80 ) ', ERR = 802 ) LINE - CHOICE = UPPER( LINE(1:1) ) - IF ( CHOICE .NE. ' ' ) THEN - LN = CONVERT( LINE(1:5) ) - IF ( LN .LT. 0 .OR. LN. GT. 99999999 ) GO TO 802 - ENDIF - GO TO 805 - 802 CONTINUE - WRITE ( STDOUT, 1001 ) - GO TO 801 -C -C b) upper bound -C - 805 CONTINUE - WRITE ( STDOUT, 4005 ) - 803 CONTINUE - WRITE ( STDOUT, 4006 ) - READ ( STDIN, '( A80 ) ', ERR = 804 ) LINE - CHOICE = UPPER( LINE(1:1) ) - IF ( CHOICE .NE. ' ' ) THEN - UN = CONVERT( LINE(1:5) ) - IF ( UN .LT. 0 .OR. UN. GT. 99999999 .OR. LN. GT. UN ) - 1 GO TO 804 - ENDIF - GO TO 806 - 804 CONTINUE - WRITE ( STDOUT, 1001 ) - GO TO 803 -C -C Verify the bounds on the number of variables -C - 806 CONTINUE - WRITE ( STDOUT, 4007 ) LN, UN - WRITE ( STDOUT, 2003 ) - READ ( STDIN, '( A1 )' ) CHOICE - IF ( UPPER( CHOICE ) .EQ. 'Y' ) GO TO 800 - ENDIF -C -C Get the number of constraints -C - ELSE IF ( CHAR .EQ. 'M' ) THEN - NUM = 0 - 711 CONTINUE - WRITE ( STDOUT, 1016 ) - 710 CONTINUE - WRITE ( STDOUT, 1017 ) - READ ( STDIN , FMT = '( A1 )', ERR = 720 ) CHOICE - CHOICE = UPPER( CHOICE ) - IF ( REJECT( CHOICE, VARM, 0 ) ) GO TO 720 - TARGET(1)(VARM:VARM) = CHOICE - GO TO 740 - 720 CONTINUE - WRITE ( STDOUT, 1001 ) - GO TO 710 -C -C Verify the constraints number type -C - 740 CONTINUE - IF ( CHOICE .EQ. 'F' ) THEN - WRITE ( STDOUT, 2011 ) - ELSE IF ( CHOICE .EQ. 'V' ) THEN - WRITE ( STDOUT, 2021 ) - ELSE IF ( CHOICE .EQ. 'I' ) THEN - WRITE ( STDOUT, 6009 ) - ELSE - WRITE ( STDOUT, 2031 ) - ENDIF - WRITE ( STDOUT, 2003 ) - READ ( STDIN, '( A1 )' ) CHOICE - IF ( UPPER( CHOICE ) .EQ. 'Y' ) GO TO 711 -C -C Get the fixed number of constraints -C - IF ( TARGET(1)(VARM:VARM) .EQ. 'F' ) THEN - 741 CONTINUE - NUM = 0 - DO 770 I = 1, MAXTRG - WRITE( STDOUT, 1020 ) - 750 CONTINUE - IF ( NUM .EQ. 0) WRITE( STDOUT, 1121 ) - IF ( NUM .GT. 0) WRITE( STDOUT, 1021 ) - READ ( STDIN , FMT = '( A80 )', ERR = 760 ) LINE - CHOICE = UPPER( LINE(1:1) ) - IF ( NUM .EQ. 0 ) ANYFNC = - 1 CHOICE .EQ. '*' .OR. CHOICE .EQ. ' ' - IF ( NUM .NE. 0 ) ANYFNC = CHOICE .EQ. '*' - IF ( CHOICE .EQ. ' ' .OR. ANYFNC ) GO TO 795 - NCON(I) = CONVERT( LINE(1:5) ) - IF ( I .GT. 1 ) THEN - IM1 = I - 1 - DO 755 J = 1, IM1 - IF ( NCON(J) .EQ. NCON(I) ) GO TO 765 - 755 CONTINUE - ENDIF - IF ( NCON(I) .LT. 0 .OR. NCON(I) .GT. 99999999 ) GO TO 760 - NUM = NUM + 1 - GO TO 770 - 760 CONTINUE - WRITE ( STDOUT, 1001 ) - GO TO 750 - 765 CONTINUE - WRITE ( STDOUT, 1101 ) - GO TO 750 - 770 CONTINUE -C -C Verify the number of constraints -C - 795 CONTINUE - IF ( ANYFNC ) THEN - WRITE ( STDOUT, 2022 ) - ELSE - IF ( NUM .EQ. 0 ) THEN - WRITE ( STDOUT, 2120 ) - GO TO 741 - ELSE - WRITE ( STDOUT, 2012 ) ( NCON(K), K = 1, NUM ) - ENDIF - ENDIF - WRITE ( STDOUT, 2003 ) - READ ( STDIN, '( A1 )' ) CHOICE - IF ( UPPER( CHOICE ) .EQ. 'Y' ) GO TO 741 -C -C Get an interval for the number of constraints -C a) lower bound -C - ELSE IF ( TARGET(1)(VARM:VARM) .EQ. 'I' ) THEN - 900 CONTINUE - LM = 0 - UM = 99999999 - WRITE ( STDOUT, 6003 ) - 901 CONTINUE - WRITE ( STDOUT, 6004 ) - READ ( STDIN, '( A80 ) ', ERR = 902 ) LINE - CHOICE = UPPER( LINE(1:1) ) - IF ( CHOICE .NE. ' ' ) THEN - LM = CONVERT( LINE(1:5) ) - IF ( LM .LT. 0 .OR. LM. GT. 99999999 ) GO TO 902 - ENDIF - GO TO 905 - 902 CONTINUE - WRITE ( STDOUT, 1001 ) - GO TO 901 -C -C b) upper bound -C - 905 CONTINUE - WRITE ( STDOUT, 6005 ) - 903 CONTINUE - WRITE ( STDOUT, 6006 ) - READ ( STDIN, '( A80 ) ', ERR = 904 ) LINE - CHOICE = UPPER( LINE(1:1) ) - IF ( CHOICE .NE. ' ' ) THEN - UM = CONVERT( LINE(1:5) ) - IF ( UM .LT. 0 .OR. UM. GT. 99999999 .OR. LM. GT. UM ) - 1 GO TO 904 - ENDIF - GO TO 906 - 904 CONTINUE - WRITE ( STDOUT, 1001 ) - GO TO 903 -C -C Verify the bounds on the number of constraints -C - 906 CONTINUE - WRITE ( STDOUT, 6007 ) LM, UM - WRITE ( STDOUT, 2003 ) - READ ( STDIN, '( A1 )' ) CHOICE - IF ( UPPER( CHOICE ) .EQ. 'Y' ) GO TO 900 - ENDIF -C -C All characteristics have been recorded. Quit -C - ELSE IF ( CHAR .EQ. ' ' ) THEN - GO TO 7 -C -C Error in the choice of characteristic -C - ELSE - GO TO 2 - ENDIF -C -C Loop for another characteristic -C - CLOSE ( CLSDVC ) - GO TO 5 -C -C Handle the error in characteristic choice -C - 2 CONTINUE - WRITE ( STDOUT, 1001 ) - GO TO 6 -C -C The target(s) are now defined. -C - 7 CONTINUE - WRITE (STDOUT, 4001 ) -C -C Loop on the problem classification and print names of matching ones -C in lots of 5. Also accumulate the number of matching problems found. -C - NMATCH = 0 - L = 0 - 3000 CONTINUE - READ ( CLSDVC, '( A28 )', END = 3010 ) PBCLS - IF ( MATCH( PBCLS(10:28), TARGET, MAXTRG, ANYFNV, ANYFNC, - 1 NVAR, NCON, LN, UN, LM, UM ) ) THEN - NMATCH = NMATCH + 1 - L = L + 1 - LIST(L) = PBCLS(1:8) - IF ( L .EQ. 5 ) THEN - WRITE ( STDOUT, 4002 ) ( LIST(I), I = 1, 5 ) - L = 0 - ENDIF - ENDIF - GO TO 3000 -C -C End of the database processing for the main loop. -C -C Print selected problem names still -C in waiting list for output. -C - 3010 CONTINUE - IF ( L .GE. 1 ) WRITE ( STDOUT, 4002 ) ( LIST(I), I = 1, L ) - WRITE ( STDOUT, 4000 ) NMATCH - CLOSE ( CLSDVC ) - WRITE ( STDOUT, 7001 ) - READ ( STDIN, '( A1 )' ) CHOICE - IF ( UPPER( CHOICE ) .EQ. 'Y' ) THEN - OPEN( UNIT = CLSDVC, FILE = FILEN, STATUS = 'OLD' ) - WRITE ( STDOUT, 4955 ) - READ ( STDIN , FMT = '( A )' ) FILES - SIZE = LEN( FILES ) - OPEN( UNIT = FLSDVC, FILE = FILES, STATUS = 'UNKNOWN' ) - 3020 CONTINUE - READ ( CLSDVC, '( A28 )', END = 3050 ) PBCLS - IF ( MATCH( PBCLS(10:28), TARGET, MAXTRG, ANYFNV, ANYFNC, - 1 NVAR, NCON, LN, UN, LM, UM ) ) THEN - NBLK = 8 - DO 3030 NLBK = 8, 2, -1 - IF ( PBCLS(NBLK:NBLK) .NE. ' ' ) GO TO 3040 - 3030 CONTINUE - 3040 CONTINUE - WRITE ( FLSDVC, '(A)' ) PBCLS(1:NBLK) - ENDIF - GO TO 3020 - 3050 CLOSE ( FLSDVC ) - CLOSE ( CLSDVC ) - ENDIF - WRITE ( STDOUT, 7000 ) - READ ( STDIN, '( A1 )' ) CHOICE - IF ( UPPER( CHOICE ) .EQ. 'Y' ) GO TO 1 -C -C End of the database processing. -C - STOP -C -C Non excutable statements -C - 1000 FORMAT( /' *************************************************' - 1 /' * *' - 1 /' * CONSTRAINED AND UNCONSTRAINED *' - 1 /' * TESTING ENVIRONMENT *' - 1 /' * *' - 1 /' * ( CUTE ) *' - 1 /' * *' - 1 /' * INTERACTIVE PROBLEM SELECTION *' - 1 /' * *' - 1 /' * CGT PRODUCTIONS *' - 1 /' * *' - 1 /' *************************************************' - 1 / ) - 1101 FORMAT( ' *** THIS SELECTION IS REPETITION. Please choose ', - 1 'again.' - 1 / ) - 1201 FORMAT( ' *** YOU USED MORE THAN 32 CHARACTERS. Please choose', - 1 ' again.' - 1 / ) - 1001 FORMAT( ' *** YOUR ANSWER IS NOT ALLOWED. Please choose again.' - 1 / ) - 4950 FORMAT( /' Your current classification file is : ', - 1 A ) - 4957 FORMAT( /' Do you wish to change this [ = N] ?', - 1 ' (N/Y)') - 4955 FORMAT( ' Input the filename you want (up to 32 characters): ') - 5000 FORMAT( /' CHOOSE A PROBLEM CHARACTERISTIC THAT YOU WANT', - 1 ' TO SPECIFY :' - 1 /' ---------------------------------------------', - 1 '-------------' ) - 5001 FORMAT( /' O : Objective type C : Constraint', - 1 ' type' - 1 /' R : Regularity I : Problem', - 1 ' interest' - 1 /' N : Number of variables M : Number of', - 1 ' constraints' - 1 /' D : Degree of available analytic derivatives' - 1 /' S : Presence of explicit internal variables' - 1 /' : No further characteristic, perform', - 1 ' selection' - 1 /' ' - 1 /' Your choice :' ) - 5002 FORMAT( /' Your current problem selection key is:' - 1 /' ( * = anything goes )' ) - 5003 FORMAT( /' Objective function type : ', - 1 10 ( A1, 1X ) ) - 5004 FORMAT( ' Constraints type : ', - 1 10 ( A1, 1X ) ) - 5005 FORMAT( ' Regularity : ', - 1 10 ( A1, 1X ) ) - 5006 FORMAT( ' Degree of available derivatives : ', - 1 10 ( A1, 1X ) ) - 5007 FORMAT( ' Problem interest : ', - 1 10 ( A1, 1X ) ) - 5008 FORMAT( ' Explicit internal variables : ', - 1 10 ( A1, 1X ) ) - 5009 FORMAT( ' Number of variables : v' ) - 5010 FORMAT( ' Number of variables : *' ) - 5011 FORMAT( ' Number of variables : any fixed number - 1 ') - 5012 FORMAT( ' Number of variables : ', - 1 10 ( I5, 1X ) ) - 5013 FORMAT( ' Number of constraints : v' ) - 5014 FORMAT( ' Number of constraints : *' ) - 5015 FORMAT( ' Number of constraints : any fixed number - 1 ') - 5016 FORMAT( ' Number of constraints : ', - 1 10 ( I5, 1X ) ) - 1002 FORMAT( /' OBJECTIVE FUNCTION TYPE :' - 1 /' -------------------------' ) - 1103 FORMAT( /' C : Constant L : Linear' - 1 /' Q : Quadratic S : Sum of squares' - 1 /' N : No objective' - 1 /' O : Other (that is none of the above)' - 1 /' : Any of the above (*)' - 1 /' ' - 1 /' Your choice :' ) - 1003 FORMAT( /' C : Constant L : Linear' - 1 /' Q : Quadratic S : Sum of squares' - 1 /' N : No objective' - 1 /' O : Other (that is none of the above)' - 1 /' : No further type' - 1 /' ' - 1 /' Your choice :' ) - 1004 FORMAT( /' CONSTRAINTS TYPE :' - 1 /' ------------------' ) - 1105 FORMAT( /' U : No constraint X : Fixed variables', - 1 ' only' - 1 /' B : Bounds only N : Linear network' - 1 /' L : Linear Q : Quadratic' - 1 /' O : Other (that is more general than any of the', - 1 ' above alone)' - 1 /' : Any of the above (*)' - 1 /' ' - 1 /' Your choice :' ) - 1005 FORMAT( /' U : No constraint X : Fixed variables', - 1 ' only' - 1 /' B : Bounds only N : Linear network' - 1 /' L : Linear Q : Quadratic' - 1 /' O : Other (that is more general than any of the', - 1 ' above alone)' - 1 /' : No further type' - 1 /' ' - 1 /' Your choice :' ) - 1006 FORMAT( /' PROBLEM REGULARITY TYPE :' - 1 /' -------------------------' ) - 1007 FORMAT( /' R : Twice continuously differentiable' - 1 /' I : Other' - 1 /' : Any of the above (*)' - 1 /' ' - 1 /' Your choice :' ) - 1008 FORMAT( /' DEGREE OF AVAILABLE ANALYTICAL DERIVATIVES :' - 1 /' --------------------------------------------' ) - 1109 FORMAT( /' 0 : No analytical der. 1 : Analytical first' - 1 /' 2 : Analytical second' - 1 /' : Any of the above (*)' - 1 /' ' - 1 /' Your choice :' ) - 1009 FORMAT( /' 0 : No analytical der. 1 : Analytical first' - 1 /' 2 : Analytical second' - 1 /' : No further degree' - 1 /' ' - 1 /' Your choice :' ) - 1010 FORMAT( /' PROBLEM INTEREST TYPE :' - 1 /' -----------------------' ) - 1111 FORMAT( /' A : Academic R : Real application' - 1 /' M : Modelling' - 1 /' : Any of the above (*)' - 1 /' ' - 1 /' Your choice :' ) - 1011 FORMAT( /' A : Academic R : Real application' - 1 /' M : Modelling' - 1 /' : No further type' - 1 /' ' - 1 /' Your choice :' ) - 1012 FORMAT( /' PRESENCE OF EXPLICIT INTERNAL VARIABLES :' - 1 /' -----------------------------------------' ) - 1013 FORMAT( /' Y : Yes N : No' - 1 /' : Any of the above (*)' - 1 /' ' - 1 /' Your choice :' ) - 1014 FORMAT( /' NUMBER OF VARIABLES :' - 1 /' ---------------------' ) - 1015 FORMAT( /' F : Fixed V : Variable' - 1 /' I : In an interval' - 1 /' : Any number of variables (*)' - 1 /' ' - 1 /' Your choice :' ) - 1016 FORMAT( /' NUMBER OF CONSTRAINTS :' - 1 /' -----------------------' ) - 1017 FORMAT( /' F : Fixed V : Variable' - 1 /' I : In an interval' - 1 /' : Any number of constraints (*)' - 1 /' ' - 1 /' Your choice :' ) - 1018 FORMAT( /' SELECT A NUMBER OF VARIABLES:' - 1 /' -----------------------------' ) - 1119 FORMAT( /' (INT) : Select only problems with (INT) variables' - 1 /' (minimum 0, maximum 99999999, multiple ', - 1 'choices are allowed)' - 1 /' : Any fixed number of variables (*)' - 1 /' ' - 1 /' Your choice :' ) - 1019 FORMAT( /' (INT) : Select only problems with (INT) variables' - 1 /' (minimum 0, maximum 99999999, multiple ', - 1 'choices are allowed)' - 1 /' * : Any fixed number of variables' - 1 /' : No further selection', - 1 /' ' - 1 /' Your choice :' ) - 1020 FORMAT( /' SELECT A NUMBER OF CONSTRAINTS:' - 1 /' -------------------------------' ) - 1121 FORMAT( /' (INT) : Select only problems with (INT) constraints' - 1 /' (minimum 0, maximum 99999999, multiple ', - 1 'choices are allowed)' - 1 /' : Any fixed number of variables (*)' - 1 /' ' - 1 /' Your choice :' ) - 1021 FORMAT( /' (INT) : Select only problems with (INT) constraints' - 1 /' (minimum 0, maximum 99999999, multiple ', - 1 'choices are allowed)' - 1 /' * : Any fixed number of variables ' - 1 /' : No further selection', - 1 /' ' - 1 /' Your choice :' ) - 2002 FORMAT( /' You have specified objective of type(s): ', - 1 10( A1, 1X ) ) - 2102 FORMAT( /' *** Please choose an objective function type.' ) - 2003 FORMAT( ' Do you wish to reconsider your choice [ = N] ?', - 1 ' (N/Y)') - 2004 FORMAT( /' You have specified constraints of type(s): ', - 1 10( A1, 1X ) ) - 2104 FORMAT( /' *** Please choose a constraint type.' ) - 2005 FORMAT( /' You have specified regularity of type: ', A1 ) - 2006 FORMAT( /' You have specified derivatives of degree: ', - 1 10( A1, 1X ) ) - 2106 FORMAT(/' *** Please choose a degree of available derivatives.') - 2007 FORMAT( /' You have specified problem interest of type: ', - 1 10( A1, 1X ) ) - 2107 FORMAT( /' *** Please choose a problem interest type.' ) - 2008 FORMAT( /' You have specified problems with explicit', - 1 ' internal variables.' ) - 2018 FORMAT( /' You have specified problems without explicit', - 1 ' internal variables.' ) - 2017 FORMAT( /' You have specified problems with or without', - 1 ' explicit internal variables.' ) - 2009 FORMAT( /' You have specified a fixed number of variables.' ) - 2019 FORMAT( /' You have specified a variable number of variables.' ) - 2029 FORMAT( /' You have specified any number of variables.' ) - 2010 FORMAT( /' You have specified a number of variables', - 1 ' in the set: ', - 1 /' ', 10( I5, 1X ) ) - 2020 FORMAT( /' You have specified any fixed number of variables.' ) - 2110 FORMAT( /' *** Please choose a number of variables.' ) - 2011 FORMAT( /' You have specified a fixed number of constraints.' ) - 2021 FORMAT(/' You have specified a variable number of constraints.') - 2031 FORMAT( /' You have specified any number of constraints.' ) - 2012 FORMAT( /' You have specified a number of constraints', - 1 ' in the set: ', - 1 /' ', 10( I5, 1X ) ) - 2022 FORMAT( /' You have specified any fixed number of constraints.') - 2120 FORMAT( /' *** Please choose a number of constraints.' ) - 4000 FORMAT( /' ', I5, ' Problem(s) match(es) the specification.' / ) - 4001 FORMAT( /' MATCHING PROBLEMS :' - 1 /' -------------------' / ) - 4002 FORMAT( ' ', 5( A8, 3X ) ) - 4003 FORMAT( /' LOWER BOUND ON THE NUMBER OF VARIABLES :' - 1 /' ----------------------------------------' ) - 4004 FORMAT( /' (INT) : Problems with at least (INT) variables' - 1 /' : No lower bound on the number of variables' - 1 /' ' - 1 /' Your choice : ' ) - 4005 FORMAT( /' UPPER BOUND ON THE NUMBER OF VARIABLES :' - 1 /' ----------------------------------------' ) - 4006 FORMAT( /' (INT) : Problems with at most (INT) variables' - 1 /' : No upper bound on the number of variables' - 1 /' ' - 1 /' Your choice : ' ) - 4007 FORMAT( /' You have specified a number of variables in [ ', - 1 I5,', ',I5,' ]' ) - 4008 FORMAT( ' Number of variables : in [ ', - 1 I5,', ',I5,' ]' ) - 4009 FORMAT( /' You have specified an interval for the number of', - 1 ' variables.' ) - 6003 FORMAT( /' LOWER BOUND ON THE NUMBER OF CONSTRAINTS :' - 1 /' -----------------------------------------' ) - 6004 FORMAT( /' (INT) : Problems with at least (INT) constraints' - 1 /' : No lower bound on the number of constraints' - 1 /' ' - 1 /' Your choice : ' ) - 6005 FORMAT( /' UPPER BOUND ON THE NUMBER OF CONSTRAINTS :' - 1 /' -----------------------------------------' ) - 6006 FORMAT( /' (INT) : Problems with at most (INT) constraints' - 1 /' : No upper bound on the number of constraints' - 1 /' ' - 1 /' Your choice : ' ) - 6007 FORMAT( /' You have specified a number of constraints in [ ', - 1 I5,', ',I5,' ]' ) - 6008 FORMAT( ' Number of constraints : in [ ', - 1 I5,', ',I5,' ]' ) - 6009 FORMAT( /' You have specified an interval for the number of', - 1 ' constraints.' ) -C Added by Kristjan Jonasson. - 7001 FORMAT( /' Do you wish to save the problem names to a file', - 1 ' [ = N] ? (N/Y)') - 7000 FORMAT( /' Do you wish to make another selection [ = N] ?', - 1 ' (N/Y)') - 8000 FORMAT( A256 ) - END -C -C----------------------------------------------------------------------------- -C - LOGICAL FUNCTION REJECT( CHOICE, ITEM, NUM) -C -C----------------------------------------------------------------------------- -C -C The purpose of this function is to verify if the character CHOICE -C is a valid specification for item ITEM, where ITEM is one of -C 1 = objective type, -C 2 = constraints type, -C 3 = problem regularity, -C 4 = degree of available derivatives, -C 5 = problem interest, -C 6 = presence of explicit internal variables, -C 7 = number of variables, -C 8 = number of constraints. -C -C Programming: A. R. Conn and Ph. Toint for CGT Productions. -C -C----------------------------------------------------------------------------- -C -C -C Classification constants -C - INTEGER OBJ, CON, REG, DER, INTRST, INTVAR, VARN, VARM - PARAMETER ( OBJ = 1, CON = 2, REG = 3, DER = 4, INTRST = 5, - 1 INTVAR = 6, VARN = 7, VARM = 8 ) -C -C Arguments -C - CHARACTER*1 CHOICE - INTEGER ITEM, NUM -C -C Other variables -C - LOGICAL ADMIT -C -C Control choices -C - IF ( ( CHOICE .EQ. ' ' .OR. CHOICE .EQ. '*' ) - 1 .AND. NUM .EQ. 0 ) THEN - CHOICE = '*' - REJECT = .FALSE. - RETURN -C -C Objective function type -C - ELSE IF ( ITEM .EQ. OBJ ) THEN - ADMIT = CHOICE .EQ. 'N' .OR. CHOICE .EQ. 'C' .OR. - 1 CHOICE .EQ. 'L' .OR. CHOICE .EQ. 'Q' .OR. - 1 CHOICE .EQ. 'S' .OR. CHOICE .EQ. 'O' .OR. - 1 CHOICE .EQ. ' ' -C -C Constraint type -C - ELSE IF ( ITEM .EQ. CON ) THEN - ADMIT = CHOICE .EQ. 'U' .OR. CHOICE .EQ. 'B' .OR. - 1 CHOICE .EQ. 'N' .OR. CHOICE .EQ. 'L' .OR. - 1 CHOICE .EQ. 'Q' .OR. CHOICE .EQ. 'O' .OR. - 1 CHOICE .EQ. 'X' .OR. CHOICE .EQ. ' ' -C -C Problem regularity -C - ELSE IF ( ITEM .EQ. REG ) THEN - ADMIT = CHOICE .EQ. 'R' .OR. CHOICE .EQ. 'I' -C -C Degree of analytical derivatives -C - ELSE IF ( ITEM .EQ. DER ) THEN - ADMIT = CHOICE .EQ. '0' .OR. CHOICE .EQ. '1' .OR. - 1 CHOICE .EQ. '2' .OR. CHOICE .EQ. ' ' -C -C Problem interest -C - ELSE IF ( ITEM .EQ. INTRST ) THEN - ADMIT = CHOICE .EQ. 'A' .OR. CHOICE .EQ. 'R' .OR. - 1 CHOICE .EQ. 'M' .OR. CHOICE .EQ. ' ' -C -C Presence of explicit internal variables -C - ELSE IF ( ITEM .EQ. INTVAR ) THEN - ADMIT = CHOICE .EQ. 'Y' .OR. CHOICE .EQ. 'N' -C -C Number of variables and constraints -C - ELSE IF ( ITEM .EQ. VARN .OR. ITEM .EQ. VARM ) THEN - ADMIT = CHOICE .EQ. 'F' .OR. CHOICE .EQ. 'V' .OR. - 1 CHOICE .EQ. 'I' - ENDIF - REJECT = .NOT. ADMIT - RETURN - END -C -C----------------------------------------------------------------------------- -C - LOGICAL FUNCTION MATCH ( C, T, MAXTRG, ANYFNV, ANYFNC, NV, NC, - 1 LN, UN, LM, UM ) -C -C----------------------------------------------------------------------------- -C -C The purpose of this function is to check if the classification C -C matches one of the targets specified by T, ANYFNV, ANYFNC, NV, NC, LN -C UN, LM and UM. -C -C Programming: Ph. Toint, Dec 1991, for CGT Productions. -C -C----------------------------------------------------------------------------- -C -C Arguments -C - CHARACTER*8 T( MAXTRG ) - CHARACTER*19 C - LOGICAL ANYFNV, ANYFNC - INTEGER NV( MAXTRG ), NC( MAXTRG ), MAXTRG, LN, UN, LM, UM -C -C Other variables -C - INTEGER I, J, CONVERT - CHARACTER*1 CH -C -C Match objective function type -C - MATCH = .FALSE. - DO 10 I = 1, MAXTRG - CH = T(I)(1:1) - IF ( CH .EQ. ' ' ) GO TO 20 - MATCH = MATCH .OR. CH .EQ. C(1:1) .OR. CH .EQ. '*' - 10 CONTINUE - 20 CONTINUE - IF ( .NOT. MATCH ) RETURN -C -C Match constraint type -C - MATCH = .FALSE. - DO 30 I = 1, MAXTRG - CH = T(I)(2:2) - IF ( CH .EQ. ' ' ) GO TO 40 - MATCH = MATCH .OR. CH .EQ. C(2:2) .OR. CH .EQ. '*' - 30 CONTINUE - 40 CONTINUE - IF ( .NOT. MATCH ) RETURN -C -C Match regularity type -C - CH = T(1)(3:3) - MATCH = CH .EQ. C(3:3) .OR. CH .EQ. '*' - IF ( .NOT. MATCH ) RETURN -C -C Match degree of available derivatives -C - MATCH = .FALSE. - DO 50 I = 1, MAXTRG - CH = T(I)(4:4) - IF ( CH .EQ. ' ' ) GO TO 60 - MATCH = MATCH .OR. CH .EQ. C(4:4) .OR. CH .EQ. '*' - 50 CONTINUE - 60 CONTINUE - IF ( .NOT. MATCH ) RETURN -C -C Match interest of the problem -C - MATCH = .FALSE. - DO 70 I = 1, MAXTRG - CH = T(I)(5:5) - IF ( CH .EQ. ' ' ) GO TO 80 - MATCH = MATCH .OR. CH .EQ. C(6:6) .OR. CH .EQ. '*' - 70 CONTINUE - 80 CONTINUE - IF ( .NOT. MATCH ) RETURN -C -C Match for explicit internal variables -C - CH = T(1)(6:6) - MATCH = CH .EQ. C(7:7) .OR. CH .EQ. '*' - IF ( .NOT. MATCH ) RETURN -C -C Match the number of variables -C - MATCH = .FALSE. - CH = T(1)(7:7) - IF ( CH .EQ. '*' ) THEN - MATCH = .TRUE. - ELSE IF ( CH .EQ. 'V' ) THEN - MATCH = C(13:13) .EQ. 'V' - ELSE IF ( CH .EQ. 'I' ) THEN -C interval. A variable number of variables is no longer considered to -C match a number in an interval. - IF ( C(13:13) .NE. 'V' ) THEN - I = CONVERT( C(9:13) ) - MATCH = I. GE. LN .AND. I .LE. UN - ENDIF - ELSE - IF ( ANYFNV ) THEN - MATCH = .TRUE. - ELSE -C A variable number of variables is no longer considered to match a fixed -C number. - IF ( C(13:13) .NE. 'V' ) THEN - J = CONVERT( C(9:13) ) - DO 90 I = 1, MAXTRG - IF ( NV(I) .LT. 0 ) GO TO 90 - MATCH = NV(I) .EQ. J - IF ( MATCH ) GO TO 100 - 90 CONTINUE - 100 CONTINUE - ENDIF - ENDIF - ENDIF - IF ( .NOT. MATCH ) RETURN -C -C Match the number of constraints -C - MATCH = .FALSE. - CH = T(1)(8:8) - IF ( CH .EQ. '*' ) THEN - MATCH = .TRUE. - ELSE IF ( CH .EQ. 'V' ) THEN - MATCH = C(19:19) .EQ. 'V' - ELSE IF ( CH .EQ. 'I' ) THEN -C interval. A variable number of constraints is no longer considered to -C match a number in an interval. - IF ( C(19:19) .NE. 'V' ) THEN - I = CONVERT( C(15:19) ) - MATCH = I. GE. LM .AND. I .LE. UM - ENDIF - ELSE - IF ( ANYFNC ) THEN - MATCH = .TRUE. - ELSE -C A variable number of constraints is no longer considered to match a fixed -C number. - IF ( C(19:19) .NE. 'V' ) THEN - J = CONVERT( C(15:19) ) - DO 110 I = 1, MAXTRG - IF ( NC(I) .LT. 0 ) GO TO 110 - MATCH = NC(I) .EQ. J - IF ( MATCH ) GO TO 120 - 110 CONTINUE - 120 CONTINUE - ENDIF - ENDIF - ENDIF - RETURN - END -C -C----------------------------------------------------------------------------- -C - INTEGER FUNCTION CONVERT( LINE ) -C -C----------------------------------------------------------------------------- -C -C The purpose of this function is to convert the nonnegative integer contained -C in the first 5 characters of the string LINE into a proper integer. -C -1 is returned in case of error. -C -C Programming: Ph. Toint, Dec 1991, for CGT Productions. -C -C----------------------------------------------------------------------------- -C -C Arguments -C - CHARACTER*5 LINE -C -C Other variables -C - INTEGER L -C -C Remove trailing blanks -C - DO 10 L= 5, 1, -1 - IF ( LINE(L:L) .NE. ' ' ) GO TO 20 - 10 CONTINUE - GO TO 30 -C -C Read the integer -C - 20 CONTINUE - IF ( L .EQ. 1 ) THEN - READ ( LINE(1:1), '( I1 )', ERR = 30 ) CONVERT - ELSE IF ( L .EQ. 2 ) THEN - READ ( LINE(1:2), '( I2 )', ERR = 30 ) CONVERT - ELSE IF ( L .EQ. 3 ) THEN - READ ( LINE(1:3), '( I3 )', ERR = 30 ) CONVERT - ELSE IF ( L .EQ. 4 ) THEN - READ ( LINE(1:4), '( I4 )', ERR = 30 ) CONVERT - ELSE - READ ( LINE(1:5), '( I5 )', ERR = 30 ) CONVERT - ENDIF - RETURN -C -C Error -C - 30 CONTINUE - CONVERT = -1 - RETURN - END -C -C----------------------------------------------------------------------------- -C - INTEGER FUNCTION NBT ( I, T, MX ) -C -C----------------------------------------------------------------------------- -C -C The purpose of this function is to return the number of non trivial -C choices of item I specified in the target list T. -C -C Programming: Ph. Toint, Dec 1991, for CGT Productions. -C -C----------------------------------------------------------------------------- -C -C Arguments -C - CHARACTER*8 T( MX ) - INTEGER I, MX -C -C Other variables -C - INTEGER L -C - NBT = 1 - DO 10 L = 2, MX - IF ( T(L)(I:I) .EQ. 'X' ) RETURN - NBT = NBT + 1 - 10 CONTINUE - RETURN - END -C -C----------------------------------------------------------------------------- -C - INTEGER FUNCTION NBI ( N, MX ) -C -C----------------------------------------------------------------------------- -C -C The purpose of this function is to return the number of non trivial -C dimensions specified in the integer dimension vector N. -C -C Programming: Ph. Toint, Dec 1991, for CGT Productions. -C -C----------------------------------------------------------------------------- -C -C Arguments -C - INTEGER N( MX ), MX -C -C Other variables -C - INTEGER L -C - NBI = 0 - DO 10 L = 1, MX - IF ( N(L) .LT. 0 ) RETURN - NBI = NBI + 1 - 10 CONTINUE - RETURN - END -C -C----------------------------------------------------------------------------- -C - CHARACTER*1 FUNCTION UPPER( CH ) -C -C----------------------------------------------------------------------------- -C -C The purpose of this function is to transform the character CH -C to upper case, if it is not already. -C -C Programming: Ph. Toint, Dec 1991, for CGT Productions. -C -C----------------------------------------------------------------------------- -C - CHARACTER*1 CH -C - INTRINSIC ICHAR, CHAR -C - INTEGER ICH, LSTART -C - LSTART = ICHAR( 'a' ) - ICH = ICHAR( CH ) - IF ( ICH .GE. LSTART .AND. ICH .LE. ICHAR( 'z' ) ) THEN - UPPER = CHAR( ICHAR( 'A' ) + ICH - LSTART ) - ELSE - UPPER = CH - ENDIF - RETURN - END - -C -C----------------------------------------------------------------------------- -C