PROGRAM PRICE
C  ---------------------------------------------------------------------
C  PRICE v1.0,  Mar 2003
C  
C  This program implements a modification of Price's global
C  optimization algorithm, described in:
C
C    W.L Price, A controlled random search procedure for global
C    optimization, Towards Global Optimization 2, L.C.W. Dixon and
C    G.P Szego (eds.), North-Holland, Amsterdam.
C
C  See also:
C
C    P.Brachetti, M.De Felice Ciccoli, G.Di Pillo and S. Lucidi, A new
C    version of Price's algorithm for global optimization, Journal of
C    Global Optimization, 10 (1997) 165-184.
C
C  Newer versions of this code are available from:
C  http://nrt.cs.uoi.gr/merlin
C
C  ---------------------------------------------------------------------
	IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C  Maximum number of objective function parameters.
	PARAMETER ( MAXNOD = 100 )
C  Maximum random sample size.
	PARAMETER ( MAXFAC = 100 )
C  ---------------------------------------------------------------------
C  Input file.
	CHARACTER*(*) INFIL
	PARAMETER ( INFIL  = 'PRICE.DAT'  )
C  ---------------------------------------------------------------------
C  Workspaces:
	PARAMETER ( MM = MAXFAC*MAXNOD )
	DIMENSION F(MM), INN(MM)
	DIMENSION POINT(MAXNOD), XLL(MAXNOD), XRL(MAXNOD), IXAT(MAXNOD)
	DIMENSION XT2(MAXNOD), XT3(MAXNOD), XT4(MAXNOD)
	DIMENSION XT5(MAXNOD), XT6(MAXNOD), XT7(MAXNOD)
	DIMENSION INDE(MAXNOD), IW2(MAXNOD+1)
	DIMENSION V(MAXNOD,MM)
C  Local variables:
	CHARACTER*80 MESS
	CHARACTER*20 OUTFIL, POIFIL, FINP, FOUT
	LOGICAL EXI1, EXI2, ERR
	DIMENSION ICODE(4)
C  ---------------------------------------------------------------------
C  Default values for the input parameters.
	DATA NOD    / 2 /
	DATA NOC    / 10000 /
	DATA EPS    / 1.D-4 /
	DATA OMEGA  / 10000. /
	DATA NF     / 20 /
	DATA IPRINT / 1 /
	DATA NFORM  / 1 /
	DATA OUTFIL / 'PRICE.OUT' /
	DATA POIFIL / 'POIMAR.DAT' /
	DATA FINP   / 'in.dat' /
	DATA FOUT   / 'out.dat' /
C  Default values for bounds and fix statuses.
	DATA XLL  / MAXNOD * -1.D0 /
	DATA XRL  / MAXNOD *  1.D0 /
	DATA IXAT / MAXNOD *  1    /
	DATA ICODE  / 1, 1, 1, 1 /
C  ---------------------------------------------------------------------
C  Check if the input file exists.
	INQUIRE (FILE=INFIL,EXIST=EXI1)
	IF (EXI1) THEN
C  Open and read the data file.
		OPEN (1,FILE=INFIL,STATUS='OLD')
		READ (1,*) NOD
		READ (1,*) NOC
		READ (1,*) EPS
		READ (1,*) OMEGA
		READ (1,*) NF
		READ (1,*) IPRINT
		READ (1,*) NFORM
		READ (1,'(A)') OUTFIL
		READ (1,'(A)') POIFIL
		READ (1,'(A)') FINP
		READ (1,'(A)') FOUT
		CLOSE (1)
	ELSE
C  Create a sample input file with default values.
		OPEN (1,FILE=INFIL,STATUS='NEW')
		WRITE (1,'(I8,T25,A)')       NOD,    'NOD'
		WRITE (1,'(I8,T25,A)')       NOC,    'NOC'
		WRITE (1,'(1PG21.14,T25,A)') EPS,    'EPS'
		WRITE (1,'(1PG21.14,T25,A)') OMEGA,  'OMEGA'
		WRITE (1,'(I8,T25,A)')       NF,     'NF'
		WRITE (1,'(I8,T25,A)')       IPRINT, 'IPRINT'
		WRITE (1,'(I8,T25,A)')       NFORM,  'NFORM'
		WRITE (1,'(A,T25,A)')        OUTFIL,  'OUTFIL'
		WRITE (1,'(A,T25,A)')        POIFIL,  'POIFIL'
		WRITE (1,'(A,T25,A)')        FINP,    'in.dat'
		WRITE (1,'(A,T25,A)')        FOUT,    'out.dat'
		CLOSE (1)
		WRITE (*,*) 'PRICE: File ', INFIL,
     &	            ' is created with default values.'
		CLOSE (1)
	END IF
C
C  Check if the parameter file exists.
	INQUIRE (FILE=POIFIL,EXIST=EXI2)
	IF (EXI2) THEN
C  Read parameter bounds.
		OPEN (1,FILE=POIFIL,STATUS='OLD')
		DO 10,I=1,NOD
			READ (1,*) POINT(I), XLL(I), XRL(I), IXAT(I)
10		CONTINUE
		CLOSE (1)
	ELSE
C  Create a sample parameter file with default values.
		OPEN (1,FILE=POIFIL,STATUS='NEW')
		DO 90,I=1,NOD
			POINT(I) = 2*RANM()-1.
			WRITE (1,120) POINT(I), XLL(I), XRL(I), IXAT(I)
90		CONTINUE
		CLOSE (1)
		WRITE (*,*) 'PRICE: File ', POIFIL,
     &	            ' is created with default values.'
	END IF
C
C  Check if the input is meaningful.
	ERR = .FALSE.
	IF (NOD.LT.1 .OR. NOD.GT.MAXNOD) THEN
		WRITE (*,*) 'PRICE: Incorrect dimensionality ', NOD
		ERR = .TRUE.
	END IF
C
	IF (NOC.LT.NOD) THEN
		WRITE (*,*) 'PRICE: Incorrect number of calls ', NOC
		ERR = .TRUE.
	END IF
C
	IF (EPS.LE.0. .OR. EPS.GE.1.) THEN
		WRITE (*,*) 'PRICE: Incorrect epsilon ', EPS
		ERR = .TRUE.
	END IF
C
	IF (OMEGA.LT.1) THEN
		WRITE (*,*) 'PRICE: Incorrect weighting factor ', OMEGA
		ERR = .TRUE.
	END IF
C
	IF (IPRINT.NE.0 .AND. IPRINT.NE.1) THEN
		WRITE (*,*) 'PRICE: Incorrect printout option ', IPRINT
		ERR = .TRUE.
	END IF
C
	IF (NF.LT.1 .OR. NF.GT.MAXFAC) THEN
		WRITE (*,*) 'PRICE: Incorrect sample size factor ', NF
		ERR = .TRUE.
	END IF
C
	IF (NFORM.NE.0 .AND. NFORM.NE.1 .AND. NFORM.NE.2) THEN
		WRITE (*,*) 'PRICE: Incorrect output format ', NFORM
		ERR = .TRUE.
	END IF
C
	IF (FINP.EQ.' ') THEN
		WRITE (*,*) 'PRICE: Merlin input file not specified.'
		ERR = .TRUE.
	END IF
C
	IF (FOUT.EQ.' ') THEN
		WRITE (*,*) 'PRICE: Merlin output file not specified.'
		ERR = .TRUE.
	END IF
C
C  Check if parameters, bounds and fix statuses are meaningful.
	DO 100,I=1,NOD
		IF (XLL(I).GE.XRL(I)) THEN
			WRITE (*,*) 'PRICE: Incorrect bounds for parameter ', I
			ERR = .TRUE.
		ELSE IF (POINT(I).LT.XLL(I) .OR. POINT(I).GT.XRL(I)) THEN
			WRITE (*,*) 'PRICE: Out of bounds parameter ', I
			ERR = .TRUE.
		END IF
		IF (IXAT(I).NE.0 .AND. IXAT(I).NE.1) THEN
			WRITE (*,*) 'PRICE: Incorrect fix status for variable ', I
			ERR = .TRUE.
		END IF
100	CONTINUE
C
C  Missing input files ?
	IF (.NOT. (EXI1.AND.EXI2)) THEN
		WRITE (*,*) 'PRICE: Please edit the input files ',
     &	            'to provide the desired input.'
		STOP
	END IF
C
C  Any error ?
	IF (ERR) STOP
C
C  Print running parameters.
	WRITE (*,20)
	WRITE (*,50) 'PRICE running with ...'
	WRITE (*,50) 'Number of parameters:   ', NOD
	WRITE (*,50) 'Maximum function calls: ', NOC
	WRITE (*,60) 'Termination criterion:  ', EPS
	WRITE (*,60) 'Weighting factor:       ', OMEGA
	WRITE (*,50) 'Sample size factor:     ', NF
	WRITE (*,50) 'Printout option:        ', IPRINT
	WRITE (*,80) 'Output file:            '//OUTFIL
	WRITE (*,80) 'Bounds file:            '//POIFIL
	WRITE (*,80) 'Merlin input file:      '//FINP 
	WRITE (*,80) 'Merlin output file:     '//FOUT 
	WRITE (*,50) 'Output format:          ', NFORM
	WRITE (*,20)
C
C  Call the actual minimizer.
	M = NF*NOD
	CALL PRCGL(NOD,M,XLL,XRL,IXAT,V,NOC,EPS,OMEGA,NOCEX,POINT,FMIN,
     &           ITER,XT2,XT3,XT4,XT5,XT6,XT7,IW2,INN,F,IPRINT,INFO)
C
C  Construct a message describing the reason for termination.
	IF (INFO.EQ.1) THEN
		MESS = 'The termination criterion has been satisfied'
	ELSE IF (INFO.EQ.2) THEN
		MESS = 'All function evaluations have been used'
	ELSE
		WRITE (*,*) 'PRICE: Incorrect "info".'
		STOP
	END IF
C
C  Call Merlin to refine the minimum.
	CALL OPTIMA(NOD,NOF,POINT,VAL,XLL,XRL,IXAT,ICODE,FINP,FOUT,
     &            GRMS,NF,NG,NH,NJ)
	NOCEX = NOCEX+NF
C
C  Report the reason for termination.
	LE1 = LENGTH(MESS)
      IF (IPRINT.NE.0) WRITE (*,20)
	WRITE (*,80) MESS(1:LE1)
	WRITE (*,70) 'Function value:      ', VAL
	WRITE (*,50) 'Total function evaluations:', NOCEX
	WRITE (*,50) 'PRICE Iterations:          ', ITER
	WRITE (*,70) 'The minimum has been refined by Merlin, GRMS = ',
     &            GRMS
	WRITE (*,80) 'Output parameters in file: '//OUTFIL
      WRITE (*,20)
C
C  Write the output file.
	IF (NFORM.EQ.0) THEN
C  Raw unformatted output.
		OPEN (1,FILE=OUTFIL,FORM='UNFORMATTED')
		DO 130,I=1,NOD
			WRITE (1) POINT(I)
130		CONTINUE
		WRITE (1) VAL
		CLOSE (1)
	ELSE IF (NFORM.EQ.1) THEN
C  Raw formatted output.
		OPEN (1,FILE=OUTFIL)
		DO 40,I=1,NOD
			WRITE (1,30) POINT(I)
40		CONTINUE
		WRITE (1,30) VAL
		CLOSE (1)
	ELSE
C  Output suitable for Merlin.
		OPEN (1,FILE=OUTFIL)
		WRITE (1,*) NOD
		CALL WRITER(POINT,VAL,1,1,0)
		CLOSE (1)
	END IF
C
20    FORMAT (79('-'))
30	FORMAT (1PG21.14)
50	FORMAT (A,1X,I6)
60	FORMAT (A,1X,1PG11.4)
70	FORMAT (A,1X,1PG21.14)
80	FORMAT (A)
120	FORMAT (F8.5,3X,2(F4.1,3X),I1)
C
	END
C  ---------------------------------------------------------------------
	SUBROUTINE PRCGL ( N, M, XL, XR, IXAT, S, NOC, EPS, OMEGA, NOE,
     &                   XMIN, FMIN, K, X, XMAX, Y, ZU, WN, CW, IRN, 
     &                   INN, F, IPRINT, INFO )
C  ---------------------------------------------------------------------
C
C  Description:
C    This is an implementation of the improved Price algorithm
C    for global optimization.
C
C  Input arguments:
C    N          Dimensionality of the problem.
C    M          Size of the random sample (number of random points).
C    XL         Left margins.
C    XR         Right margins.
C    IXAT       Fix statuses.
C    NOC        Maximum number of calls allowed.
C    EPS        Termination tolerance.
C    OMEGA      Weigthing factor.
C    IPRINT     Printout level.
C                 IPRINT = 0 -> No printout at all.
C                 IPRINT = 1 -> Just the function value.
C                 IPRINT = 2 -> Function and parametervalues as well.
C
C  Output arguments:
C    NOE        Number of function calls that have been performed.
C    K          Iteration that have been performed.
C    INFO       Error indicator.
C                 INFO = 1 -> The routine terminated because
C                             F_max - F_min < EPS.
C                 INFO = 2 -> The routine terminated because all
C                             available function calls (NOC)
C                             have been used.
C
C  Input / Output arguments:
C    XMIN       On input the current point. On output the point that
C               gives the least value (even if not always lower than
C               the current point).
C    FMIN       =FUNMIN(XMIN,NOD)
C
C  Workspaces:
C    X(N), XMAX(N), Y(N), ZU(N), WN(N), CW(N), IRN(0:N), INN(M)
C
C  ---------------------------------------------------------------------
	IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C  Arguments:
	DIMENSION S(N,*), XL(N), XR(N), IXAT(N)
	DIMENSION X(N), XMAX(N), XMIN(N), Y(N), ZU(N), WN(N), CW(N)
	DIMENSION IRN(0:N), F(M), INN(M)
C  ---------------------------------------------------------------------
C  Local variables:
	LOGICAL CHECK
C  ---------------------------------------------------------------------
C
C  Iterations done so far.
	K = 0
C
C  Number of function calls so far.
	NOE = 0
C
C  Number of function calls that lead to a new lower upper bound.
	NOSE = 0
C  =======
C  Step 0:
C  =======
C
C  Initialize the set S by sampling randomly M points.
	CALL RSAMP(S,N,M,XL,XR,IXAT,XMIN)
C
C  Evaluate the function at each point and collect the values.
	DO 2,I=1,M
		DO 40,J=1,N
			X(J) = S(J,I)
40		CONTINUE
		F(I) = FUNMIN(X,N)
2	CONTINUE
	NOE = NOE+M
C  =======
C  Step 1:
C  =======
101	CONTINUE
	CALL MINMAX(F,M,FMIN,IN,FMAX,IX)
	IF (K .EQ. 0) THEN
		FMAX0 = FMAX
		FMIN0 = FMIN
		VAL = FMIN
	END IF
	DO 10,I=1,N
		XMAX(I) = S(I,IX)
		XMIN(I) = S(I,IN)
10	CONTINUE
	IF (FMIN.LT.VAL) THEN
		CALL PMDIS(FMIN,K,NOE,NOC,IPRINT)
		VAL = FMIN
	END IF
	TEST = FMAX - FMIN
	IF (TEST .LT. EPS ) THEN
		INFO = 1
		RETURN
	ELSE IF ( NOE .GE. NOC) THEN
		INFO = 2
		RETURN
	END IF
C  =======
C  Step 2:
C  =======
C
102	CONTINUE
C
C  Pick N+1 integers from 1 to M randomly. Store them in IRN(0:N).
	CALL INTRAN(M,N,IRN,INN)
	PHI = OMEGA*(FMAX-FMIN)**2/(FMAX0-FMIN0)
	DO 20,I=1,N
		IP = IRN(I)
		ZU(I) = 1./(F(IP)-FMIN+PHI)
20	CONTINUE
	CALL ZUNOR(ZU,N,WN)
	DO 21,I=1,N
		CW(I) = 0
		DO 22 J=1,N
			CW(I) = CW(I) + WN(J)*S(I,IRN(J))
22		CONTINUE
21	CONTINUE
	FW = 0
	DO 23,I=1,N
		FW = FW + WN(I)*F(IRN(I))
23	CONTINUE
	I0 = IRN(0)
	FAC = (F(I0)-FW)/(FMAX-FMIN+PHI)
	IF (FW .LE. F(I0)) THEN
		DO 24,I=1,N
			X(I) = (S(I,I0)-CW(I))*FAC+2*CW(I)-S(I,I0)
24		CONTINUE
	ELSE
		DO 25,I=1,N
			X(I) = (S(I,I0)-CW(I))*FAC+2*S(I,I0)-CW(I)
25		CONTINUE
	END IF
	CALL DOMAIN(X,N,XL,XR,CHECK)
	IF (CHECK) THEN
		FC = FUNMIN(X,N)
		NOE = NOE + 1
		IF (NOE .GE. NOC) GOTO 101
	ELSE
		GOTO 102
	END IF
C  =======
C  Step 3:
C  =======
103	CONTINUE
	IF (FC .GE. FMAX) THEN
		RATE = REAL(NOSE)/NOE
		IF (RATE .GT. 0.5) THEN
			K = K+1
			GOTO 102
		END IF
		DO 30,I=1,N
			Y(I) = ( CW(I)+S(I,IRN(N)) )/2.
30		CONTINUE
		FY = FUNMIN(Y,N)
		NOE = NOE + 1
		IF (FY .GE. FMAX) THEN
			K = K+1
			GOTO 102
		ELSE
			NOSE = NOSE + 1
			CALL REPLAC(S,N,M,IX,Y)
			F(IX) = FY
			K = K+1
			GOTO 101
		END IF
	END IF
	NOSE = NOSE + 1
	CALL REPLAC(S,N,M,IX,X)
	F(IX) = FC
	K = K+1
	GOTO 101
C
	END
C  ---------------------------------------------------------------------
	SUBROUTINE RSAMP ( S, N, M, XL, XR, IXAT, X )
C  ---------------------------------------------------------------------
C
C  Description:
C    Part of the PRICE global optimization method.
C    This routine samples at random M points in the N-dimensional
C    space, inside the N-dimensional box defined by the bounds
C    XL (lower) and XR (upper).
C    Fixed variables (IXAT(I)=0) remain at their current value
C    as supplied in X.
C
C  ---------------------------------------------------------------------
	IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C  ---------------------------------------------------------------------
C  Arguments:
	DIMENSION S(N,*)
	DIMENSION XL(N), XR(N), IXAT(N), X(N)
C  ---------------------------------------------------------------------
C
	DO 1,IP=1,M
		DO 2,I=1,N
			IF (IXAT(I).NE.0) THEN
				S(I,IP) = RANDI(XL(I),XR(I))
			ELSE
				S(I,IP) = X(I)
			END IF
2		CONTINUE
1	CONTINUE
	END
C  ---------------------------------------------------------------------
	SUBROUTINE MINMAX ( F, M, FMIN, IN, FMAX, IX )
C  ---------------------------------------------------------------------
C
C  Description:
C    Part of the PRICE global optimization method.
C    Calculates the minimum and the maximum numbers contained
C    in array F, and the corresponding indices.                         
C
C  Input arguments:
C    F      The input array.
C    M      The number of elements to be considered. F(1) through F(M).
C
C  Output arguments:
C    FMIN   The minimum of the numbers in F.
C    IN     The location of FMIN inside the array F. (FMIN = F(IN))
C    FMAX   The maximum of the numbers in F.
C    IX     The location of FMAX inside the array F. (FMAX = F(IX))
C
C  Notes:
C    In case of multiple minima or maxima, the lowest indices
C    are returned for IN and IX.
C
C  ---------------------------------------------------------------------
	IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C  ---------------------------------------------------------------------
C  Arguments:
	DIMENSION F(M)
C  ---------------------------------------------------------------------
C
	IN = 1
	IX = 1
	FMIN = F(IN)
	FMAX = F(IX)
	DO 10,I=2,M
		FC = F(I)
		IF (FC .LT. FMIN) THEN
			FMIN = FC
			IN = I
		END IF
		IF (FC .GT. FMAX) THEN
			FMAX = FC
			IX = I
		END IF
10	CONTINUE
	END
C  ---------------------------------------------------------------------
	SUBROUTINE INTRAN ( M, N, IRN, INN )
C  ---------------------------------------------------------------------
C
C  Description:
C    Part of the PRICE global optimization method.
C    Picks N+1 integers from the set {1,2, ...,M} at random.
C    These integers are returned in IRN(0:N).
C    The way this is done is described by the following steps:
C    1. Put the numbers 1, 2, ..., M in their natural order in 
C       an array INN.
C    2. Draw a random number IR from 1 to M.
C    3. The number INN(IR) is set as one of the numbers to choose.
C       (array IRN).
C    4. Delete this number from the INN array and decrement its 
C       population by one.
C    5. Shift all positions so that there is no "hole" at the
C       deleted position.
C    6. Set M = M-1 and repeat N+1 times.
C
C  ---------------------------------------------------------------------
	IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C  Arguments:
	DIMENSION IRN(0:N)
C  ---------------------------------------------------------------------
C  Local variables:
	DIMENSION INN(M)
C  ---------------------------------------------------------------------
C
	DO 1,I=1,M
		INN(I) = I
1	CONTINUE
	IPOP = M
	DO 2,I=0,N
		XSI = RANM()
		IR = 1 + INT(IPOP*XSI)
		IRN(I) = INN(IR)
		IPOP = IPOP-1
		DO 20,J=IR,IPOP
			INN(J) = INN(J+1)
20		CONTINUE
2	CONTINUE
	END
C  ---------------------------------------------------------------------
	SUBROUTINE ZUNOR ( ZU, N, WN )
C  ---------------------------------------------------------------------
C
C  Description:
C    Part of the PRICE global optimization method.
C    Normalizes the array elements ZU(i).
C    Normalization here means: WN(i) = ZU(i)/{Sum_over_j=1,N ZU(j)}
C
C  ---------------------------------------------------------------------
	IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C  Arguments:
	DIMENSION ZU(N), WN(N)
C  ---------------------------------------------------------------------
C
	DEN = 0.
	DO 1,I=1,N
		DEN = DEN + ZU(I)
1	CONTINUE
C
	DO 2,I=1,N
		WN(I) = ZU(I)/DEN
2	CONTINUE
	END
C  ---------------------------------------------------------------------
	SUBROUTINE DOMAIN ( X, N, XL, XR, CHECK )
C  ---------------------------------------------------------------------
C
C  Description:
C    Part of the PRICE global optimization method.
C    Checks if point X is inside the domain.
C    I.e. checks if X(i) is contained in [XL(i), XR(i)], i=1,2,..,N
C
C  Input arguments:
C    X       The input array to be checked.
C    N       The elements of X to be considered. X(1) through X(N).
C    XL      The array containing the lower bounds. (Left margins)
C    XR      The array containing the upper bounds. (Right margins)
C
C  Output arguments:
C    CHECK   Logical variable.
C            CHECK = .TRUE.  -> X belongs to the domain.
C            CHECK = .FALSE. -> X does not belong to the domain.
C
C  ---------------------------------------------------------------------
	IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C  Arguments:
	LOGICAL CHECK
	DIMENSION X(N), XL(N), XR(N)
C  ---------------------------------------------------------------------
C
	CHECK = .TRUE.
	DO 1,I=1,N
		IF (X(I) .LT. XL(I)) THEN
			CHECK = .FALSE.
			RETURN
		END IF
		IF (X(I) .GT. XR(I)) THEN
			CHECK = .FALSE.
			RETURN
		END IF
1	CONTINUE
	END
C  ---------------------------------------------------------------------
	SUBROUTINE REPLAC ( S, N, M, JC, P )
C  ---------------------------------------------------------------------
C
C  Description:
C    Part of the PRICE global optimization method.
C    Replaces in the N x M matrix S, the JC column (N rows)
C    by the N-vector P.
C
C  ---------------------------------------------------------------------
	IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C  Arguments:
	DIMENSION S(N,M), P(N)
C  ---------------------------------------------------------------------
C
	DO 1,I=1,N
		S(I,JC) = P(I)
1	CONTINUE
	END
C  ---------------------------------------------------------------------
	SUBROUTINE PMDIS ( VAL, ITER, NOC, MAXNOC, IPRINT )
C  ---------------------------------------------------------------------
C
C  Description:
C    Issues informative messages during a minimization session.
C    Normally, it is called when a lower value is discovered. 
C
C  Input arguments:
C    VAL        Value of the objective function.
C    ITER       Number of iterations that have been performed by the
C               calling routine.
C    NOC        Number of function evaluations that have been performed 
C               by the calling routine.
C    MAXNOC     The calling routine is allowed MAXNOC calls at most.
C    IPRINT     Printout level:
C               IPRINT = 0 -> Nothing is printed.
C               IPRINT = 1 -> Simple printout: Prints ITER, VAL,
C                             NOC, MAXNOC
C
C  ---------------------------------------------------------------------
	IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C  ---------------------------------------------------------------------
C  Local variables:
	CHARACTER*10 C1, C2, C3
	CHARACTER*23 CVAL
C  ---------------------------------------------------------------------
C
	IF (IPRINT.EQ.0) RETURN
C
	CALL I2STR(ITER,C1,LE1)
	CALL I2STR(NOC,C2,LE2)
	WRITE (CVAL,'(1PG21.14)') VAL
	IF (NOC.LE.MAXNOC) THEN
		CALL I2STR(MAXNOC,C3,LE3)
		WRITE (*,10) C1(1:LE1), CVAL,
     &                             C2(1:LE2), C3(1:LE3)
	ELSE
		WRITE (*,10) C1(1:LE1), CVAL, C2(1:LE2)
	END IF
C
10	FORMAT (1X,'Iter: ',A,3X,'Lower value:',3X,A,
     &        3X,'Calls: ',A:,' of ',A)
	END