*DECK PLQ
      SUBROUTINE PLQ(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY)
*
*-----------------------------------------------------------------------
*
*Purpose:
* solves a linear optimization problem with a quadratic constraint.
* PLQ = Quasi Linear Programmation 
*
*Copyright:
* Copyright (C) 2002 Ecole Polytechnique de Montreal
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
* License as published by the Free Software Foundation; either
* version 2.1 of the License, or (at your option) any later version
*
*Author(s): R. Chambon
*
*Parameters: input/ouput
* NENTRY  number of LCM objects or files used by the operator.
* HENTRY  name of each LCM object or file:
*         HENTRY(1): creation type(L_OPTIMIZE).
* IENTRY  type of each LCM object or file:
*         =1 LCM memory object; =2 XSM file; =3 sequential binary file;
*         =4 sequential ascii file.
* JENTRY  access of each LCM object or file:
*         =0 the LCM object or file is created;
*         =1 the LCM object or file is open for modifications;
*         =2 the LCM object or file is open in read-only mode.
* KENTRY  LCM object address or file unit number.
*                          
*-----------------------------------------------------------------------
*
      USE GANLIB
      IMPLICIT  NONE
*----
*  SUBROUTINE ARGUMENTS
*----
      INTEGER      NENTRY,IENTRY(NENTRY),JENTRY(NENTRY)
      TYPE(C_PTR)  KENTRY(NENTRY)
      CHARACTER    HENTRY(NENTRY)*12
*----
*  LOCAL VARIABLES
*----
      INTEGER   NITMA,ITYP,ITYP1
      DOUBLE PRECISION DFLOTT
      REAL      FLOTT
      CHARACTER TEXT12*12,HSIGN*12
      INTEGER   NSTATE
      PARAMETER (NSTATE=40)
      INTEGER   OPTPRI(NSTATE)
      REAL      OPTPRR(NSTATE)
      TYPE(C_PTR) IPOPT
      INTEGER   I,NVAR,NCST,LENGT,IPRINT,NSTPEX,IMTHD,M0,MINMAX,CNVTST,
     1          IERR,CONV
      REAL      XDROIT,XS,XXS,EPS4,EPSIM,ECOST,DELTA,S,NORM,EPSEXT
      DOUBLE PRECISION  FCOST
      LOGICAL   LSAVE,LNORM2,LWAR
      REAL      COST,CQUAD
*----
*  ALLOCATABLE ARRAYS
*----
      INTEGER, ALLOCATABLE, DIMENSION(:) :: INEGAL
      REAL, ALLOCATABLE, DIMENSION(:) :: VARVAL,VARWGT,FCSTV,GRAD,ODX,
     > ODF,DX,CONTR,VALMAX,VALMIN,DINF,DSUP,VARVL2,GRAD0
*----
*  CHECK THE VALIDITY OF OBJECTS
*----
      IF(NENTRY.NE.1) CALL XABORT('PLQ:ONE OBJECT EXPECTED.')
      IF(JENTRY(1).NE.1) CALL XABORT('PLQ: OBJECT IN MODIFICATION '
     1  //'MODE ONLY')
      IPOPT=KENTRY(1)
      IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2))CALL XABORT('PLQ:'
     1      //' LCM OBJECT EXPECTED')
      CALL LCMGTC(KENTRY(1),'SIGNATURE',12,1,HSIGN)
      IF(HSIGN.NE.'L_OPTIMIZE') THEN
         TEXT12=HENTRY(1)
         CALL XABORT('PLQ: SIGNATURE OF '//TEXT12//' IS '//HSIGN//
     1   '. L_OPTIMIZE EXPECTED.')
      ENDIF
*----
*  RECOVER STATE VECTOR INFORMATION	
*----
      CALL LCMGET(IPOPT,'STATE-VECTOR',OPTPRI)
      NVAR  =OPTPRI(1)
      NCST  =OPTPRI(2)
      MINMAX=OPTPRI(3)
      IF((MINMAX.NE.1).AND.(MINMAX.NE.-1)) CALL XABORT('PLQ: '
     1  //'MINMAX not equal to 1 or -1')
      NSTPEX=OPTPRI(5)
      IMTHD =OPTPRI(9)
      CALL LCMGET(IPOPT,'OPT-PARAM-R',OPTPRR)
      S     =OPTPRR(1)
      ECOST =OPTPRR(6)
      EPSEXT=OPTPRR(3)
      EPSIM =OPTPRR(4)
      EPS4  =OPTPRR(5)
*----
*  SET CONTROL-VARIABLE VALUES
*----
      ALLOCATE(VARVAL(NVAR))
      CALL LCMLEN(IPOPT,'VAR-VALUE',LENGT,ITYP)
      IF(LENGT.NE.NVAR) CALL XABORT('PLQ: WRONG NUMBER OF VARIABLE')
      CALL LCMGET(IPOPT,'VAR-VALUE',VARVAL)
*----
*  SET CONTROL-VARIABLE WEIGHTS
*----
      ALLOCATE(VARWGT(NVAR))
      CALL LCMLEN(IPOPT,'VAR-WEIGHT',LENGT,ITYP)
      IF(LENGT.EQ.0) THEN
         CALL XDRSET(VARWGT,NVAR,1.0)
      ELSEIF(LENGT.EQ.NVAR) THEN
         CALL LCMGET(IPOPT,'VAR-WEIGHT',VARWGT)
      ELSE
         CALL XABORT('PQL: NVAR - LENGT ARE NOT THE SAME')
      ENDIF
*----
*  SET SYSTEM CHARACTERISTICS (THE OBJECTIVE FUNCTION IS THE FIRST ONE)
*----
      ALLOCATE(FCSTV(NCST+1))
      CALL LCMLEN(IPOPT,'FOBJ-CST-VAL',LENGT,ITYP)
      IF(LENGT.EQ.0) CALL XABORT('PLQ: OBJECTIVE FUNCTION AND CONSTRA'
     1  //'INTS NOT YET EVALUATED')
      CALL LCMGET(IPOPT,'FOBJ-CST-VAL',FCSTV)
      COST=FCSTV(1)
*----
*  SET GRADIENTS
*----
      ALLOCATE(GRAD(NVAR*(NCST+1)))
      CALL LCMGET(IPOPT,'GRADIENT',GRAD)
*----
*  MEMORY ALLOCATION
*----
      ALLOCATE(ODX(NVAR),ODF(NVAR))
      IPRINT=0
      LWAR=.FALSE.
      CONV=-99
*----
*  READ USER INPUT:
*----
   20 CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT)
*     Edition level
   30 IF(ITYP.NE.3) CALL XABORT('PLQ: CHARACTER EXPECTED')
      IF(TEXT12.EQ.'EDIT') THEN
         CALL REDGET(ITYP,IPRINT,FLOTT,TEXT12,DFLOTT)
         IF(ITYP.NE.1) CALL XABORT('PLQ: *IPRINT* MUST BE INTEGER')
      ELSEIF(TEXT12.EQ.'WARNING-ONLY')THEN
*        Warning Only for failure of recovery of a valid point
         LWAR=.TRUE.
      ELSEIF(TEXT12.EQ.'CALCUL-DX')THEN
*        Calculation of next point
         GO TO 100
      ELSEIF(TEXT12.EQ.'COST-EXTRAP')THEN
*        Cost extrapolation
         GO TO 200
      ELSEIF(TEXT12.EQ.'CONV-TEST') THEN
*        Convergence test
         GO TO 300
      ELSEIF( TEXT12.EQ.';' )THEN
*        End of this subroutine
         GO TO 1000
      ELSE
         CALL XABORT('PLQ: '//TEXT12//' IS AN INVALID KEYWORD.')
      ENDIF
      GO TO 20
*----
*  NEXT STEP CALCULATION
*----
  100 CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT)
      IF(TEXT12.EQ.'NO-STORE-OLD') THEN
         LSAVE=.TRUE.
         CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT)
      ELSE
         LSAVE=.FALSE.
      ENDIF
      ITYP1=ITYP
      ALLOCATE(DX(NVAR))
      FCOST=DBLE(COST)
      IF(NCST.GT.0) THEN
*        INEQUAL
         ALLOCATE(INEGAL(NCST))
         CALL LCMLEN(IPOPT,'CST-TYPE',LENGT,ITYP)
         IF(LENGT.NE.NCST) CALL XABORT('PLQ: NCST - LENGT NOT EQUAL')
         CALL LCMGET(IPOPT,'CST-TYPE',INEGAL)
*
*        CONTR
         ALLOCATE(CONTR(NCST))
         CALL LCMLEN(IPOPT,'CST-OBJ',LENGT,ITYP)
         IF(LENGT.NE.NCST) CALL XABORT('PLQ: NCST - LENGT NOT EQUAL')
         CALL LCMGET(IPOPT,'CST-OBJ',CONTR)
         DO 110 I=1,NCST
  110    CONTR(I) = CONTR(I)-FCSTV(I+1)
      ENDIF
*
*   DINF AND DSUP
      CALL LCMLEN(IPOPT,'VAR-VAL-MAX',LENGT,ITYP)
      IF(LENGT.EQ.0) CALL XABORT('PLQ: NO MAXIMUM VALUE DEFINED')
      ALLOCATE(VALMAX(NVAR),VALMIN(NVAR))
      CALL LCMGET(IPOPT,'VAR-VAL-MAX',VALMAX)
      CALL LCMLEN(IPOPT,'VAR-VAL-MIN',LENGT,ITYP)
      IF(LENGT.EQ.0) CALL XABORT('PLQ: NO MAXIMUM VALUE DEFINED')
      CALL LCMGET(IPOPT,'VAR-VAL-MIN',VALMIN)
      ALLOCATE(DINF(NVAR),DSUP(NVAR))
      DO 115 I=1,NVAR
         DINF(I) = VALMIN(I) - VARVAL(I)
  115    DSUP(I) = VALMAX(I) - VARVAL(I)
      DEALLOCATE(VALMAX,VALMIN)
*
      M0     = NCST
      XDROIT = S**2
      IF(IPRINT.GE.1) WRITE(6,40001) XDROIT,(VARWGT(I),I=1,NVAR)
*----
*  FIND ACTIVE CONSTRAINTS FOR XK(I) LIMITS
*----
      DO 140 I=1,NVAR
         XS = SQRT(XDROIT/VARWGT(I))
         XXS=-XS
         IF(DINF(I).GT.XXS) THEN
            M0 = M0 + 1
         ENDIF
         IF(DSUP(I).LT.XS) THEN
            M0 = M0 + 1
         ENDIF
  140    CONTINUE
*----
*  SOLUTION OF A LINEAR OPTIMIZATION PROBLEM WITH A QUADRATIC CONSTRAINT
*----
      IERR=0
      CALL PLDRV(IPOPT,NVAR,NCST,M0,MINMAX,IMTHD,FCOST,DX,VARWGT,GRAD,
     > INEGAL,CONTR,DINF,DSUP,XDROIT,EPSIM,IPRINT,IERR)
*----
*  STEP-BACK IN CASE OF FAILURE
*----
      IF(IERR.GE.1) THEN
         OPTPRI(13)=OPTPRI(13)+1
         CALL LCMSIX(IPOPT,'OLD-VALUE',1)
         CALL LCMLEN(IPOPT,'VAR-VALUE2',LENGT,ITYP)
         IF(LENGT.EQ.0) THEN
            IF(LWAR) THEN
               WRITE(6,*) 'WARNING: UNABLE TO RECOVER A VALID POINT'
     1         //' WITH SUCCESSFUL "PLQ" RESOLUTION'
            ELSE
               CALL LCMLIB(IPOPT)
               CALL XABORT('PLQ: UNABLE TO RECOVER A VALID POINT WITH '
     1         //'SUCCESSFUL "PLQ" RESOLUTION')
            ENDIF
         ELSE
            ALLOCATE(VARVL2(NVAR))
            CALL LCMGET(IPOPT,'VAR-VALUE2',VARVL2)
            DO 156 I=1,NVAR
  156       DX(I)=(VARVL2(I)-VARVAL(I))/2.0
            DEALLOCATE(VARVL2)
         ENDIF
         IF(IPRINT.GE.1) WRITE(6,*) 'IERR>0'
         IF(IPRINT.GE.1) WRITE(6,*) 'DX=',(DX(I),I=1,NVAR)
      ELSE
         OPTPRI(13)=0
      ENDIF
*
      DO 157 I=1,NVAR
         ODX(I)=DX(I)
  157    ODF(I)=GRAD(I)
      DEALLOCATE(DX)
      IF(NCST.GT.0) DEALLOCATE(INEGAL)
      DEALLOCATE(DINF,DSUP)
      IF(NCST.GT.0) DEALLOCATE(CONTR)
*----
*  BACKUP VALUES OF THE PRECEDING ITERATION
*----
      IF(.NOT.LSAVE) THEN
         CALL LCMSIX(IPOPT,' ',0)
         CALL LCMSIX(IPOPT,'OLD-VALUE',1)
         CALL LCMPUT(IPOPT,'VAR-VALUE',NVAR,2,VARVAL)
         CALL LCMPUT(IPOPT,'FOBJ-CST-VAL',NCST+1,2,FCSTV)
         CALL LCMPUT(IPOPT,'GRADIENT',NVAR*(NCST+1),2,GRAD)
         CALL LCMSIX(IPOPT,' ',0)
      ENDIF
*----
*  BACKUP VALUES OF THE NEW ITERATION
*----
      DO 180 I=1,NVAR
  180 VARVAL(I)=VARVAL(I)+ODX(I)
      CALL LCMPUT(IPOPT,'VAR-VALUE',NVAR,2,VARVAL)
      ITYP=ITYP1
*----
*  EXTRAPOLATE OBJECTIVE FUNCTION
*----
      ECOST=COST
      DO 190 I=1,NVAR
  190 ECOST=ECOST+ODX(I)*ODF(I)
*----
*  REINITIALIZE GRADIENTS FOR THE NEXT ITERATION
*----
      ALLOCATE(GRAD0(NVAR*(NCST+1)))
      CALL XDRSET(GRAD0,NVAR*(NCST+1),0.0)
      CALL LCMPUT(IPOPT,'GRADIENT',NVAR*(NCST+1),2,GRAD0)
      DEALLOCATE(GRAD0)
      GO TO 30
*----
* OUTPUT THE EXTRAPOLATED OBJECTIVE FUNCTION
*----
  200 CALL REDGET(ITYP,NITMA,ECOST,TEXT12,DFLOTT)
      IF(ITYP.NE.-2) CALL XABORT('PLQ: OUTPUT REAL EXPECTED')
      ITYP=2
      CALL REDPUT(ITYP,NITMA,ECOST,TEXT12,DFLOTT)
      GO TO 20
*----
*  TEST CONVERGENCE
*----
  300 LNORM2=.TRUE.
      CALL REDGET(ITYP,CNVTST,FLOTT,TEXT12,DFLOTT)
      IF((ITYP.EQ.3).AND.(TEXT12.EQ.'NORM-INF')) THEN
         LNORM2=.FALSE.
         CALL REDGET(ITYP,CNVTST,FLOTT,TEXT12,DFLOTT)
      ENDIF
      IF(ITYP.NE.-5) CALL XABORT('PLQ: OUTPUT LOGICAL EXPECTED')
      DELTA=ABS((ECOST-COST)/COST)
      NORM=0.0
      CQUAD=0.0
      IF(LNORM2) THEN
         DO 350 I=1,NVAR
            NORM=NORM+VARWGT(I)*VARVAL(I)*VARVAL(I)
  350          CQUAD=CQUAD+VARWGT(I)*ODX(I)*ODX(I)
         IF(NORM.NE.0.0) THEN
            CQUAD=SQRT(CQUAD/NORM)
         ELSE
            CQUAD=0.0
         ENDIF
      ELSE
         DO 360 I=1,NVAR
            NORM=MAX(NORM,ABS(VARWGT(I)**0.5*VARVAL(I)))
  360       CQUAD=MAX(CQUAD,ABS(VARWGT(I)**0.5*ODX(I)))
         IF(NORM.NE.0.0) THEN
            CQUAD=CQUAD/NORM
         ELSE
            CQUAD=0.0
         ENDIF
      ENDIF
      IF(EPSEXT.EQ.0.0) EPSEXT = 0.001
      IF(((DELTA.LT.EPSEXT).AND.(CQUAD.LE.EPSEXT)) .OR.
     1    (CQUAD.LE.(EPSEXT/10.0)))    THEN
         CNVTST=1
         CONV  =1
      ELSE
         CNVTST=-1
         CONV  =0
      ENDIF
      IF(IPRINT.GT.1) THEN
         WRITE(6,*) 'It= convergence?', DELTA,CQUAD,EPSEXT
         IF(IPRINT.GT.2) THEN
            WRITE(6,*) 'DX',(ODX(I),I=1,NVAR)
            WRITE(6,*) 'X',(VARVAL(I),I=1,NVAR)
         ENDIF
      ENDIF
      ITYP=5
      CALL REDPUT(ITYP,CNVTST,FLOTT,TEXT12,DFLOTT)
      GO TO 20
*----
*  END
*----
 1000 DEALLOCATE(VARWGT,FCSTV,GRAD,ODX,ODF,VARVAL)
      OPTPRI(4)=CONV
      OPTPRI(5)=NSTPEX
      OPTPRR(6)=ECOST
      CALL LCMPUT(IPOPT,'OPT-PARAM-R',NSTATE,2,OPTPRR)
      CALL LCMPUT(IPOPT,'STATE-VECTOR',NSTATE,1,OPTPRI)
      RETURN
*
40001 FORMAT(//,5X,'S**2 (XDROIT) = ',1P,E13.5,
     >        /,5X,'FPOIDS  = ',/,(11X,1P,8E13.5))
      END
