PROGRAM test_smplx ! Test the F90 version of the NSWC routine SMPLX. USE constants_NSWC IMPLICIT NONE INTEGER :: n, pos, i, constr_type(9), m, ind, ibasis(9), iter, & mxiter = 25, numle, numge, j CHARACTER (LEN=79) :: text, in_text REAL (dp) :: a(9,9), b(9), c(9), x(9), z, temp(9), rerr REAL (dp), ALLOCATABLE :: bi(:,:) INTERFACE SUBROUTINE smplx (a, b0, c, ka, m, n0, ind, ibasis, x, z, iter, mxiter, & numle, numge, bi, rerr) USE constants_NSWC IMPLICIT NONE INTEGER, INTENT(IN) :: ka, m, n0, mxiter, numle, numge INTEGER, INTENT(IN OUT) :: ind INTEGER, DIMENSION(:), INTENT(IN OUT) :: ibasis INTEGER, INTENT(OUT) :: iter REAL (dp), DIMENSION(:,:), INTENT(IN) :: a REAL (dp), DIMENSION(:), INTENT(IN) :: b0, c REAL (dp), INTENT(OUT) :: z, rerr REAL (dp), DIMENSION(:), INTENT(OUT) :: x REAL (dp), DIMENSION(:,:), INTENT(OUT) :: bi END SUBROUTINE smplx END INTERFACE WRITE(*, *) 'How many variables? (<=9): ' READ(*, *) n IF (n > 9) STOP 'Too many!' WRITE(*, *) 'Enter constraint coefficients incl. constr. type (<=, >= or =)' WRITE(*, *) 'Press ENTER again after the last constraint' text = ' ' DO i = 1, n pos = 8*i-6 WRITE(text(pos:pos+3), '("X(", i1, ")")') i END DO text(pos+4:pos+11) = 'Con.type' text(pos+13:pos+15) = 'RHS' WRITE(*, '(a)') text WRITE(*, *) numle = 0 numge = 0 DO i = 1, 9 READ(*, '(a)') in_text IF (LEN_TRIM(in_text) == 0) EXIT READ(in_text, *) a(i,1:n) pos = INDEX(in_text, '=') IF (pos == 0) THEN STOP 'You must enter the constraint type (<=, >= or =)' END IF IF (in_text(pos-1:pos-1) == '<') THEN constr_type(i) = 1 numle = numle + 1 ELSE IF (in_text(pos-1:pos-1) == '>') THEN constr_type(i) = 2 numge = numge + 1 ELSE constr_type(i) = 3 END IF READ(in_text(pos+1:), *) b(i) END DO m = i - 1 ALLOCATE( bi(m,m) ) ! Re-order the constraints if necessary DO i = 1, numle IF (constr_type(i) /= 1) THEN DO j = numle+1, m IF (constr_type(j) == 1) THEN temp(1:n) = a(i, 1:n) a(i, 1:n) = a(j, 1:n) a(j, 1:n) = temp(1:n) z = b(i) b(i) = b(j) b(j) = z constr_type(j) = constr_type(i) constr_type(i) = 1 EXIT END IF END DO END IF END DO DO i = numle+1, numle+numge IF (constr_type(i) /= 2) THEN DO j = numle+numge+1, m IF (constr_type(j) == 2) THEN temp(1:n) = a(i, 1:n) a(i, 1:n) = a(j, 1:n) a(j, 1:n) = temp(1:n) z = b(i) b(i) = b(j) b(j) = z constr_type(j) = constr_type(i) constr_type(i) = 2 EXIT END IF END DO END IF END DO ! Enter the coefficients in the objective function. WRITE(*, *) 'Enter the coefficients (costs) in the objective to be maximized' pos = 8*n-2 text(pos:) = ' ' WRITE(*, '(a)') text WRITE(*, *) READ(*, '(a)') in_text READ(in_text, *) c(1:n) CALL smplx (a, b, c, 9, m, n, ind, ibasis, x, z, iter, mxiter, & numle, numge, bi, rerr) WRITE(*, '(a, i2, a, i3)') ' IND = ', ind, ' No. of iterations = ', iter IF (ind == 0 .OR. i== 6) THEN WRITE(*, '(a, 9f7.2)') ' Solution: ', x(1:n) WRITE(*, '(a, f8.2)') ' Value of objective = ', z WRITE(*, *) 'The inverse matrix:' DO i = 1, m WRITE(*, '(9f8.3)') bi(i,1:m) END DO END IF WRITE(*, '(a, g12.4)') ' Relative error = ', rerr STOP END PROGRAM test_smplx