C * * * * * * * * * * * * * * *
C --- DRIVER FOR RADAR5
C * * * * * * * * * * * * * * *
C       Use make command (relevant to Makefile)

        IMPLICIT REAL*8 (A-H,O-Z)

        REAL*4 TARRAY(2)
        INTEGER, PARAMETER :: DP=kind(1D0)
C --->  PARAMETERS FOR RADAR5 (FULL JACOBIAN) <---
        INTEGER, PARAMETER :: ND=1
        INTEGER, PARAMETER :: NRDENS=1
        INTEGER, PARAMETER :: NGRID=0
        INTEGER, PARAMETER :: NLAGS=1
        INTEGER, PARAMETER :: NJACL=1
        INTEGER, PARAMETER :: MXST=10000
        INTEGER, PARAMETER :: LWORK=30
        INTEGER, PARAMETER :: LIWORK=30
        REAL(kind=DP), dimension(ND) :: Y
        REAL(kind=DP), dimension(NGRID+1) :: GRID
        REAL(kind=DP), dimension(LWORK) :: WORK
        INTEGER, dimension(LIWORK) :: IWORK
        INTEGER, dimension(NRDENS+1) :: IPAST
        REAL(kind=DP), dimension(5) :: RPAR
        INTEGER, dimension(22) :: ISTAT
        REAL(kind=DP), PARAMETER :: A=5.D0
        REAL(kind=DP), PARAMETER :: B=-4.0D0
        REAL(kind=DP), PARAMETER :: TAU=1.D0
        REAL(kind=DP), PARAMETER :: EPS=1.D-6
        REAL(kind=DP), PARAMETER :: PI=3.1415926535897932385D0
        EXTERNAL  FCN,PHI,ARGLAG,JFCN,JACLAG,QFUN,SOLOUT

C ------ FILE TO OPEN ----------
        OPEN(9,FILE='sol.out')
        OPEN(10,FILE='cont.out')
        REWIND 9
        REWIND 10

C --- PARAMETERS IN THE DIFFERENTIAL EQUATION
        RPAR(1)=A
        RPAR(2)=B
        RPAR(3)=TAU
        RPAR(4)=EPS
        RPAR(5)=PI
C -----------------------------------------------------------------------
C
C --- DIMENSION OF THE SYSTEM
        N=ND
C --- COMPUTE THE JACOBIAN ANALYTICALLY
        IJAC=1
C --- JACOBIAN IS A FULL MATRIX
        MLJAC=N
C --- DIFFERENTIAL EQUATION IS IN IMPLICIT FORM
      IMAS=1
      MLMAS=N
C --- OUTPUT ROUTINE IS USED DURING INTEGRATION
        IOUT=1
C --- INITIAL VALUES
        X=0.0D0
        Y(1)=0.0D0
C       Consistent with initial function
C --- ENDPOINT OF INTEGRATION
        XEND=100.5D0
C --- REQUIRED (RELATIVE AND ABSOLUTE) TOLERANCE
        ITOL=0
        RTOL=1.D-6
        ATOL=RTOL
C --- INITIAL STEP SIZE
        H=1.0D-6
C --- DEFAULT VALUES FOR PARAMETERS
        DO 10 I=1,20
        IWORK(I)=0
  10    WORK(I)=0.D0
        IWORK(2)=1000000
C --- PARAMETERS FOR ERROR ESTIMATION
        WORK(10)=0.D0
        IWORK(11)=1
C --- WORKSPACE FOR PAST
        IWORK(12)=MXST
C --- THE COMPONENT USES RETARDED ARGUMENT
        IWORK(15)=NRDENS
        IPAST(1)=1
C --- SET THE PRESCRIBED GRID-POINTS
        DO 12 I=1,NGRID
  12     GRID(I)=I*TAU
C --- WORKSPACE FOR GRID
        IWORK(13)=NGRID
C _____________________________________________________________________
C --- CALL OF THE SUBROUTINE RADAR5
        CALL DTIME(TARRAY)
        CALL RADAR5(N,FCN,PHI,ARGLAG,X,Y,XEND,H,
     &                  RTOL,ATOL,ITOL,
     &                  JFCN,IJAC,MLJAC,MUJAC,
     &                  JACLAG,NLAGS,NJACL,
     &                  IMAS,SOLOUT,IOUT,
     &                  WORK,IWORK,RPAR,IPAR,IDID,
     &                  GRID,IPAST,QFUN,MLMAS,MUMAS)
        CALL DTIME(TARRAY)

C --- PRINT FINAL SOLUTION SOLUTION
        WRITE (6,90) X,Y(1)
C --- PRINT STATISTICS
         DO J=14,20
            ISTAT(J)=IWORK(J)
         END DO
        WRITE(6,*)' ***** TOL=',RTOL,'  ELAPSED TIME=',TARRAY(1),' ****'
        WRITE (6,91) (ISTAT(J),J=14,20)
 90     FORMAT(1X,'X =',F8.2,'    Y =',E18.10)
 91     FORMAT(' fcn=',I7,' jac=',I6,' step=',I6,
     &        ' accpt=',I6,' rejct=',I6,' dec=',I6,
     &        ' sol=',I7)
        WRITE(6,*) 'SOLUTION IS TABULATED IN FILES: sol.out & cont.out'

        STOP
        END
C
C
        SUBROUTINE SOLOUT (NR,XOLD,X,HSOL,Y,CONT,LRC,N,
     &                     RPAR,IPAR,IRTRN)

C ----- PRINTS THE DISCRETE OUTPUT AND THE CONTINUOUS OUTPUT
C       AT EQUIDISTANT OUTPUT-POINTS
        IMPLICIT REAL*8 (A-H,O-Z)
        INTEGER, PARAMETER :: DP=kind(1D0)
        REAL(kind=DP), PARAMETER :: XSTEP=0.01D0
        REAL(kind=DP), dimension(N) :: Y
        REAL(kind=DP), dimension(LRC) :: CONT
        REAL(kind=DP), dimension(1) :: RPAR
        EXTERNAL PHI
C       XOUT IS USED FOR THE DENSE OUTPUT
        COMMON /INTERN/XOUT

        WRITE (9,99) X,Y(1)
C
        IF (NR.EQ.1) THEN
           WRITE (10,99) X,Y(1)
           XOUT=XSTEP
        ELSE
 10        CONTINUE
           IF (X.GE.XOUT) THEN
              WRITE (10,99) XOUT,CONTR5(1,N,XOUT,CONT,X,HSOL)
              XOUT=XOUT+XSTEP
              GOTO 10
           END IF
        END IF
 99     FORMAT(1X,'X =',F12.8,'    Y =',E18.10)
        RETURN
        END
C
        FUNCTION ARGLAG(IL,X,Y,RPAR,IPAR,PHI,PAST,IPAST,NRDS)
        IMPLICIT REAL*8 (A-H,O-Z)
        INTEGER, PARAMETER :: DP=kind(1D0)
        REAL(kind=DP), dimension(1) :: Y
        INTEGER, dimension(1) :: IPAST
	  REAL(kind=DP), dimension(1) :: PAST
        INTEGER, dimension(1) :: IPAR
        REAL(kind=DP), dimension(1) :: RPAR

        TAU=RPAR(3)
        ARGLAG=X-TAU
        RETURN
        END
C
        SUBROUTINE FCN(N,X,Y,F,ARGLAG,PHI,RPAR,IPAR,
     &                 PAST,IPAST,NRDS)
        IMPLICIT REAL*8 (A-H,K,O-Z)
        INTEGER, PARAMETER :: DP=kind(1D0)
        REAL(kind=DP), dimension(N) :: Y
        REAL(kind=DP), dimension(N) :: F
        REAL(kind=DP), dimension(1) :: PAST
        INTEGER, dimension(1) :: IPAST
        REAL(kind=DP), dimension(1) :: RPAR
        EXTERNAL PHI

        A=RPAR(1)
        B=RPAR(2)
        TAU=RPAR(3)
        EPS=RPAR(4)
        PI=RPAR(5)

C       ONE DELAY
        CALL LAGR5(1,X,Y,ARGLAG,PAST,ALPHA1,IPOS1,RPAR,IPAR,
     &             PHI,IPAST,NRDS)
        Y1LT=YLAGR5(1,ALPHA1,IPOS1,PHI,RPAR,IPAR,
     &                PAST,IPAST,NRDS)

        F(1)=EPS*(1.D0/(1.D0 + X*X)) - Y(1) + (B/A)*Y1LT +
     &            ((A-B)/A)*PI/2.D0
        RETURN
        END
C
        SUBROUTINE JFCN(N,X,Y,DFY,LDFY,ARGLAG,PHI,RPAR,IPAR,
     &                  PAST,IPAST,NRDS)
C ----- STANDARD JACOBIAN OF THE EQUATION
        IMPLICIT REAL*8 (A-H,K,O-Z)
        INTEGER, PARAMETER :: DP=kind(1D0)
        REAL(kind=DP), dimension(N) :: Y
        REAL(kind=DP), dimension(LDFY,N) :: DFY
        REAL(kind=DP), dimension(1) :: PAST
        INTEGER, dimension(1) :: IPAST
        REAL(kind=DP), dimension(1) :: RPAR
        EXTERNAL PHI

        DFY(1,1)=-1
        RETURN
        END
C
        SUBROUTINE JACLAG(N,X,Y,DFYL,ARGLAG,PHI,IVE,IVC,IVL,
     &                    RPAR,IPAR,PAST,IPAST,NRDS)
C ----- JACOBIAN OF DELAY TERMS IN THE EQUATION
        IMPLICIT REAL*8 (A-H,O-Z)
        INTEGER, PARAMETER :: DP=kind(1D0)
        REAL(kind=DP), dimension(N) :: Y
        REAL(kind=DP), dimension(1) :: DFYL
        REAL(kind=DP), dimension(1) :: PAST
        INTEGER, dimension(1) :: IPAST
        REAL(kind=DP), dimension(1) :: RPAR
        INTEGER, dimension(1) :: IVE,IVC,IVL
        EXTERNAL PHI

        A=RPAR(1)
        B=RPAR(2)

        IVL(1)=1
        IVE(1)=1
        IVC(1)=1
        DFYL(1)=B/A

        RETURN
        END

C
        FUNCTION PHI(I,X,RPAR,IPAR)
        IMPLICIT REAL*8 (A-H,O-Z)
        PHI=ATAN(X)
        RETURN
        END

        SUBROUTINE QFUN(N,Q,LQ,RPAR,IPAR)
C --- MATRIX "M" FOR THE TEST PROBLEM
        IMPLICIT REAL*8 (A-H,O-Z)
        INTEGER, PARAMETER :: DP=kind(1D0)
        REAL(kind=DP), dimension(1) :: RPAR
        REAL(kind=DP), dimension(LQ,N) :: Q
        Q(1,1)=RPAR(4)
        RETURN
        END


C
C      ALGORITHM 733, COLLECTED ALGORITHMS FROM ACM.
C      TRANSACTIONS ON MATHEMATICAL SOFTWARE,
C      VOL. 20, NO. 3, SEPTEMBER, 1994, PP. 262-281.
C      http://doi.acm.org/10.1145/192115.192124
C
C
C      http://permalink.gmane.org/gmane.comp.python.scientific.devel/6725
C      ------
C      From: Deborah Cotton <cotton@hq.acm.org>
C      Date: Fri, 14 Sep 2007 12:35:55 -0500
C      Subject: RE: Algorithm License requested
C      To: Alan Isaac
C
C      Prof. Issac,
C
C      In that case, then because the author consents to [the ACM] releasing
C      the code currently archived at http://www.netlib.org/toms/733 under the
C      BSD license, the ACM hereby releases this code under the BSD license.
C
C      Regards,
C
C      Deborah Cotton, Copyright & Permissions
C      ACM Publications
C      2 Penn Plaza, Suite 701**
C      New York, NY 10121-0701
C      permissions@acm.org
C      212.869.7440 ext. 652
C      Fax. 212.869.0481
C      ------
C

************************************************************************
*                              optimizer                               *
************************************************************************

      SUBROUTINE slsqp (m, meq, la, n, x, xl, xu, f, c, g, a,
     *                  acc, iter, mode, w, l_w, jw, l_jw)

C   SLSQP       S EQUENTIAL  L EAST  SQ UARES  P ROGRAMMING
C            TO SOLVE GENERAL NONLINEAR OPTIMIZATION PROBLEMS

C***********************************************************************
C*                                                                     *
C*                                                                     *
C*            A NONLINEAR PROGRAMMING METHOD WITH                      *
C*            QUADRATIC  PROGRAMMING  SUBPROBLEMS                      *
C*                                                                     *
C*                                                                     *
C*  THIS SUBROUTINE SOLVES THE GENERAL NONLINEAR PROGRAMMING PROBLEM   *
C*                                                                     *
C*            MINIMIZE    F(X)                                         *
C*                                                                     *
C*            SUBJECT TO  C (X) .EQ. 0  ,  J = 1,...,MEQ               *
C*                         J                                           *
C*                                                                     *
C*                        C (X) .GE. 0  ,  J = MEQ+1,...,M             *
C*                         J                                           *
C*                                                                     *
C*                        XL .LE. X .LE. XU , I = 1,...,N.             *
C*                          I      I       I                           *
C*                                                                     *
C*  THE ALGORITHM IMPLEMENTS THE METHOD OF HAN AND POWELL              *
C*  WITH BFGS-UPDATE OF THE B-MATRIX AND L1-TEST FUNCTION              *
C*  WITHIN THE STEPLENGTH ALGORITHM.                                   *
C*                                                                     *
C*    PARAMETER DESCRIPTION:                                           *
C*    ( * MEANS THIS PARAMETER WILL BE CHANGED DURING CALCULATION )    *
C*                                                                     *
C*    M              IS THE TOTAL NUMBER OF CONSTRAINTS, M .GE. 0      *
C*    MEQ            IS THE NUMBER OF EQUALITY CONSTRAINTS, MEQ .GE. 0 *
C*    LA             SEE A, LA .GE. MAX(M,1)                           *
C*    N              IS THE NUMBER OF VARIBLES, N .GE. 1               *
C*  * X()            X() STORES THE CURRENT ITERATE OF THE N VECTOR X  *
C*                   ON ENTRY X() MUST BE INITIALIZED. ON EXIT X()     *
C*                   STORES THE SOLUTION VECTOR X IF MODE = 0.         *
C*    XL()           XL() STORES AN N VECTOR OF LOWER BOUNDS XL TO X.  *
C*                   ELEMENTS MAY BE NAN TO INDICATE NO LOWER BOUND.   *
C*    XU()           XU() STORES AN N VECTOR OF UPPER BOUNDS XU TO X.  *
C*                   ELEMENTS MAY BE NAN TO INDICATE NO UPPER BOUND.   *
C*    F              IS THE VALUE OF THE OBJECTIVE FUNCTION.           *
C*    C()            C() STORES THE M VECTOR C OF CONSTRAINTS,         *
C*                   EQUALITY CONSTRAINTS (IF ANY) FIRST.              *
C*                   DIMENSION OF C MUST BE GREATER OR EQUAL LA,       *
C*                   which must be GREATER OR EQUAL MAX(1,M).          *
C*    G()            G() STORES THE N VECTOR G OF PARTIALS OF THE      *
C*                   OBJECTIVE FUNCTION; DIMENSION OF G MUST BE        *
C*                   GREATER OR EQUAL N+1.                             *
C*    A(),LA,M,N     THE LA BY N + 1 ARRAY A() STORES                  *
C*                   THE M BY N MATRIX A OF CONSTRAINT NORMALS.        *
C*                   A() HAS FIRST DIMENSIONING PARAMETER LA,          *
C*                   WHICH MUST BE GREATER OR EQUAL MAX(1,M).          *
C*    F,C,G,A        MUST ALL BE SET BY THE USER BEFORE EACH CALL.     *
C*  * ACC            ABS(ACC) CONTROLS THE FINAL ACCURACY.             *
C*                   IF ACC .LT. ZERO AN EXACT LINESEARCH IS PERFORMED,*
C*                   OTHERWISE AN ARMIJO-TYPE LINESEARCH IS USED.      *
C*  * ITER           PRESCRIBES THE MAXIMUM NUMBER OF ITERATIONS.      *
C*                   ON EXIT ITER INDICATES THE NUMBER OF ITERATIONS.  *
C*  * MODE           MODE CONTROLS CALCULATION:                        *
C*                   REVERSE COMMUNICATION IS USED IN THE SENSE THAT   *
C*                   THE PROGRAM IS INITIALIZED BY MODE = 0; THEN IT IS*
C*                   TO BE CALLED REPEATEDLY BY THE USER UNTIL A RETURN*
C*                   WITH MODE .NE. IABS(1) TAKES PLACE.               *
C*                   IF MODE = -1 GRADIENTS HAVE TO BE CALCULATED,     *
C*                   WHILE WITH MODE = 1 FUNCTIONS HAVE TO BE CALCULATED
C*                   MODE MUST NOT BE CHANGED BETWEEN SUBSEQUENT CALLS *
C*                   OF SQP.                                           *
C*                   EVALUATION MODES:                                 *
C*        MODE = -1: GRADIENT EVALUATION, (G&A)                        *
C*                0: ON ENTRY: INITIALIZATION, (F,G,C&A)               *
C*                   ON EXIT : REQUIRED ACCURACY FOR SOLUTION OBTAINED *
C*                1: FUNCTION EVALUATION, (F&C)                        *
C*                                                                     *
C*                   FAILURE MODES:                                    *
C*                2: NUMBER OF EQUALITY CONTRAINTS LARGER THAN N       *
C*                3: MORE THAN 3*N ITERATIONS IN LSQ SUBPROBLEM        *
C*                4: INEQUALITY CONSTRAINTS INCOMPATIBLE               *
C*                5: SINGULAR MATRIX E IN LSQ SUBPROBLEM               *
C*                6: SINGULAR MATRIX C IN LSQ SUBPROBLEM               *
C*                7: RANK-DEFICIENT EQUALITY CONSTRAINT SUBPROBLEM HFTI*
C*                8: POSITIVE DIRECTIONAL DERIVATIVE FOR LINESEARCH    *
C*                9: MORE THAN ITER ITERATIONS IN SQP                  *
C*             >=10: WORKING SPACE W OR JW TOO SMALL,                  *
C*                   W SHOULD BE ENLARGED TO L_W=MODE/1000             *
C*                   JW SHOULD BE ENLARGED TO L_JW=MODE-1000*L_W       *
C*  * W(), L_W       W() IS A ONE DIMENSIONAL WORKING SPACE,           *
C*                   THE LENGTH L_W OF WHICH SHOULD BE AT LEAST        *
C*                   (3*N1+M)*(N1+1)                        for LSQ    *
C*                  +(N1-MEQ+1)*(MINEQ+2) + 2*MINEQ         for LSI    *
C*                  +(N1+MINEQ)*(N1-MEQ) + 2*MEQ + N1       for LSEI   *
C*                  + N1*N/2 + 2*M + 3*N + 3*N1 + 1         for SLSQPB *
C*                   with MINEQ = M - MEQ + 2*N1  &  N1 = N+1          *
C*        NOTICE:    FOR PROPER DIMENSIONING OF W IT IS RECOMMENDED TO *
C*                   COPY THE FOLLOWING STATEMENTS INTO THE HEAD OF    *
C*                   THE CALLING PROGRAM (AND REMOVE THE COMMENT C)    *
c#######################################################################
C     INTEGER LEN_W, LEN_JW, M, N, N1, MEQ, MINEQ
C     PARAMETER (M=... , MEQ=... , N=...  )
C     PARAMETER (N1= N+1, MINEQ= M-MEQ+N1+N1)
C     PARAMETER (LEN_W=
c    $           (3*N1+M)*(N1+1)
c    $          +(N1-MEQ+1)*(MINEQ+2) + 2*MINEQ
c    $          +(N1+MINEQ)*(N1-MEQ) + 2*MEQ + N1
c    $          +(N+1)*N/2 + 2*M + 3*N + 3*N1 + 1,
c    $           LEN_JW=MINEQ)
C     DOUBLE PRECISION W(LEN_W)
C     INTEGER          JW(LEN_JW)
c#######################################################################
C*                   THE FIRST M+N+N*N1/2 ELEMENTS OF W MUST NOT BE    *
C*                   CHANGED BETWEEN SUBSEQUENT CALLS OF SLSQP.        *
C*                   ON RETURN W(1) ... W(M) CONTAIN THE MULTIPLIERS   *
C*                   ASSOCIATED WITH THE GENERAL CONSTRAINTS, WHILE    *
C*                   W(M+1) ... W(M+N(N+1)/2) STORE THE CHOLESKY FACTOR*
C*                   L*D*L(T) OF THE APPROXIMATE HESSIAN OF THE        *
C*                   LAGRANGIAN COLUMNWISE DENSE AS LOWER TRIANGULAR   *
C*                   UNIT MATRIX L WITH D IN ITS 'DIAGONAL' and        *
C*                   W(M+N(N+1)/2+N+2 ... W(M+N(N+1)/2+N+2+M+2N)       *
C*                   CONTAIN THE MULTIPLIERS ASSOCIATED WITH ALL       *
C*                   ALL CONSTRAINTS OF THE QUADRATIC PROGRAM FINDING  *
C*                   THE SEARCH DIRECTION TO THE SOLUTION X*           *
C*  * JW(), L_JW     JW() IS A ONE DIMENSIONAL INTEGER WORKING SPACE   *
C*                   THE LENGTH L_JW OF WHICH SHOULD BE AT LEAST       *
C*                   MINEQ                                             *
C*                   with MINEQ = M - MEQ + 2*N1  &  N1 = N+1          *
C*                                                                     *
C*  THE USER HAS TO PROVIDE THE FOLLOWING SUBROUTINES:                 *
C*     LDL(N,A,Z,SIG,W) :   UPDATE OF THE LDL'-FACTORIZATION.          *
C*     LINMIN(A,B,F,TOL) :  LINESEARCH ALGORITHM IF EXACT = 1          *
C*     LSQ(M,MEQ,LA,N,NC,C,D,A,B,XL,XU,X,LAMBDA,W,....) :              *
C*                                                                     *
C*        SOLUTION OF THE QUADRATIC PROGRAM                            *
C*                QPSOL IS RECOMMENDED:                                *
C*     PE GILL, W MURRAY, MA SAUNDERS, MH WRIGHT:                      *
C*     USER'S GUIDE FOR SOL/QPSOL:                                     *
C*     A FORTRAN PACKAGE FOR QUADRATIC PROGRAMMING,                    *
C*     TECHNICAL REPORT SOL 83-7, JULY 1983                            *
C*     DEPARTMENT OF OPERATIONS RESEARCH, STANFORD UNIVERSITY          *
C*     STANFORD, CA 94305                                              *
C*     QPSOL IS THE MOST ROBUST AND EFFICIENT QP-SOLVER                *
C*     AS IT ALLOWS WARM STARTS WITH PROPER WORKING SETS               *
C*                                                                     *
C*     IF IT IS NOT AVAILABLE USE LSEI, A CONSTRAINT LINEAR LEAST      *
C*     SQUARES SOLVER IMPLEMENTED USING THE SOFTWARE HFTI, LDP, NNLS   *
C*     FROM C.L. LAWSON, R.J.HANSON: SOLVING LEAST SQUARES PROBLEMS,   *
C*     PRENTICE HALL, ENGLEWOOD CLIFFS, 1974.                          *
C*     LSEI COMES WITH THIS PACKAGE, together with all necessary SR's. *
C*                                                                     *
C*     TOGETHER WITH A COUPLE OF SUBROUTINES FROM BLAS LEVEL 1         *
C*                                                                     *
C*     SQP IS HEAD SUBROUTINE FOR BODY SUBROUTINE SQPBDY               *
C*     IN WHICH THE ALGORITHM HAS BEEN IMPLEMENTED.                    *
C*                                                                     *
C*  IMPLEMENTED BY: DIETER KRAFT, DFVLR OBERPFAFFENHOFEN               *
C*  as described in Dieter Kraft: A Software Package for               *
C*                                Sequential Quadratic Programming     *
C*                                DFVLR-FB 88-28, 1988                 *
C*  which should be referenced if the user publishes results of SLSQP  *
C*                                                                     *
C*  DATE:           APRIL - OCTOBER, 1981.                             *
C*  STATUS:         DECEMBER, 31-ST, 1984.                             *
C*  STATUS:         MARCH   , 21-ST, 1987, REVISED TO FORTAN 77        *
C*  STATUS:         MARCH   , 20-th, 1989, REVISED TO MS-FORTRAN       *
C*  STATUS:         APRIL   , 14-th, 1989, HESSE   in-line coded       *
C*  STATUS:         FEBRUARY, 28-th, 1991, FORTRAN/2 Version 1.04      *
C*                                         accepts Statement Functions *
C*  STATUS:         MARCH   ,  1-st, 1991, tested with SALFORD         *
C*                                         FTN77/386 COMPILER VERS 2.40*
C*                                         in protected mode           *
C*                                                                     *
C***********************************************************************
C*                                                                     *
C*  Copyright 1991: Dieter Kraft, FHM                                  *
C*                                                                     *
C***********************************************************************

      INTEGER          il, im, ir, is, iter, iu, iv, iw, ix, l_w, l_jw,
     *                 jw(l_jw), la, m, meq, mineq, mode, n, n1

      DOUBLE PRECISION acc, a(la,n+1), c(la), f, g(n+1),
     *                 x(n), xl(n), xu(n), w(l_w)

c     dim(W) =         N1*(N1+1) + MEQ*(N1+1) + MINEQ*(N1+1)  for LSQ
c                    +(N1-MEQ+1)*(MINEQ+2) + 2*MINEQ          for LSI
c                    +(N1+MINEQ)*(N1-MEQ) + 2*MEQ + N1        for LSEI
c                    + N1*N/2 + 2*M + 3*N +3*N1 + 1           for SLSQPB
c                      with MINEQ = M - MEQ + 2*N1  &  N1 = N+1

C   CHECK LENGTH OF WORKING ARRAYS

      n1 = n+1
      mineq = m-meq+n1+n1
      il = (3*n1+m)*(n1+1) +
     .(n1-meq+1)*(mineq+2) + 2*mineq +
     .(n1+mineq)*(n1-meq)  + 2*meq +
     .n1*n/2 + 2*m + 3*n + 4*n1 + 1
      im = MAX(mineq, n1-meq)
      IF (l_w .LT. il .OR. l_jw .LT. im) THEN
          mode = 1000*MAX(10,il)
          mode = mode+MAX(10,im)
          RETURN
      ENDIF

C   PREPARE DATA FOR CALLING SQPBDY  -  INITIAL ADDRESSES IN W

      im = 1
      il = im + MAX(1,m)
      il = im + la
      ix = il + n1*n/2 + 1
      ir = ix + n
      is = ir + n + n + MAX(1,m)
      is = ir + n + n + la
      iu = is + n1
      iv = iu + n1
      iw = iv + n1

      CALL slsqpb  (m, meq, la, n, x, xl, xu, f, c, g, a, acc, iter,
     * mode, w(ir), w(il), w(ix), w(im), w(is), w(iu), w(iv), w(iw), jw)

      END

      SUBROUTINE slsqpb (m, meq, la, n, x, xl, xu, f, c, g, a, acc,
     *                   iter, mode, r, l, x0, mu, s, u, v, w, iw)

C   NONLINEAR PROGRAMMING BY SOLVING SEQUENTIALLY QUADRATIC PROGRAMS

C        -  L1 - LINE SEARCH,  POSITIVE DEFINITE  BFGS UPDATE  -

C                      BODY SUBROUTINE FOR SLSQP

      INTEGER          iw(*), i, iexact, incons, ireset, iter, itermx,
     *                 k, j, la, line, m, meq, mode, n, n1, n2, n3

      DOUBLE PRECISION a(la,n+1), c(la), g(n+1), l((n+1)*(n+2)/2),
     *                 mu(la), r(m+n+n+2), s(n+1), u(n+1), v(n+1), w(*),
     *                 x(n), xl(n), xu(n), x0(n),
     *                 ddot_sl, dnrm2_, linmin,
     *                 acc, alfmin, alpha, f, f0, gs, h1, h2, h3, h4,
     *                 hun, one, t, t0, ten, tol, two, ZERO

c     dim(W) =         N1*(N1+1) + MEQ*(N1+1) + MINEQ*(N1+1)  for LSQ
c                     +(N1-MEQ+1)*(MINEQ+2) + 2*MINEQ
c                     +(N1+MINEQ)*(N1-MEQ) + 2*MEQ + N1       for LSEI
c                      with MINEQ = M - MEQ + 2*N1  &  N1 = N+1

      SAVE             alpha, f0, gs, h1, h2, h3, h4, t, t0, tol,
     *                 iexact, incons, ireset, itermx, line, n1, n2, n3

      DATA             ZERO /0.0d0/, one /1.0d0/, alfmin /1.0d-1/,
     *                 hun /1.0d+2/, ten /1.0d+1/, two /2.0d0/

      IF (mode) 260, 100, 220

  100 itermx = iter
      IF (acc.GE.ZERO) THEN
          iexact = 0
      ELSE
          iexact = 1
      ENDIF
      acc = ABS(acc)
      tol = ten*acc
      iter = 0
      ireset = 0
      n1 = n + 1
      n2 = n1*n/2
      n3 = n2 + 1
      s(1) = ZERO
      mu(1) = ZERO
      CALL dcopy_(n, s(1),  0, s,  1)
      CALL dcopy_(m, mu(1), 0, mu, 1)

C   RESET BFGS MATRIX

  110 ireset = ireset + 1
      IF (ireset.GT.5) GO TO 255
      l(1) = ZERO
      CALL dcopy_(n2, l(1), 0, l, 1)
      j = 1
      DO 120 i=1,n
         l(j) = one
         j = j + n1 - i
  120 CONTINUE

C   MAIN ITERATION : SEARCH DIRECTION, STEPLENGTH, LDL'-UPDATE

  130 iter = iter + 1
      mode = 9
      IF (iter.GT.itermx) GO TO 330

C   SEARCH DIRECTION AS SOLUTION OF QP - SUBPROBLEM

      CALL dcopy_(n, xl, 1, u, 1)
      CALL dcopy_(n, xu, 1, v, 1)
      CALL daxpy_sl(n, -one, x, 1, u, 1)
      CALL daxpy_sl(n, -one, x, 1, v, 1)
      h4 = one
      CALL lsq (m, meq, n , n3, la, l, g, a, c, u, v, s, r, w, iw, mode)

C   AUGMENTED PROBLEM FOR INCONSISTENT LINEARIZATION

      IF (mode.EQ.6) THEN
          IF (n.EQ.meq) THEN
              mode = 4
          ENDIF
      ENDIF
      IF (mode.EQ.4) THEN
          DO 140 j=1,m
             IF (j.LE.meq) THEN
                 a(j,n1) = -c(j)
             ELSE
                 a(j,n1) = MAX(-c(j),ZERO)
             ENDIF
  140     CONTINUE
          s(1) = ZERO
          CALL dcopy_(n, s(1), 0, s, 1)
          h3 = ZERO
          g(n1) = ZERO
          l(n3) = hun
          s(n1) = one
          u(n1) = ZERO
          v(n1) = one
          incons = 0
  150     CALL lsq (m, meq, n1, n3, la, l, g, a, c, u, v, s, r,
     *              w, iw, mode)
          h4 = one - s(n1)
          IF (mode.EQ.4) THEN
              l(n3) = ten*l(n3)
              incons = incons + 1
              IF (incons.GT.5) GO TO 330
              GOTO 150
          ELSE IF (mode.NE.1) THEN
              GOTO 330
          ENDIF
      ELSE IF (mode.NE.1) THEN
          GOTO 330
      ENDIF

C   UPDATE MULTIPLIERS FOR L1-TEST

      DO 160 i=1,n
         v(i) = g(i) - ddot_sl(m,a(1,i),1,r,1)
  160 CONTINUE
      f0 = f
      CALL dcopy_(n, x, 1, x0, 1)
      gs = ddot_sl(n, g, 1, s, 1)
      h1 = ABS(gs)
      h2 = ZERO
      DO 170 j=1,m
         IF (j.LE.meq) THEN
             h3 = c(j)
         ELSE
             h3 = ZERO
         ENDIF
         h2 = h2 + MAX(-c(j),h3)
         h3 = ABS(r(j))
         mu(j) = MAX(h3,(mu(j)+h3)/two)
         h1 = h1 + h3*ABS(c(j))
  170 CONTINUE

C   CHECK CONVERGENCE

      mode = 0
      IF (h1.LT.acc .AND. h2.LT.acc) GO TO 330
      h1 = ZERO
      DO 180 j=1,m
         IF (j.LE.meq) THEN
             h3 = c(j)
         ELSE
             h3 = ZERO
         ENDIF
         h1 = h1 + mu(j)*MAX(-c(j),h3)
  180 CONTINUE
      t0 = f + h1
      h3 = gs - h1*h4
      mode = 8
      IF (h3.GE.ZERO) GO TO 110

C   LINE SEARCH WITH AN L1-TESTFUNCTION

      line = 0
      alpha = one
      IF (iexact.EQ.1) GOTO 210

C   INEXACT LINESEARCH

  190     line = line + 1
          h3 = alpha*h3
          CALL dscal_sl(n, alpha, s, 1)
          CALL dcopy_(n, x0, 1, x, 1)
          CALL daxpy_sl(n, one, s, 1, x, 1)
          mode = 1
          GO TO 330
  200         IF (h1.LE.h3/ten .OR. line.GT.10) GO TO 240
              alpha = MAX(h3/(two*(h3-h1)),alfmin)
              GO TO 190

C   EXACT LINESEARCH

  210 IF (line.NE.3) THEN
          alpha = linmin(line,alfmin,one,t,tol)
          CALL dcopy_(n, x0, 1, x, 1)
          CALL daxpy_sl(n, alpha, s, 1, x, 1)
          mode = 1
          GOTO 330
      ENDIF
      CALL dscal_sl(n, alpha, s, 1)
      GOTO 240

C   CALL FUNCTIONS AT CURRENT X

  220     t = f
          DO 230 j=1,m
             IF (j.LE.meq) THEN
                 h1 = c(j)
             ELSE
                 h1 = ZERO
             ENDIF
             t = t + mu(j)*MAX(-c(j),h1)
  230     CONTINUE
          h1 = t - t0
          GOTO (200, 210) iexact+1

C   CHECK CONVERGENCE

  240 h3 = ZERO
      DO 250 j=1,m
         IF (j.LE.meq) THEN
             h1 = c(j)
         ELSE
             h1 = ZERO
         ENDIF
         h3 = h3 + MAX(-c(j),h1)
  250 CONTINUE
      IF ((ABS(f-f0).LT.acc .OR. dnrm2_(n,s,1).LT.acc) .AND. h3.LT.acc)
     *   THEN
            mode = 0
         ELSE
            mode = -1
         ENDIF
      GO TO 330

C   CHECK relaxed CONVERGENCE in case of positive directional derivative

  255 CONTINUE
      IF ((ABS(f-f0).LT.tol .OR. dnrm2_(n,s,1).LT.tol) .AND. h3.LT.tol)
     *   THEN
            mode = 0
         ELSE
            mode = 8
         ENDIF
      GO TO 330

C   CALL JACOBIAN AT CURRENT X

C   UPDATE CHOLESKY-FACTORS OF HESSIAN MATRIX BY MODIFIED BFGS FORMULA

  260 DO 270 i=1,n
         u(i) = g(i) - ddot_sl(m,a(1,i),1,r,1) - v(i)
  270 CONTINUE

C   L'*S

      k = 0
      DO 290 i=1,n
         h1 = ZERO
         k = k + 1
         DO 280 j=i+1,n
            k = k + 1
            h1 = h1 + l(k)*s(j)
  280    CONTINUE
         v(i) = s(i) + h1
  290 CONTINUE

C   D*L'*S

      k = 1
      DO 300 i=1,n
         v(i) = l(k)*v(i)
         k = k + n1 - i
  300 CONTINUE

C   L*D*L'*S

      DO 320 i=n,1,-1
         h1 = ZERO
         k = i
         DO 310 j=1,i - 1
            h1 = h1 + l(k)*v(j)
            k = k + n - j
  310    CONTINUE
         v(i) = v(i) + h1
  320 CONTINUE

      h1 = ddot_sl(n,s,1,u,1)
      h2 = ddot_sl(n,s,1,v,1)
      h3 = 0.2d0*h2
      IF (h1.LT.h3) THEN
          h4 = (h2-h3)/(h2-h1)
          h1 = h3
          CALL dscal_sl(n, h4, u, 1)
          CALL daxpy_sl(n, one-h4, v, 1, u, 1)
      ENDIF
      CALL ldl(n, l, u, +one/h1, v)
      CALL ldl(n, l, v, -one/h2, u)

C   END OF MAIN ITERATION

      GO TO 130

C   END OF SLSQPB

  330 END

      SUBROUTINE lsq(m,meq,n,nl,la,l,g,a,b,xl,xu,x,y,w,jw,mode)

C   MINIMIZE with respect to X

C             ||E*X - F||
C                                      1/2  T
C   WITH UPPER TRIANGULAR MATRIX E = +D   *L ,

C                                      -1/2  -1
C                     AND VECTOR F = -D    *L  *G,

C  WHERE THE UNIT LOWER TRIDIANGULAR MATRIX L IS STORED COLUMNWISE
C  DENSE IN THE N*(N+1)/2 ARRAY L WITH VECTOR D STORED IN ITS
C 'DIAGONAL' THUS SUBSTITUTING THE ONE-ELEMENTS OF L

C   SUBJECT TO

C             A(J)*X - B(J) = 0 ,         J=1,...,MEQ,
C             A(J)*X - B(J) >=0,          J=MEQ+1,...,M,
C             XL(I) <= X(I) <= XU(I),     I=1,...,N,
C     ON ENTRY, THE USER HAS TO PROVIDE THE ARRAYS L, G, A, B, XL, XU.
C     WITH DIMENSIONS: L(N*(N+1)/2), G(N), A(LA,N), B(M), XL(N), XU(N)
C     THE WORKING ARRAY W MUST HAVE AT LEAST THE FOLLOWING DIMENSION:
c     DIM(W) =        (3*N+M)*(N+1)                        for LSQ
c                    +(N-MEQ+1)*(MINEQ+2) + 2*MINEQ        for LSI
c                    +(N+MINEQ)*(N-MEQ) + 2*MEQ + N        for LSEI
c                      with MINEQ = M - MEQ + 2*N
C     ON RETURN, NO ARRAY WILL BE CHANGED BY THE SUBROUTINE.
C     X     STORES THE N-DIMENSIONAL SOLUTION VECTOR
C     Y     STORES THE VECTOR OF LAGRANGE MULTIPLIERS OF DIMENSION
C           M+N+N (CONSTRAINTS+LOWER+UPPER BOUNDS)
C     MODE  IS A SUCCESS-FAILURE FLAG WITH THE FOLLOWING MEANINGS:
C          MODE=1: SUCCESSFUL COMPUTATION
C               2: ERROR RETURN BECAUSE OF WRONG DIMENSIONS (N<1)
C               3: ITERATION COUNT EXCEEDED BY NNLS
C               4: INEQUALITY CONSTRAINTS INCOMPATIBLE
C               5: MATRIX E IS NOT OF FULL RANK
C               6: MATRIX C IS NOT OF FULL RANK
C               7: RANK DEFECT IN HFTI

c     coded            Dieter Kraft, april 1987
c     revised                        march 1989

      DOUBLE PRECISION l,g,a,b,w,xl,xu,x,y,
     .                 diag,ZERO,one,ddot_sl,xnorm

      INTEGER          jw(*),i,ic,id,ie,IF,ig,ih,il,im,ip,iu,iw,
     .     i1,i2,i3,i4,la,m,meq,mineq,mode,m1,n,nl,n1,n2,n3,
     .     nancnt,j

      DIMENSION        a(la,n), b(la), g(n), l(nl),
     .                 w(*), x(n), xl(n), xu(n), y(m+n+n)

      DATA             ZERO/0.0d0/, one/1.0d0/

      n1 = n + 1
      mineq = m - meq
      m1 = mineq + n + n

c  determine whether to solve problem
c  with inconsistent linerarization (n2=1)
c  or not (n2=0)

      n2 = n1*n/2 + 1
      IF (n2.EQ.nl) THEN
          n2 = 0
      ELSE
          n2 = 1
      ENDIF
      n3 = n-n2

C  RECOVER MATRIX E AND VECTOR F FROM L AND G

      i2 = 1
      i3 = 1
      i4 = 1
      ie = 1
      IF = n*n+1
      DO 10 i=1,n3
         i1 = n1-i
         diag = SQRT (l(i2))
         w(i3) = ZERO
         CALL dcopy_ (i1  ,  w(i3), 0, w(i3), 1)
         CALL dcopy_ (i1-n2, l(i2), 1, w(i3), n)
         CALL dscal_sl (i1-n2,     diag, w(i3), n)
         w(i3) = diag
         w(IF-1+i) = (g(i) - ddot_sl (i-1, w(i4), 1, w(IF), 1))/diag
         i2 = i2 + i1 - n2
         i3 = i3 + n1
         i4 = i4 + n
   10 CONTINUE
      IF (n2.EQ.1) THEN
          w(i3) = l(nl)
          w(i4) = ZERO
          CALL dcopy_ (n3, w(i4), 0, w(i4), 1)
          w(IF-1+n) = ZERO
      ENDIF
      CALL dscal_sl (n, - one, w(IF), 1)

      ic = IF + n
      id = ic + meq*n

      IF (meq .GT. 0) THEN

C  RECOVER MATRIX C FROM UPPER PART OF A

          DO 20 i=1,meq
              CALL dcopy_ (n, a(i,1), la, w(ic-1+i), meq)
   20     CONTINUE

C  RECOVER VECTOR D FROM UPPER PART OF B

          CALL dcopy_ (meq, b(1), 1, w(id), 1)
          CALL dscal_sl (meq,   - one, w(id), 1)

      ENDIF

      ig = id + meq

C  RECOVER MATRIX G FROM LOWER PART OF A
C  The matrix G(mineq+2*n,m1) is stored at w(ig)
C  Not all rows will be filled if some of the upper/lower
C  bounds are unbounded.

      IF (mineq .GT. 0) THEN

          DO 30 i=1,mineq
              CALL dcopy_ (n, a(meq+i,1), la, w(ig-1+i), m1)
   30     CONTINUE

      ENDIF

      ih = ig + m1*n
      iw = ih + mineq + 2*n

      IF (mineq .GT. 0) THEN

C  RECOVER H FROM LOWER PART OF B
C  The vector H(mineq+2*n) is stored at w(ih)

          CALL dcopy_ (mineq, b(meq+1), 1, w(ih), 1)
          CALL dscal_sl (mineq,       - one, w(ih), 1)

      ENDIF

C  AUGMENT MATRIX G BY +I AND -I, AND,
C  AUGMENT VECTOR H BY XL AND XU
C  NaN value indicates no bound

      ip = ig + mineq
      il = ih + mineq
      nancnt = 0

      DO 40 i=1,n
         if (xl(i).eq.xl(i)) then
            w(il) = xl(i)
            do 41 j=1,n
               w(ip + m1*(j-1)) = 0
 41         continue
            w(ip + m1*(i-1)) = 1
            ip = ip + 1
            il = il + 1
         else
            nancnt = nancnt + 1
         end if
   40 CONTINUE

      DO 50 i=1,n
         if (xu(i).eq.xu(i)) then
            w(il) = -xu(i)
            do 51 j=1,n
               w(ip + m1*(j-1)) = 0
 51         continue
            w(ip + m1*(i-1)) = -1
            ip = ip + 1
            il = il + 1
         else
            nancnt = nancnt + 1
         end if
 50   CONTINUE

      CALL lsei (w(ic), w(id), w(ie), w(IF), w(ig), w(ih), MAX(1,meq),
     .           meq, n, n, m1, m1-nancnt, n, x, xnorm, w(iw), jw, mode)

      IF (mode .EQ. 1) THEN

c   restore Lagrange multipliers (only for user-defined variables)

          CALL dcopy_ (m,  w(iw),     1, y(1),      1)

c   set rest of the multipliers to nan (they are not used)

          IF (n3 .GT. 0) THEN
             y(m+1) = 0
             y(m+1) = 0 / y(m+1)
             do 60 i=m+2,m+n3+n3
                y(i) = y(m+1)
 60          continue
          ENDIF

      ENDIF
      call bound(n, x, xl, xu)

C   END OF SUBROUTINE LSQ

      END

      SUBROUTINE lsei(c,d,e,f,g,h,lc,mc,LE,me,lg,mg,n,x,xnrm,w,jw,mode)

C     FOR MODE=1, THE SUBROUTINE RETURNS THE SOLUTION X OF
C     EQUALITY & INEQUALITY CONSTRAINED LEAST SQUARES PROBLEM LSEI :

C                MIN ||E*X - F||
C                 X

C                S.T.  C*X  = D,
C                      G*X >= H.

C     USING QR DECOMPOSITION & ORTHOGONAL BASIS OF NULLSPACE OF C
C     CHAPTER 23.6 OF LAWSON & HANSON: SOLVING LEAST SQUARES PROBLEMS.

C     THE FOLLOWING DIMENSIONS OF THE ARRAYS DEFINING THE PROBLEM
C     ARE NECESSARY
C     DIM(E) :   FORMAL (LE,N),    ACTUAL (ME,N)
C     DIM(F) :   FORMAL (LE  ),    ACTUAL (ME  )
C     DIM(C) :   FORMAL (LC,N),    ACTUAL (MC,N)
C     DIM(D) :   FORMAL (LC  ),    ACTUAL (MC  )
C     DIM(G) :   FORMAL (LG,N),    ACTUAL (MG,N)
C     DIM(H) :   FORMAL (LG  ),    ACTUAL (MG  )
C     DIM(X) :   FORMAL (N   ),    ACTUAL (N   )
C     DIM(W) :   2*MC+ME+(ME+MG)*(N-MC)  for LSEI
C              +(N-MC+1)*(MG+2)+2*MG     for LSI
C     DIM(JW):   MAX(MG,L)
C     ON ENTRY, THE USER HAS TO PROVIDE THE ARRAYS C, D, E, F, G, AND H.
C     ON RETURN, ALL ARRAYS WILL BE CHANGED BY THE SUBROUTINE.
C     X     STORES THE SOLUTION VECTOR
C     XNORM STORES THE RESIDUUM OF THE SOLUTION IN EUCLIDIAN NORM
C     W     STORES THE VECTOR OF LAGRANGE MULTIPLIERS IN ITS FIRST
C           MC+MG ELEMENTS
C     MODE  IS A SUCCESS-FAILURE FLAG WITH THE FOLLOWING MEANINGS:
C          MODE=1: SUCCESSFUL COMPUTATION
C               2: ERROR RETURN BECAUSE OF WRONG DIMENSIONS (N<1)
C               3: ITERATION COUNT EXCEEDED BY NNLS
C               4: INEQUALITY CONSTRAINTS INCOMPATIBLE
C               5: MATRIX E IS NOT OF FULL RANK
C               6: MATRIX C IS NOT OF FULL RANK
C               7: RANK DEFECT IN HFTI

C     18.5.1981, DIETER KRAFT, DFVLR OBERPFAFFENHOFEN
C     20.3.1987, DIETER KRAFT, DFVLR OBERPFAFFENHOFEN

      INTEGER          jw(*),i,ie,IF,ig,iw,j,k,krank,l,lc,LE,lg,
     .                 mc,mc1,me,mg,mode,n
      DOUBLE PRECISION c(lc,n),e(LE,n),g(lg,n),d(lc),f(LE),h(lg),x(n),
     .                 w(*),t,ddot_sl,xnrm,dnrm2_,epmach,ZERO
      DATA             epmach/2.22d-16/,ZERO/0.0d+00/

      mode=2
      IF(mc.GT.n)                      GOTO 75
      l=n-mc
      mc1=mc+1
      iw=(l+1)*(mg+2)+2*mg+mc
      ie=iw+mc+1
      IF=ie+me*l
      ig=IF+me

C  TRIANGULARIZE C AND APPLY FACTORS TO E AND G

      DO 10 i=1,mc
          j=MIN(i+1,lc)
          CALL h12(1,i,i+1,n,c(i,1),lc,w(iw+i),c(j,1),lc,1,mc-i)
          CALL h12(2,i,i+1,n,c(i,1),lc,w(iw+i),e     ,LE,1,me)
   10     CALL h12(2,i,i+1,n,c(i,1),lc,w(iw+i),g     ,lg,1,mg)

C  SOLVE C*X=D AND MODIFY F

      mode=6
      DO 15 i=1,mc
          IF(ABS(c(i,i)).LT.epmach)    GOTO 75
          x(i)=(d(i)-ddot_sl(i-1,c(i,1),lc,x,1))/c(i,i)
   15 CONTINUE
      mode=1
      w(mc1) = ZERO
      CALL dcopy_ (mg-mc,w(mc1),0,w(mc1),1)

      IF(mc.EQ.n)                      GOTO 50

      DO 20 i=1,me
   20     w(IF-1+i)=f(i)-ddot_sl(mc,e(i,1),LE,x,1)

C  STORE TRANSFORMED E & G

      DO 25 i=1,me
   25     CALL dcopy_(l,e(i,mc1),LE,w(ie-1+i),me)
      DO 30 i=1,mg
   30     CALL dcopy_(l,g(i,mc1),lg,w(ig-1+i),mg)

      IF(mg.GT.0)                      GOTO 40

C  SOLVE LS WITHOUT INEQUALITY CONSTRAINTS

      mode=7
      k=MAX(LE,n)
      t=SQRT(epmach)
      CALL hfti (w(ie),me,me,l,w(IF),k,1,t,krank,xnrm,w,w(l+1),jw)
      CALL dcopy_(l,w(IF),1,x(mc1),1)
      IF(krank.NE.l)                   GOTO 75
      mode=1
                                       GOTO 50
C  MODIFY H AND SOLVE INEQUALITY CONSTRAINED LS PROBLEM

   40 DO 45 i=1,mg
   45     h(i)=h(i)-ddot_sl(mc,g(i,1),lg,x,1)
      CALL lsi
     . (w(ie),w(IF),w(ig),h,me,me,mg,mg,l,x(mc1),xnrm,w(mc1),jw,mode)
      IF(mc.EQ.0)                      GOTO 75
      t=dnrm2_(mc,x,1)
      xnrm=SQRT(xnrm*xnrm+t*t)
      IF(mode.NE.1)                    GOTO 75

C  SOLUTION OF ORIGINAL PROBLEM AND LAGRANGE MULTIPLIERS

   50 DO 55 i=1,me
   55     f(i)=ddot_sl(n,e(i,1),LE,x,1)-f(i)
      DO 60 i=1,mc
   60     d(i)=ddot_sl(me,e(1,i),1,f,1)-ddot_sl(mg,g(1,i),1,w(mc1),1)

      DO 65 i=mc,1,-1
   65     CALL h12(2,i,i+1,n,c(i,1),lc,w(iw+i),x,1,1,1)

      DO 70 i=mc,1,-1
          j=MIN(i+1,lc)
          w(i)=(d(i)-ddot_sl(mc-i,c(j,i),1,w(j),1))/c(i,i)
   70 CONTINUE

C  END OF SUBROUTINE LSEI

   75                                  END

      SUBROUTINE lsi(e,f,g,h,LE,me,lg,mg,n,x,xnorm,w,jw,mode)

C     FOR MODE=1, THE SUBROUTINE RETURNS THE SOLUTION X OF
C     INEQUALITY CONSTRAINED LINEAR LEAST SQUARES PROBLEM:

C                    MIN ||E*X-F||
C                     X

C                    S.T.  G*X >= H

C     THE ALGORITHM IS BASED ON QR DECOMPOSITION AS DESCRIBED IN
C     CHAPTER 23.5 OF LAWSON & HANSON: SOLVING LEAST SQUARES PROBLEMS

C     THE FOLLOWING DIMENSIONS OF THE ARRAYS DEFINING THE PROBLEM
C     ARE NECESSARY
C     DIM(E) :   FORMAL (LE,N),    ACTUAL (ME,N)
C     DIM(F) :   FORMAL (LE  ),    ACTUAL (ME  )
C     DIM(G) :   FORMAL (LG,N),    ACTUAL (MG,N)
C     DIM(H) :   FORMAL (LG  ),    ACTUAL (MG  )
C     DIM(X) :   N
C     DIM(W) :   (N+1)*(MG+2) + 2*MG
C     DIM(JW):   LG
C     ON ENTRY, THE USER HAS TO PROVIDE THE ARRAYS E, F, G, AND H.
C     ON RETURN, ALL ARRAYS WILL BE CHANGED BY THE SUBROUTINE.
C     X     STORES THE SOLUTION VECTOR
C     XNORM STORES THE RESIDUUM OF THE SOLUTION IN EUCLIDIAN NORM
C     W     STORES THE VECTOR OF LAGRANGE MULTIPLIERS IN ITS FIRST
C           MG ELEMENTS
C     MODE  IS A SUCCESS-FAILURE FLAG WITH THE FOLLOWING MEANINGS:
C          MODE=1: SUCCESSFUL COMPUTATION
C               2: ERROR RETURN BECAUSE OF WRONG DIMENSIONS (N<1)
C               3: ITERATION COUNT EXCEEDED BY NNLS
C               4: INEQUALITY CONSTRAINTS INCOMPATIBLE
C               5: MATRIX E IS NOT OF FULL RANK

C     03.01.1980, DIETER KRAFT: CODED
C     20.03.1987, DIETER KRAFT: REVISED TO FORTRAN 77

      INTEGER          i,j,LE,lg,me,mg,mode,n,jw(lg)
      DOUBLE PRECISION e(LE,n),f(LE),g(lg,n),h(lg),x(n),w(*),
     .                 ddot_sl,xnorm,dnrm2_,epmach,t,one
      DATA             epmach/2.22d-16/,one/1.0d+00/

C  QR-FACTORS OF E AND APPLICATION TO F

      DO 10 i=1,n
      j=MIN(i+1,n)
      CALL h12(1,i,i+1,me,e(1,i),1,t,e(1,j),1,LE,n-i)
   10 CALL h12(2,i,i+1,me,e(1,i),1,t,f     ,1,1 ,1  )

C  TRANSFORM G AND H TO GET LEAST DISTANCE PROBLEM

      mode=5
      DO 30 i=1,mg
          DO 20 j=1,n
              IF (ABS(e(j,j)).LT.epmach) GOTO 50
   20         g(i,j)=(g(i,j)-ddot_sl(j-1,g(i,1),lg,e(1,j),1))/e(j,j)
   30     h(i)=h(i)-ddot_sl(n,g(i,1),lg,f,1)

C  SOLVE LEAST DISTANCE PROBLEM

      CALL ldp(g,lg,mg,n,h,x,xnorm,w,jw,mode)
      IF (mode.NE.1)                     GOTO 50

C  SOLUTION OF ORIGINAL PROBLEM

      CALL daxpy_sl(n,one,f,1,x,1)
      DO 40 i=n,1,-1
          j=MIN(i+1,n)
   40     x(i)=(x(i)-ddot_sl(n-i,e(i,j),LE,x(j),1))/e(i,i)
      j=MIN(n+1,me)
      t=dnrm2_(me-n,f(j),1)
      xnorm=SQRT(xnorm*xnorm+t*t)

C  END OF SUBROUTINE LSI

   50                                    END

      SUBROUTINE ldp(g,mg,m,n,h,x,xnorm,w,INDEX,mode)

C                     T
C     MINIMIZE   1/2 X X    SUBJECT TO   G * X >= H.

C       C.L. LAWSON, R.J. HANSON: 'SOLVING LEAST SQUARES PROBLEMS'
C       PRENTICE HALL, ENGLEWOOD CLIFFS, NEW JERSEY, 1974.

C     PARAMETER DESCRIPTION:

C     G(),MG,M,N   ON ENTRY G() STORES THE M BY N MATRIX OF
C                  LINEAR INEQUALITY CONSTRAINTS. G() HAS FIRST
C                  DIMENSIONING PARAMETER MG
C     H()          ON ENTRY H() STORES THE M VECTOR H REPRESENTING
C                  THE RIGHT SIDE OF THE INEQUALITY SYSTEM

C     REMARK: G(),H() WILL NOT BE CHANGED DURING CALCULATIONS BY LDP

C     X()          ON ENTRY X() NEED NOT BE INITIALIZED.
C                  ON EXIT X() STORES THE SOLUTION VECTOR X IF MODE=1.
C     XNORM        ON EXIT XNORM STORES THE EUCLIDIAN NORM OF THE
C                  SOLUTION VECTOR IF COMPUTATION IS SUCCESSFUL
C     W()          W IS A ONE DIMENSIONAL WORKING SPACE, THE LENGTH
C                  OF WHICH SHOULD BE AT LEAST (M+2)*(N+1) + 2*M
C                  ON EXIT W() STORES THE LAGRANGE MULTIPLIERS
C                  ASSOCIATED WITH THE CONSTRAINTS
C                  AT THE SOLUTION OF PROBLEM LDP
C     INDEX()      INDEX() IS A ONE DIMENSIONAL INTEGER WORKING SPACE
C                  OF LENGTH AT LEAST M
C     MODE         MODE IS A SUCCESS-FAILURE FLAG WITH THE FOLLOWING
C                  MEANINGS:
C          MODE=1: SUCCESSFUL COMPUTATION
C               2: ERROR RETURN BECAUSE OF WRONG DIMENSIONS (N.LE.0)
C               3: ITERATION COUNT EXCEEDED BY NNLS
C               4: INEQUALITY CONSTRAINTS INCOMPATIBLE

      DOUBLE PRECISION g,h,x,xnorm,w,u,v,
     .                 ZERO,one,fac,rnorm,dnrm2_,ddot_sl,diff
      INTEGER          INDEX,i,IF,iw,iwdual,iy,iz,j,m,mg,mode,n,n1
      DIMENSION        g(mg,n),h(m),x(n),w(*),INDEX(m)
      diff(u,v)=       u-v
      DATA             ZERO,one/0.0d0,1.0d0/

      mode=2
      IF(n.LE.0)                    GOTO 50

C  STATE DUAL PROBLEM

      mode=1
      x(1)=ZERO
      CALL dcopy_(n,x(1),0,x,1)
      xnorm=ZERO
      IF(m.EQ.0)                    GOTO 50
      iw=0
      DO 20 j=1,m
          DO 10 i=1,n
              iw=iw+1
   10         w(iw)=g(j,i)
          iw=iw+1
   20     w(iw)=h(j)
      IF=iw+1
      DO 30 i=1,n
          iw=iw+1
   30     w(iw)=ZERO
      w(iw+1)=one
      n1=n+1
      iz=iw+2
      iy=iz+n1
      iwdual=iy+m

C  SOLVE DUAL PROBLEM

      CALL nnls (w,n1,n1,m,w(IF),w(iy),rnorm,w(iwdual),w(iz),INDEX,mode)

      IF(mode.NE.1)                 GOTO 50
      mode=4
      IF(rnorm.LE.ZERO)             GOTO 50

C  COMPUTE SOLUTION OF PRIMAL PROBLEM

      fac=one-ddot_sl(m,h,1,w(iy),1)
      IF(diff(one+fac,one).LE.ZERO) GOTO 50
      mode=1
      fac=one/fac
      DO 40 j=1,n
   40     x(j)=fac*ddot_sl(m,g(1,j),1,w(iy),1)
      xnorm=dnrm2_(n,x,1)

C  COMPUTE LAGRANGE MULTIPLIERS FOR PRIMAL PROBLEM

      w(1)=ZERO
      CALL dcopy_(m,w(1),0,w,1)
      CALL daxpy_sl(m,fac,w(iy),1,w,1)

C  END OF SUBROUTINE LDP

   50                               END

c     SUBROUTINE nnls (a, mda, m, n, b, x, rnorm, w, z, INDEX, mode)

C     C.L.LAWSON AND R.J.HANSON, JET PROPULSION LABORATORY:
C     'SOLVING LEAST SQUARES PROBLEMS'. PRENTICE-HALL.1974

C      **********   NONNEGATIVE LEAST SQUARES   **********

C     GIVEN AN M BY N MATRIX, A, AND AN M-VECTOR, B, COMPUTE AN
C     N-VECTOR, X, WHICH SOLVES THE LEAST SQUARES PROBLEM

C                  A*X = B  SUBJECT TO  X >= 0

C     A(),MDA,M,N
C            MDA IS THE FIRST DIMENSIONING PARAMETER FOR THE ARRAY,A().
C            ON ENTRY A()  CONTAINS THE M BY N MATRIX,A.
C            ON EXIT A() CONTAINS THE PRODUCT Q*A,
C            WHERE Q IS AN M BY M ORTHOGONAL MATRIX GENERATED
C            IMPLICITLY BY THIS SUBROUTINE.
C            EITHER M>=N OR M<N IS PERMISSIBLE.
C            THERE IS NO RESTRICTION ON THE RANK OF A.
C     B()    ON ENTRY B() CONTAINS THE M-VECTOR, B.
C            ON EXIT B() CONTAINS Q*B.
C     X()    ON ENTRY X() NEED NOT BE INITIALIZED.
C            ON EXIT X() WILL CONTAIN THE SOLUTION VECTOR.
C     RNORM  ON EXIT RNORM CONTAINS THE EUCLIDEAN NORM OF THE
C            RESIDUAL VECTOR.
C     W()    AN N-ARRAY OF WORKING SPACE.
C            ON EXIT W() WILL CONTAIN THE DUAL SOLUTION VECTOR.
C            W WILL SATISFY W(I)=0 FOR ALL I IN SET P
C            AND W(I)<=0 FOR ALL I IN SET Z
C     Z()    AN M-ARRAY OF WORKING SPACE.
C     INDEX()AN INTEGER WORKING ARRAY OF LENGTH AT LEAST N.
C            ON EXIT THE CONTENTS OF THIS ARRAY DEFINE THE SETS
C            P AND Z AS FOLLOWS:
C            INDEX(1)    THRU INDEX(NSETP) = SET P.
C            INDEX(IZ1)  THRU INDEX (IZ2)  = SET Z.
C            IZ1=NSETP + 1 = NPP1, IZ2=N.
C     MODE   THIS IS A SUCCESS-FAILURE FLAG WITH THE FOLLOWING MEANING:
C            1    THE SOLUTION HAS BEEN COMPUTED SUCCESSFULLY.
C            2    THE DIMENSIONS OF THE PROBLEM ARE WRONG,
C                 EITHER M <= 0 OR N <= 0.
C            3    ITERATION COUNT EXCEEDED, MORE THAN 3*N ITERATIONS.

c     INTEGER          i,ii,ip,iter,itmax,iz,izmax,iz1,iz2,j,jj,jz,
c    *                 k,l,m,mda,mode,n,npp1,nsetp,INDEX(n)

c     DOUBLE PRECISION a(mda,n),b(m),x(n),w(n),z(m),asave,diff,
c    *                 factor,ddot_sl,ZERO,one,wmax,alpha,
c    *                 c,s,t,u,v,up,rnorm,unorm,dnrm2_

c     diff(u,v)=       u-v

c     DATA             ZERO,one,factor/0.0d0,1.0d0,1.0d-2/

c     revised          Dieter Kraft, March 1983

c     mode=2
c     IF(m.LE.0.OR.n.LE.0)            GOTO 290
c     mode=1
c     iter=0
c     itmax=3*n

C STEP ONE (INITIALIZE)

c     DO 100 i=1,n
c 100    INDEX(i)=i
c     iz1=1
c     iz2=n
c     nsetp=0
c     npp1=1
c     x(1)=ZERO
c     CALL dcopy_(n,x(1),0,x,1)

C STEP TWO (COMPUTE DUAL VARIABLES)
C .....ENTRY LOOP A

c 110 IF(iz1.GT.iz2.OR.nsetp.GE.m)    GOTO 280
c     DO 120 iz=iz1,iz2
c        j=INDEX(iz)
c 120    w(j)=ddot_sl(m-nsetp,a(npp1,j),1,b(npp1),1)

C STEP THREE (TEST DUAL VARIABLES)

c 130 wmax=ZERO
c     DO 140 iz=iz1,iz2
c     j=INDEX(iz)
c        IF(w(j).LE.wmax)             GOTO 140
c        wmax=w(j)
c        izmax=iz
c 140 CONTINUE

C .....EXIT LOOP A

c     IF(wmax.LE.ZERO)                GOTO 280
c     iz=izmax
c     j=INDEX(iz)

C STEP FOUR (TEST INDEX J FOR LINEAR DEPENDENCY)

c     asave=a(npp1,j)
c     CALL h12(1,npp1,npp1+1,m,a(1,j),1,up,z,1,1,0)
c     unorm=dnrm2_(nsetp,a(1,j),1)
c     t=factor*ABS(a(npp1,j))
c     IF(diff(unorm+t,unorm).LE.ZERO) GOTO 150
c     CALL dcopy_(m,b,1,z,1)
c     CALL h12(2,npp1,npp1+1,m,a(1,j),1,up,z,1,1,1)
c     IF(z(npp1)/a(npp1,j).GT.ZERO)   GOTO 160
c 150 a(npp1,j)=asave
c     w(j)=ZERO
c                                     GOTO 130
C STEP FIVE (ADD COLUMN)

c 160 CALL dcopy_(m,z,1,b,1)
c     INDEX(iz)=INDEX(iz1)
c     INDEX(iz1)=j
c     iz1=iz1+1
c     nsetp=npp1
c     npp1=npp1+1
c     DO 170 jz=iz1,iz2
c        jj=INDEX(jz)
c 170    CALL h12(2,nsetp,npp1,m,a(1,j),1,up,a(1,jj),1,mda,1)
c     k=MIN(npp1,mda)
c     w(j)=ZERO
c     CALL dcopy_(m-nsetp,w(j),0,a(k,j),1)

C STEP SIX (SOLVE LEAST SQUARES SUB-PROBLEM)
C .....ENTRY LOOP B

c 180 DO 200 ip=nsetp,1,-1
c        IF(ip.EQ.nsetp)              GOTO 190
c        CALL daxpy_sl(ip,-z(ip+1),a(1,jj),1,z,1)
c 190    jj=INDEX(ip)
c 200    z(ip)=z(ip)/a(ip,jj)
c     iter=iter+1
c     IF(iter.LE.itmax)               GOTO 220
c 210 mode=3
c                                     GOTO 280
C STEP SEVEN TO TEN (STEP LENGTH ALGORITHM)

c 220 alpha=one
c     jj=0
c     DO 230 ip=1,nsetp
c        IF(z(ip).GT.ZERO)            GOTO 230
c        l=INDEX(ip)
c        t=-x(l)/(z(ip)-x(l))
c        IF(alpha.LT.t)               GOTO 230
c        alpha=t
c        jj=ip
c 230 CONTINUE
c     DO 240 ip=1,nsetp
c        l=INDEX(ip)
c 240    x(l)=(one-alpha)*x(l) + alpha*z(ip)

C .....EXIT LOOP B

c     IF(jj.EQ.0)                     GOTO 110

C STEP ELEVEN (DELETE COLUMN)

c     i=INDEX(jj)
c 250 x(i)=ZERO
c     jj=jj+1
c     DO 260 j=jj,nsetp
c        ii=INDEX(j)
c        INDEX(j-1)=ii
c        CALL dsrotg(a(j-1,ii),a(j,ii),c,s)
c        t=a(j-1,ii)
c        CALL dsrot(n,a(j-1,1),mda,a(j,1),mda,c,s)
c        a(j-1,ii)=t
c        a(j,ii)=ZERO
c 260    CALL dsrot(1,b(j-1),1,b(j),1,c,s)
c     npp1=nsetp
c     nsetp=nsetp-1
c     iz1=iz1-1
c     INDEX(iz1)=i
c     IF(nsetp.LE.0)                  GOTO 210
c     DO 270 jj=1,nsetp
c        i=INDEX(jj)
c        IF(x(i).LE.ZERO)             GOTO 250
c 270 CONTINUE
c     CALL dcopy_(m,b,1,z,1)
c                                     GOTO 180
C STEP TWELVE (SOLUTION)

c 280 k=MIN(npp1,m)
c     rnorm=dnrm2_(m-nsetp,b(k),1)
c     IF(npp1.GT.m) THEN
c        w(1)=ZERO
c        CALL dcopy_(n,w(1),0,w,1)
c     ENDIF

C END OF SUBROUTINE NNLS

  290                                 END

      SUBROUTINE hfti(a,mda,m,n,b,mdb,nb,tau,krank,rnorm,h,g,ip)

C     RANK-DEFICIENT LEAST SQUARES ALGORITHM AS DESCRIBED IN:
C     C.L.LAWSON AND R.J.HANSON, JET PROPULSION LABORATORY, 1973 JUN 12
C     TO APPEAR IN 'SOLVING LEAST SQUARES PROBLEMS', PRENTICE-HALL, 1974

C     A(*,*),MDA,M,N   THE ARRAY A INITIALLY CONTAINS THE M x N MATRIX A
C                      OF THE LEAST SQUARES PROBLEM AX = B.
C                      THE FIRST DIMENSIONING PARAMETER MDA MUST SATISFY
C                      MDA >= M. EITHER M >= N OR M < N IS PERMITTED.
C                      THERE IS NO RESTRICTION ON THE RANK OF A.
C                      THE MATRIX A WILL BE MODIFIED BY THE SUBROUTINE.
C     B(*,*),MDB,NB    IF NB = 0 THE SUBROUTINE WILL MAKE NO REFERENCE
C                      TO THE ARRAY B. IF NB > 0 THE ARRAY B() MUST
C                      INITIALLY CONTAIN THE M x NB MATRIX B  OF THE
C                      THE LEAST SQUARES PROBLEM AX = B AND ON RETURN
C                      THE ARRAY B() WILL CONTAIN THE N x NB SOLUTION X.
C                      IF NB>1 THE ARRAY B() MUST BE DOUBLE SUBSCRIPTED
C                      WITH FIRST DIMENSIONING PARAMETER MDB>=MAX(M,N),
C                      IF NB=1 THE ARRAY B() MAY BE EITHER SINGLE OR
C                      DOUBLE SUBSCRIPTED.
C     TAU              ABSOLUTE TOLERANCE PARAMETER FOR PSEUDORANK
C                      DETERMINATION, PROVIDED BY THE USER.
C     KRANK            PSEUDORANK OF A, SET BY THE SUBROUTINE.
C     RNORM            ON EXIT, RNORM(J) WILL CONTAIN THE EUCLIDIAN
C                      NORM OF THE RESIDUAL VECTOR FOR THE PROBLEM
C                      DEFINED BY THE J-TH COLUMN VECTOR OF THE ARRAY B.
C     H(), G()         ARRAYS OF WORKING SPACE OF LENGTH >= N.
C     IP()             INTEGER ARRAY OF WORKING SPACE OF LENGTH >= N
C                      RECORDING PERMUTATION INDICES OF COLUMN VECTORS

      INTEGER          i,j,jb,k,kp1,krank,l,ldiag,lmax,m,
     .                 mda,mdb,n,nb,ip(n)
      DOUBLE PRECISION a(mda,n),b(mdb,nb),h(n),g(n),rnorm(nb),factor,
     .                 tau,ZERO,hmax,diff,tmp,ddot_sl,dnrm2_,u,v
      diff(u,v)=       u-v
      DATA             ZERO/0.0d0/, factor/1.0d-3/

      k=0
      ldiag=MIN(m,n)
      IF(ldiag.LE.0)                  GOTO 270

C   COMPUTE LMAX

      DO 80 j=1,ldiag
          IF(j.EQ.1)                  GOTO 20
          lmax=j
          DO 10 l=j,n
              h(l)=h(l)-a(j-1,l)**2
   10         IF(h(l).GT.h(lmax)) lmax=l
          IF(diff(hmax+factor*h(lmax),hmax).GT.ZERO)
     .                                GOTO 50
   20     lmax=j
          DO 40 l=j,n
              h(l)=ZERO
              DO 30 i=j,m
   30             h(l)=h(l)+a(i,l)**2
   40         IF(h(l).GT.h(lmax)) lmax=l
          hmax=h(lmax)

C   COLUMN INTERCHANGES IF NEEDED

   50     ip(j)=lmax
          IF(ip(j).EQ.j)              GOTO 70
          DO 60 i=1,m
              tmp=a(i,j)
              a(i,j)=a(i,lmax)
   60         a(i,lmax)=tmp
          h(lmax)=h(j)

C   J-TH TRANSFORMATION AND APPLICATION TO A AND B

   70     i=MIN(j+1,n)
          CALL h12(1,j,j+1,m,a(1,j),1,h(j),a(1,i),1,mda,n-j)
   80     CALL h12(2,j,j+1,m,a(1,j),1,h(j),b,1,mdb,nb)

C   DETERMINE PSEUDORANK

      DO 90 j=1,ldiag
   90     IF(ABS(a(j,j)).LE.tau)      GOTO 100
      k=ldiag
      GOTO 110
  100 k=j-1
  110 kp1=k+1

C   NORM OF RESIDUALS

      DO 130 jb=1,nb
  130     rnorm(jb)=dnrm2_(m-k,b(kp1,jb),1)
      IF(k.GT.0)                      GOTO 160
      DO 150 jb=1,nb
          DO 150 i=1,n
  150         b(i,jb)=ZERO
      GOTO 270
  160 IF(k.EQ.n)                      GOTO 180

C   HOUSEHOLDER DECOMPOSITION OF FIRST K ROWS

      DO 170 i=k,1,-1
  170     CALL h12(1,i,kp1,n,a(i,1),mda,g(i),a,mda,1,i-1)
  180 DO 250 jb=1,nb

C   SOLVE K*K TRIANGULAR SYSTEM

          DO 210 i=k,1,-1
              j=MIN(i+1,n)
  210         b(i,jb)=(b(i,jb)-ddot_sl(k-i,a(i,j),mda,b(j,jb),1))/a(i,i)

C   COMPLETE SOLUTION VECTOR

          IF(k.EQ.n)                  GOTO 240
          DO 220 j=kp1,n
  220         b(j,jb)=ZERO
          DO 230 i=1,k
  230         CALL h12(2,i,kp1,n,a(i,1),mda,g(i),b(1,jb),1,mdb,1)

C   REORDER SOLUTION ACCORDING TO PREVIOUS COLUMN INTERCHANGES

  240     DO 250 j=ldiag,1,-1
              IF(ip(j).EQ.j)          GOTO 250
              l=ip(j)
              tmp=b(l,jb)
              b(l,jb)=b(j,jb)
              b(j,jb)=tmp
  250 CONTINUE
  270 krank=k
      END

c     SUBROUTINE h12 (mode,lpivot,l1,m,u,iue,up,c,ice,icv,ncv)

C     C.L.LAWSON AND R.J.HANSON, JET PROPULSION LABORATORY, 1973 JUN 12
C     TO APPEAR IN 'SOLVING LEAST SQUARES PROBLEMS', PRENTICE-HALL, 1974

C     CONSTRUCTION AND/OR APPLICATION OF A SINGLE
C     HOUSEHOLDER TRANSFORMATION  Q = I + U*(U**T)/B

C     MODE    = 1 OR 2   TO SELECT ALGORITHM  H1  OR  H2 .
C     LPIVOT IS THE INDEX OF THE PIVOT ELEMENT.
C     L1,M   IF L1 <= M   THE TRANSFORMATION WILL BE CONSTRUCTED TO
C            ZERO ELEMENTS INDEXED FROM L1 THROUGH M.
C            IF L1 > M THE SUBROUTINE DOES AN IDENTITY TRANSFORMATION.
C     U(),IUE,UP
C            ON ENTRY TO H1 U() STORES THE PIVOT VECTOR.
C            IUE IS THE STORAGE INCREMENT BETWEEN ELEMENTS.
C            ON EXIT FROM H1 U() AND UP STORE QUANTITIES DEFINING
C            THE VECTOR U OF THE HOUSEHOLDER TRANSFORMATION.
C            ON ENTRY TO H2 U() AND UP
C            SHOULD STORE QUANTITIES PREVIOUSLY COMPUTED BY H1.
C            THESE WILL NOT BE MODIFIED BY H2.
C     C()    ON ENTRY TO H1 OR H2 C() STORES A MATRIX WHICH WILL BE
C            REGARDED AS A SET OF VECTORS TO WHICH THE HOUSEHOLDER
C            TRANSFORMATION IS TO BE APPLIED.
C            ON EXIT C() STORES THE SET OF TRANSFORMED VECTORS.
C     ICE    STORAGE INCREMENT BETWEEN ELEMENTS OF VECTORS IN C().
C     ICV    STORAGE INCREMENT BETWEEN VECTORS IN C().
C     NCV    NUMBER OF VECTORS IN C() TO BE TRANSFORMED.
C            IF NCV <= 0 NO OPERATIONS WILL BE DONE ON C().

c     INTEGER          incr, ice, icv, iue, lpivot, l1, mode, ncv
c     INTEGER          i, i2, i3, i4, j, m
c     DOUBLE PRECISION u,up,c,cl,clinv,b,sm,one,ZERO
c     DIMENSION        u(iue,*), c(*)
c     DATA             one/1.0d+00/, ZERO/0.0d+00/

c     IF (0.GE.lpivot.OR.lpivot.GE.l1.OR.l1.GT.m) GOTO 80
c     cl=ABS(u(1,lpivot))
c     IF (mode.EQ.2)                              GOTO 30

C     ****** CONSTRUCT THE TRANSFORMATION ******

c         DO 10 j=l1,m
c            sm=ABS(u(1,j))
c  10     cl=MAX(sm,cl)
c     IF (cl.LE.ZERO)                             GOTO 80
c     clinv=one/cl
c     sm=(u(1,lpivot)*clinv)**2
c         DO 20 j=l1,m
c  20     sm=sm+(u(1,j)*clinv)**2
c     cl=cl*SQRT(sm)
c     IF (u(1,lpivot).GT.ZERO) cl=-cl
c     up=u(1,lpivot)-cl
c     u(1,lpivot)=cl
c                                                 GOTO 40
C     ****** APPLY THE TRANSFORMATION  I+U*(U**T)/B  TO C ******

c  30 IF (cl.LE.ZERO)                             GOTO 80
c  40 IF (ncv.LE.0)                               GOTO 80
c     b=up*u(1,lpivot)
c     IF (b.GE.ZERO)                              GOTO 80
c     b=one/b
c     i2=1-icv+ice*(lpivot-1)
c     incr=ice*(l1-lpivot)
c         DO 70 j=1,ncv
c         i2=i2+icv
c         i3=i2+incr
c         i4=i3
c         sm=c(i2)*up
c             DO 50 i=l1,m
c             sm=sm+c(i3)*u(1,i)
c  50         i3=i3+ice
c         IF (sm.EQ.ZERO)                         GOTO 70
c         sm=sm*b
c         c(i2)=c(i2)+sm*up
c             DO 60 i=l1,m
c             c(i4)=c(i4)+sm*u(1,i)
c  60         i4=i4+ice
c  70     CONTINUE
c  80                                             END

      SUBROUTINE ldl (n,a,z,sigma,w)
C   LDL     LDL' - RANK-ONE - UPDATE

C   PURPOSE:
C           UPDATES THE LDL' FACTORS OF MATRIX A BY RANK-ONE MATRIX
C           SIGMA*Z*Z'

C   INPUT ARGUMENTS: (* MEANS PARAMETERS ARE CHANGED DURING EXECUTION)
C     N     : ORDER OF THE COEFFICIENT MATRIX A
C   * A     : POSITIVE DEFINITE MATRIX OF DIMENSION N;
C             ONLY THE LOWER TRIANGLE IS USED AND IS STORED COLUMN BY
C             COLUMN AS ONE DIMENSIONAL ARRAY OF DIMENSION N*(N+1)/2.
C   * Z     : VECTOR OF DIMENSION N OF UPDATING ELEMENTS
C     SIGMA : SCALAR FACTOR BY WHICH THE MODIFYING DYADE Z*Z' IS
C             MULTIPLIED

C   OUTPUT ARGUMENTS:
C     A     : UPDATED LDL' FACTORS

C   WORKING ARRAY:
C     W     : VECTOR OP DIMENSION N (USED ONLY IF SIGMA .LT. ZERO)

C   METHOD:
C     THAT OF FLETCHER AND POWELL AS DESCRIBED IN :
C     FLETCHER,R.,(1974) ON THE MODIFICATION OF LDL' FACTORIZATION.
C     POWELL,M.J.D.      MATH.COMPUTATION 28, 1067-1078.

C   IMPLEMENTED BY:
C     KRAFT,D., DFVLR - INSTITUT FUER DYNAMIK DER FLUGSYSTEME
C               D-8031  OBERPFAFFENHOFEN

C   STATUS: 15. JANUARY 1980

C   SUBROUTINES REQUIRED: NONE

      INTEGER          i, ij, j, n
      DOUBLE PRECISION a(*), t, v, w(*), z(*), u, tp, one, beta, four,
     *                 ZERO, alpha, delta, gamma, sigma, epmach
      DATA ZERO, one, four, epmach /0.0d0, 1.0d0, 4.0d0, 2.22d-16/

      IF(sigma.EQ.ZERO)               GOTO 280
      ij=1
      t=one/sigma
      IF(sigma.GT.ZERO)               GOTO 220
C PREPARE NEGATIVE UPDATE
      DO 150 i=1,n
  150     w(i)=z(i)
      DO 170 i=1,n
          v=w(i)
          t=t+v*v/a(ij)
          DO 160 j=i+1,n
              ij=ij+1
  160         w(j)=w(j)-v*a(ij)
  170     ij=ij+1
      IF(t.GE.ZERO) t=epmach/sigma
      DO 210 i=1,n
          j=n+1-i
          ij=ij-i
          u=w(j)
          w(j)=t
  210     t=t-u*u/a(ij)
  220 CONTINUE
C HERE UPDATING BEGINS
      DO 270 i=1,n
          v=z(i)
          delta=v/a(ij)
          IF(sigma.LT.ZERO) tp=w(i)
          IF(sigma.GT.ZERO) tp=t+delta*v
          alpha=tp/t
          a(ij)=alpha*a(ij)
          IF(i.EQ.n)                  GOTO 280
          beta=delta/tp
          IF(alpha.GT.four)           GOTO 240
          DO 230 j=i+1,n
              ij=ij+1
              z(j)=z(j)-v*a(ij)
  230         a(ij)=a(ij)+beta*z(j)
                                      GOTO 260
  240     gamma=t/tp
          DO 250 j=i+1,n
              ij=ij+1
              u=a(ij)
              a(ij)=gamma*u+beta*z(j)
  250         z(j)=z(j)-v*u
  260     ij=ij+1
  270     t=tp
  280 RETURN
C END OF LDL
      END

      DOUBLE PRECISION FUNCTION linmin (mode, ax, bx, f, tol)
C   LINMIN  LINESEARCH WITHOUT DERIVATIVES

C   PURPOSE:

C  TO FIND THE ARGUMENT LINMIN WHERE THE FUNCTION F TAKES IT'S MINIMUM
C  ON THE INTERVAL AX, BX.
C  COMBINATION OF GOLDEN SECTION AND SUCCESSIVE QUADRATIC INTERPOLATION.

C   INPUT ARGUMENTS: (* MEANS PARAMETERS ARE CHANGED DURING EXECUTION)

C *MODE   SEE OUTPUT ARGUMENTS
C  AX     LEFT ENDPOINT OF INITIAL INTERVAL
C  BX     RIGHT ENDPOINT OF INITIAL INTERVAL
C  F      FUNCTION VALUE AT LINMIN WHICH IS TO BE BROUGHT IN BY
C         REVERSE COMMUNICATION CONTROLLED BY MODE
C  TOL    DESIRED LENGTH OF INTERVAL OF UNCERTAINTY OF FINAL RESULT

C   OUTPUT ARGUMENTS:

C  LINMIN ABSCISSA APPROXIMATING THE POINT WHERE F ATTAINS A MINIMUM
C  MODE   CONTROLS REVERSE COMMUNICATION
C         MUST BE SET TO 0 INITIALLY, RETURNS WITH INTERMEDIATE
C         VALUES 1 AND 2 WHICH MUST NOT BE CHANGED BY THE USER,
C         ENDS WITH CONVERGENCE WITH VALUE 3.

C   WORKING ARRAY:

C  NONE

C   METHOD:

C  THIS FUNCTION SUBPROGRAM IS A SLIGHTLY MODIFIED VERSION OF THE
C  ALGOL 60 PROCEDURE LOCALMIN GIVEN IN
C  R.P. BRENT: ALGORITHMS FOR MINIMIZATION WITHOUT DERIVATIVES,
C              PRENTICE-HALL (1973).

C   IMPLEMENTED BY:

C     KRAFT, D., DFVLR - INSTITUT FUER DYNAMIK DER FLUGSYSTEME
C                D-8031  OBERPFAFFENHOFEN

C   STATUS: 31. AUGUST  1984

C   SUBROUTINES REQUIRED: NONE

      INTEGER          mode
      DOUBLE PRECISION f, tol, a, b, c, d, e, p, q, r, u, v, w, x, m,
     &                 fu, fv, fw, fx, eps, tol1, tol2, ZERO, ax, bx
      DATA             c /0.381966011d0/, eps /1.5d-8/, ZERO /0.0d0/

C  EPS = SQUARE - ROOT OF MACHINE PRECISION
C  C = GOLDEN SECTION RATIO = (3-SQRT(5))/2

      GOTO (10, 55), mode

C  INITIALIZATION

      a = ax
      b = bx
      e = ZERO
      v = a + c*(b - a)
      w = v
      x = w
      linmin = x
      mode = 1
      GOTO 100

C  MAIN LOOP STARTS HERE

   10 fx = f
      fv = fx
      fw = fv
   20 m = 0.5d0*(a + b)
      tol1 = eps*ABS(x) + tol
      tol2 = tol1 + tol1

C  TEST CONVERGENCE

      IF (ABS(x - m) .LE. tol2 - 0.5d0*(b - a)) GOTO 90
      r = ZERO
      q = r
      p = q
      IF (ABS(e) .LE. tol1) GOTO 30

C  FIT PARABOLA

      r = (x - w)*(fx - fv)
      q = (x - v)*(fx - fw)
      p = (x - v)*q - (x - w)*r
      q = q - r
      q = q + q
      IF (q .GT. ZERO) p = -p
      IF (q .LT. ZERO) q = -q
      r = e
      e = d

C  IS PARABOLA ACCEPTABLE

   30 IF (ABS(p) .GE. 0.5d0*ABS(q*r) .OR.
     &    p .LE. q*(a - x) .OR. p .GE. q*(b-x)) GOTO 40

C  PARABOLIC INTERPOLATION STEP

      d = p/q

C  F MUST NOT BE EVALUATED TOO CLOSE TO A OR B

      IF (u - a .LT. tol2) d = SIGN(tol1, m - x)
      IF (b - u .LT. tol2) d = SIGN(tol1, m - x)
      GOTO 50

C  GOLDEN SECTION STEP

   40 IF (x .GE. m) e = a - x
      IF (x .LT. m) e = b - x
      d = c*e

C  F MUST NOT BE EVALUATED TOO CLOSE TO X

   50 IF (ABS(d) .LT. tol1) d = SIGN(tol1, d)
      u = x + d
      linmin = u
      mode = 2
      GOTO 100
   55 fu = f

C  UPDATE A, B, V, W, AND X

      IF (fu .GT. fx) GOTO 60
      IF (u .GE. x) a = x
      IF (u .LT. x) b = x
      v = w
      fv = fw
      w = x
      fw = fx
      x = u
      fx = fu
      GOTO 85
   60 IF (u .LT. x) a = u
      IF (u .GE. x) b = u
      IF (fu .LE. fw .OR. w .EQ. x) GOTO 70
      IF (fu .LE. fv .OR. v .EQ. x .OR. v .EQ. w) GOTO 80
      GOTO 85
   70 v = w
      fv = fw
      w = u
      fw = fu
      GOTO 85
   80 v = u
      fv = fu
   85 GOTO 20

C  END OF MAIN LOOP

   90 linmin = x
      mode = 3
  100 RETURN

C  END OF LINMIN

      END

C## Following a selection from BLAS Level 1

      SUBROUTINE daxpy_sl(n,da,dx,incx,dy,incy)

C     CONSTANT TIMES A VECTOR PLUS A VECTOR.
C     USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE.
C     JACK DONGARRA, LINPACK, 3/11/78.

      DOUBLE PRECISION dx(*),dy(*),da
      INTEGER i,incx,incy,ix,iy,m,mp1,n

      IF(n.LE.0)RETURN
      IF(da.EQ.0.0d0)RETURN
      IF(incx.EQ.1.AND.incy.EQ.1)GO TO 20

C        CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS
C        NOT EQUAL TO 1

      ix = 1
      iy = 1
      IF(incx.LT.0)ix = (-n+1)*incx + 1
      IF(incy.LT.0)iy = (-n+1)*incy + 1
      DO 10 i = 1,n
        dy(iy) = dy(iy) + da*dx(ix)
        ix = ix + incx
        iy = iy + incy
   10 CONTINUE
      RETURN

C        CODE FOR BOTH INCREMENTS EQUAL TO 1

C        CLEAN-UP LOOP

   20 m = MOD(n,4)
      IF( m .EQ. 0 ) GO TO 40
      DO 30 i = 1,m
        dy(i) = dy(i) + da*dx(i)
   30 CONTINUE
      IF( n .LT. 4 ) RETURN
   40 mp1 = m + 1
      DO 50 i = mp1,n,4
        dy(i) = dy(i) + da*dx(i)
        dy(i + 1) = dy(i + 1) + da*dx(i + 1)
        dy(i + 2) = dy(i + 2) + da*dx(i + 2)
        dy(i + 3) = dy(i + 3) + da*dx(i + 3)
   50 CONTINUE
      RETURN
      END

      SUBROUTINE  dcopy_(n,dx,incx,dy,incy)

C     COPIES A VECTOR, X, TO A VECTOR, Y.
C     USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE.
C     JACK DONGARRA, LINPACK, 3/11/78.

      DOUBLE PRECISION dx(*),dy(*)
      INTEGER i,incx,incy,ix,iy,m,mp1,n

      IF(n.LE.0)RETURN
      IF(incx.EQ.1.AND.incy.EQ.1)GO TO 20

C        CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS
C        NOT EQUAL TO 1

      ix = 1
      iy = 1
      IF(incx.LT.0)ix = (-n+1)*incx + 1
      IF(incy.LT.0)iy = (-n+1)*incy + 1
      DO 10 i = 1,n
        dy(iy) = dx(ix)
        ix = ix + incx
        iy = iy + incy
   10 CONTINUE
      RETURN

C        CODE FOR BOTH INCREMENTS EQUAL TO 1

C        CLEAN-UP LOOP

   20 m = MOD(n,7)
      IF( m .EQ. 0 ) GO TO 40
      DO 30 i = 1,m
        dy(i) = dx(i)
   30 CONTINUE
      IF( n .LT. 7 ) RETURN
   40 mp1 = m + 1
      DO 50 i = mp1,n,7
        dy(i) = dx(i)
        dy(i + 1) = dx(i + 1)
        dy(i + 2) = dx(i + 2)
        dy(i + 3) = dx(i + 3)
        dy(i + 4) = dx(i + 4)
        dy(i + 5) = dx(i + 5)
        dy(i + 6) = dx(i + 6)
   50 CONTINUE
      RETURN
      END

      DOUBLE PRECISION FUNCTION ddot_sl(n,dx,incx,dy,incy)

C     FORMS THE DOT PRODUCT OF TWO VECTORS.
C     USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE.
C     JACK DONGARRA, LINPACK, 3/11/78.

      DOUBLE PRECISION dx(*),dy(*),dtemp
      INTEGER i,incx,incy,ix,iy,m,mp1,n

      ddot_sl = 0.0d0
      dtemp = 0.0d0
      IF(n.LE.0)RETURN
      IF(incx.EQ.1.AND.incy.EQ.1)GO TO 20

C        CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS
C          NOT EQUAL TO 1

      ix = 1
      iy = 1
      IF(incx.LT.0)ix = (-n+1)*incx + 1
      IF(incy.LT.0)iy = (-n+1)*incy + 1
      DO 10 i = 1,n
        dtemp = dtemp + dx(ix)*dy(iy)
        ix = ix + incx
        iy = iy + incy
   10 CONTINUE
      ddot_sl = dtemp
      RETURN

C        CODE FOR BOTH INCREMENTS EQUAL TO 1

C        CLEAN-UP LOOP

   20 m = MOD(n,5)
      IF( m .EQ. 0 ) GO TO 40
      DO 30 i = 1,m
        dtemp = dtemp + dx(i)*dy(i)
   30 CONTINUE
      IF( n .LT. 5 ) GO TO 60
   40 mp1 = m + 1
      DO 50 i = mp1,n,5
        dtemp = dtemp + dx(i)*dy(i) + dx(i + 1)*dy(i + 1) +
     *   dx(i + 2)*dy(i + 2) + dx(i + 3)*dy(i + 3) + dx(i + 4)*dy(i + 4)
   50 CONTINUE
   60 ddot_sl = dtemp
      RETURN
      END

      DOUBLE PRECISION FUNCTION dnrm1(n,x,i,j)
      INTEGER n, i, j, k
      DOUBLE PRECISION snormx, sum, x(n), ZERO, one, scale, temp
      DATA ZERO/0.0d0/, one/1.0d0/

C      DNRM1 - COMPUTES THE I-NORM OF A VECTOR
C              BETWEEN THE ITH AND THE JTH ELEMENTS

C      INPUT -
C      N       LENGTH OF VECTOR
C      X       VECTOR OF LENGTH N
C      I       INITIAL ELEMENT OF VECTOR TO BE USED
C      J       FINAL ELEMENT TO USE

C      OUTPUT -
C      DNRM1   NORM

      snormx=ZERO
      DO 10 k=i,j
 10      snormx=MAX(snormx,ABS(x(k)))
      dnrm1 = snormx
      IF (snormx.EQ.ZERO) RETURN
      scale = snormx
      IF (snormx.GE.one) scale=SQRT(snormx)
      sum=ZERO
      DO 20 k=i,j
         temp=ZERO
         IF (ABS(x(k))+scale .NE. scale) temp = x(k)/snormx
         IF (one+temp.NE.one) sum = sum+temp*temp
 20      CONTINUE
      sum=SQRT(sum)
      dnrm1=snormx*sum
      RETURN
      END

      DOUBLE PRECISION FUNCTION dnrm2_ ( n, dx, incx)
      INTEGER          n, i, j, nn, next, incx
      DOUBLE PRECISION dx(*), cutlo, cuthi, hitest, sum, xmax, ZERO, one
      DATA             ZERO, one /0.0d0, 1.0d0/

C     EUCLIDEAN NORM OF THE N-VECTOR STORED IN DX() WITH STORAGE
C     INCREMENT INCX .
C     IF    N .LE. 0 RETURN WITH RESULT = 0.
C     IF N .GE. 1 THEN INCX MUST BE .GE. 1

C           C.L.LAWSON, 1978 JAN 08

C     FOUR PHASE METHOD     USING TWO BUILT-IN CONSTANTS THAT ARE
C     HOPEFULLY APPLICABLE TO ALL MACHINES.
C         CUTLO = MAXIMUM OF  SQRT(U/EPS)   OVER ALL KNOWN MACHINES.
C         CUTHI = MINIMUM OF  SQRT(V)       OVER ALL KNOWN MACHINES.
C     WHERE
C         EPS = SMALLEST NO. SUCH THAT EPS + 1. .GT. 1.
C         U   = SMALLEST POSITIVE NO.   (UNDERFLOW LIMIT)
C         V   = LARGEST  NO.            (OVERFLOW  LIMIT)

C     BRIEF OUTLINE OF ALGORITHM..

C     PHASE 1    SCANS ZERO COMPONENTS.
C     MOVE TO PHASE 2 WHEN A COMPONENT IS NONZERO AND .LE. CUTLO
C     MOVE TO PHASE 3 WHEN A COMPONENT IS .GT. CUTLO
C     MOVE TO PHASE 4 WHEN A COMPONENT IS .GE. CUTHI/M
C     WHERE M = N FOR X() REAL AND M = 2*N FOR COMPLEX.

C     VALUES FOR CUTLO AND CUTHI..
C     FROM THE ENVIRONMENTAL PARAMETERS LISTED IN THE IMSL CONVERTER
C     DOCUMENT THE LIMITING VALUES ARE AS FOLLOWS..
C     CUTLO, S.P.   U/EPS = 2**(-102) FOR  HONEYWELL.  CLOSE SECONDS ARE
C                   UNIVAC AND DEC AT 2**(-103)
C                   THUS CUTLO = 2**(-51) = 4.44089E-16
C     CUTHI, S.P.   V = 2**127 FOR UNIVAC, HONEYWELL, AND DEC.
C                   THUS CUTHI = 2**(63.5) = 1.30438E19
C     CUTLO, D.P.   U/EPS = 2**(-67) FOR HONEYWELL AND DEC.
C                   THUS CUTLO = 2**(-33.5) = 8.23181D-11
C     CUTHI, D.P.   SAME AS S.P.  CUTHI = 1.30438D19
C     DATA CUTLO, CUTHI / 8.232D-11,  1.304D19 /
C     DATA CUTLO, CUTHI / 4.441E-16,  1.304E19 /
      DATA cutlo, cuthi / 8.232d-11,  1.304d19 /

      IF(n .GT. 0) GO TO 10
         dnrm2_  = ZERO
         GO TO 300

   10 assign 30 to next
      sum = ZERO
      nn = n * incx
C                       BEGIN MAIN LOOP
      i = 1
   20    GO TO next,(30, 50, 70, 110)
   30 IF( ABS(dx(i)) .GT. cutlo) GO TO 85
      assign 50 to next
      xmax = ZERO

C                        PHASE 1.  SUM IS ZERO

   50 IF( dx(i) .EQ. ZERO) GO TO 200
      IF( ABS(dx(i)) .GT. cutlo) GO TO 85

C                        PREPARE FOR PHASE 2.

      assign 70 to next
      GO TO 105

C                        PREPARE FOR PHASE 4.

  100 i = j
      assign 110 to next
      sum = (sum / dx(i)) / dx(i)
  105 xmax = ABS(dx(i))
      GO TO 115

C                   PHASE 2.  SUM IS SMALL.
C                             SCALE TO AVOID DESTRUCTIVE UNDERFLOW.

   70 IF( ABS(dx(i)) .GT. cutlo ) GO TO 75

C                   COMMON CODE FOR PHASES 2 AND 4.
C                   IN PHASE 4 SUM IS LARGE.  SCALE TO AVOID OVERFLOW.

  110 IF( ABS(dx(i)) .LE. xmax ) GO TO 115
         sum = one + sum * (xmax / dx(i))**2
         xmax = ABS(dx(i))
         GO TO 200

  115 sum = sum + (dx(i)/xmax)**2
      GO TO 200

C                  PREPARE FOR PHASE 3.

   75 sum = (sum * xmax) * xmax

C     FOR REAL OR D.P. SET HITEST = CUTHI/N
C     FOR COMPLEX      SET HITEST = CUTHI/(2*N)

   85 hitest = cuthi/float( n )

C                   PHASE 3.  SUM IS MID-RANGE.  NO SCALING.

      DO 95 j =i,nn,incx
      IF(ABS(dx(j)) .GE. hitest) GO TO 100
   95    sum = sum + dx(j)**2
      dnrm2_ = SQRT( sum )
      GO TO 300

  200 CONTINUE
      i = i + incx
      IF ( i .LE. nn ) GO TO 20

C              END OF MAIN LOOP.

C              COMPUTE SQUARE ROOT AND ADJUST FOR SCALING.

      dnrm2_ = xmax * SQRT(sum)
  300 CONTINUE
      RETURN
      END

      SUBROUTINE  dsrot (n,dx,incx,dy,incy,c,s)

C     APPLIES A PLANE ROTATION.
C     JACK DONGARRA, LINPACK, 3/11/78.

      DOUBLE PRECISION dx(*),dy(*),dtemp,c,s
      INTEGER i,incx,incy,ix,iy,n

      IF(n.LE.0)RETURN
      IF(incx.EQ.1.AND.incy.EQ.1)GO TO 20

C       CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS NOT EQUAL
C         TO 1

      ix = 1
      iy = 1
      IF(incx.LT.0)ix = (-n+1)*incx + 1
      IF(incy.LT.0)iy = (-n+1)*incy + 1
      DO 10 i = 1,n
        dtemp = c*dx(ix) + s*dy(iy)
        dy(iy) = c*dy(iy) - s*dx(ix)
        dx(ix) = dtemp
        ix = ix + incx
        iy = iy + incy
   10 CONTINUE
      RETURN

C       CODE FOR BOTH INCREMENTS EQUAL TO 1

   20 DO 30 i = 1,n
        dtemp = c*dx(i) + s*dy(i)
        dy(i) = c*dy(i) - s*dx(i)
        dx(i) = dtemp
   30 CONTINUE
      RETURN
      END

      SUBROUTINE dsrotg(da,db,c,s)

C     CONSTRUCT GIVENS PLANE ROTATION.
C     JACK DONGARRA, LINPACK, 3/11/78.
C                    MODIFIED 9/27/86.

      DOUBLE PRECISION da,db,c,s,roe,scale,r,z,one,ZERO
      DATA one, ZERO /1.0d+00, 0.0d+00/

      roe = db
      IF( ABS(da) .GT. ABS(db) ) roe = da
      scale = ABS(da) + ABS(db)
      IF( scale .NE. ZERO ) GO TO 10
         c = one
         s = ZERO
         r = ZERO
         GO TO 20
   10 r = scale*SQRT((da/scale)**2 + (db/scale)**2)
      r = SIGN(one,roe)*r
      c = da/r
      s = db/r
   20 z = s
      IF( ABS(c) .GT. ZERO .AND. ABS(c) .LE. s ) z = one/c
      da = r
      db = z
      RETURN
      END

      SUBROUTINE  dscal_sl(n,da,dx,incx)

C     SCALES A VECTOR BY A CONSTANT.
C     USES UNROLLED LOOPS FOR INCREMENT EQUAL TO ONE.
C     JACK DONGARRA, LINPACK, 3/11/78.

      DOUBLE PRECISION da,dx(*)
      INTEGER i,incx,m,mp1,n,nincx

      IF(n.LE.0)RETURN
      IF(incx.EQ.1)GO TO 20

C        CODE FOR INCREMENT NOT EQUAL TO 1

      nincx = n*incx
      DO 10 i = 1,nincx,incx
        dx(i) = da*dx(i)
   10 CONTINUE
      RETURN

C        CODE FOR INCREMENT EQUAL TO 1

C        CLEAN-UP LOOP

   20 m = MOD(n,5)
      IF( m .EQ. 0 ) GO TO 40
      DO 30 i = 1,m
        dx(i) = da*dx(i)
   30 CONTINUE
      IF( n .LT. 5 ) RETURN
   40 mp1 = m + 1
      DO 50 i = mp1,n,5
        dx(i) = da*dx(i)
        dx(i + 1) = da*dx(i + 1)
        dx(i + 2) = da*dx(i + 2)
        dx(i + 3) = da*dx(i + 3)
        dx(i + 4) = da*dx(i + 4)
   50 CONTINUE
      RETURN
      END

      subroutine bound(n, x, xl, xu)
      integer n, i
      double precision x(n), xl(n), xu(n)
      do i = 1, n
C        Note that xl(i) and xu(i) may be NaN to indicate no bound
         if(xl(i).eq.xl(i).and.x(i) < xl(i))then
            x(i) = xl(i)
         else if(xu(i).eq.xu(i).and.x(i) > xu(i))then
            x(i) = xu(i)
         end if
      end do
      end subroutine bound


program integer_division
    use, intrinsic :: iso_fortran_env, only : REAL64
    implicit none
    real(kind=REAL64) :: x
    x = 1/2
    print '(A, F3.1)', '1/2 = ', x
    x = 1.0/2.0
    print '(A, F3.1)', '1.0/2.0 = ', x
end program integer_division


subroutine shear_prod3D(def2)

use vars
implicit none

real def2(nx,ny,nzm)

real rdx0,rdx,rdx_up,rdx_dn
real rdy0,rdy,rdy_up,rdy_dn
real rdz,rdzw_up,rdzw_dn
integer i,j,k,ib,ic,jb,jc,kb,kc

rdx0=1./dx
rdy0=1./dy

do k=2,nzm-1

 kb=k-1
 kc=k+1
 rdz = 1./(dz*adz(k))
 rdzw_up = 1./(dz*adzw(kc))
 rdzw_dn = 1./(dz*adzw(k))
 rdx=rdx0 * sqrt(dx*rdz) ! take into account grid anisotropy
 rdy=rdy0 * sqrt(dy*rdz)
 rdx_up=rdx0 * sqrt(dx*rdzw_up)
 rdy_up=rdy0 * sqrt(dy*rdzw_up)
 rdx_dn=rdx0 * sqrt(dx*rdzw_dn)
 rdy_dn=rdy0 * sqrt(dy*rdzw_dn)

 do j=1,ny
   jb=j-YES3D
   jc=j+YES3D
   do i=1,nx
     ib=i-1
     ic=i+1

      def2(i,j,k)=2.* ( &
          ( (u(ic,j,k)-u(i,j,k))*rdx)**2+ &
          ( (v(i,jc,k)-v(i,j,k))*rdy)**2+ &
          ( (w(i,j,kc)-w(i,j,k))*rdz)**2 ) &
        + 0.25 * ( &
          ( (u(ic,jc,k)-u(ic,j ,k))*rdy+(v(ic,jc,k)-v(i ,jc,k))*rdx )**2 +  &
          ( (u(i ,jc,k)-u(i ,j ,k))*rdy+(v(i ,jc,k)-v(ib,jc,k))*rdx )**2 +  &
          ( (u(ic,j ,k)-u(ic,jb,k))*rdy+(v(ic,j ,k)-v(i ,j ,k))*rdx )**2 +  &
          ( (u(i ,j ,k)-u(i ,jb,k))*rdy+(v(i ,j ,k)-v(ib,j ,k))*rdx )**2 )
      def2(i,j,k)=def2(i,j,k) &
        + 0.25 * ( &
          ( (u(ic,j,kc)-u0(kc)-u(ic,j, k)+u0(k))*rdzw_up+ &
            (w(ic,j,kc)-w(i ,j,kc))*rdx_up )**2 + &
          ( (u(i ,j,kc)-u0(kc)-u(i ,j, k)+u0(k))*rdzw_up+ &
            (w(i ,j,kc)-w(ib,j,kc))*rdx_up )**2 + &
          ( (u(ic,j,k )-u0(k)-u(ic,j,kb)+u0(kb))*rdzw_dn+ &
            (w(ic,j,k )-w(i ,j,k ))*rdx_dn )**2 + &
          ( (u(i ,j,k )-u0(k)-u(i ,j,kb)+u0(kb))*rdzw_dn+ &
            (w(i ,j,k )-w(ib,j,k ))*rdx_dn )**2 )
      def2(i,j,k)=def2(i,j,k) &
        + 0.25 * ( &
          ( (v(i,jc,kc)-v0(kc)-v(i,jc, k)+v0(k))*rdzw_up+ &
            (w(i,jc,kc)-w(i,j ,kc))*rdy_up )**2 + &
          ( (v(i,j ,kc)-v0(kc)-v(i,j , k)+v0(k))*rdzw_up+ &
            (w(i,j ,kc)-w(i,jb,kc))*rdy_up )**2 + &
          ( (v(i,jc,k )-v0(k)-v(i,jc,kb)+v0(kb))*rdzw_dn+ &
            (w(i,jc,k )-w(i,j ,k ))*rdy_dn )**2 + &
          ( (v(i,j ,k )-v0(k)-v(i,j ,kb)+v0(kb))*rdzw_dn+ &
            (w(i,j ,k )-w(i,jb,k ))*rdy_dn )**2 )

    end do
 end do
end do ! k

k=1
kc=k+1

rdz = 1./(dz*adz(k))
rdzw_up = 1./(dz*adzw(kc))
rdx=rdx0 * sqrt(dx*rdz) ! take into account grid anisotropy
rdy=rdy0 * sqrt(dy*rdz)
rdx_up=rdx0 * sqrt(dx*rdzw_up)
rdy_up=rdy0 * sqrt(dy*rdzw_up)

do j=1,ny
  jb=j-YES3D
  jc=j+YES3D
  do i=1,nx
     ib=i-1
     ic=i+1

      def2(i,j,k)=2.* ( &
          ( (u(ic,j,k)-u(i,j,k))*rdx)**2+ &
          ( (v(i,jc,k)-v(i,j,k))*rdy)**2+ &
          ( (w(i,j,kc)-w(i,j,k))*rdz)**2 ) &
        + 0.25 * ( &
          ( (u(ic,jc,k)-u(ic,j ,k))*rdy+(v(ic,jc,k)-v(i ,jc,k))*rdx )**2 +  &
          ( (u(i ,jc,k)-u(i ,j ,k))*rdy+(v(i ,jc,k)-v(ib,jc,k))*rdx )**2 +  &
          ( (u(ic,j ,k)-u(ic,jb,k))*rdy+(v(ic,j ,k)-v(i ,j ,k))*rdx )**2 +  &
          ( (u(i ,j ,k)-u(i ,jb,k))*rdy+(v(i ,j ,k)-v(ib,j ,k))*rdx )**2 )   &
	 + 0.5 * ( &
          ( (v(i,jc,kc)-v0(kc)-v(i,jc, k)+v0(k))*rdzw_up+ &
            (w(i,jc,kc)-w(i,j ,kc))*rdy_up )**2 + &
          ( (v(i,j ,kc)-v0(kc)-v(i,j , k)+v0(k))*rdzw_up+ &
          (w(i,j ,kc)-w(i,jb,kc))*rdy_up )**2 ) &
	 + 0.5 * ( &
          ( (u(ic,j,kc)-u0(kc)-u(ic,j, k)+u0(k))*rdzw_up+ &
          (w(ic,j,kc)-w(i ,j,kc))*rdx_up )**2 + &
          ( (u(i ,j,kc)-u0(kc)-u(i ,j, k)+u0(k))*rdzw_up+ &
          (w(i ,j,kc)-w(ib,j,kc))*rdx_up )**2 )

   end do
end do

k=nzm
kc=k+1
kb=k-1

rdz = 1./(dz*adz(k))
rdzw_dn = 1./(dz*adzw(k))
rdx=rdx0 * sqrt(dx*rdz) ! take into account grid anisotropy
rdy=rdy0 * sqrt(dy*rdz)
rdx_dn=rdx0 * sqrt(dx*rdzw_dn)
rdy_dn=rdy0 * sqrt(dy*rdzw_dn)

do j=1,ny
  jb=j-1*YES3D
  jc=j+1*YES3D
  do i=1,nx
      ib=i-1
      ic=i+1
      def2(i,j,k)=2.* ( &
           ( (u(ic,j,k)-u(i,j,k))*rdx)**2+ &
           ( (v(i,jc,k)-v(i,j,k))*rdy)**2+ &
           ( (w(i,j,kc)-w(i,j,k))*rdz)**2 ) &
       + 0.25 * ( &
           ( (u(ic,jc,k)-u(ic,j ,k))*rdy+(v(ic,jc,k)-v(i ,jc,k))*rdx )**2 +  &
           ( (u(i ,jc,k)-u(i ,j ,k))*rdy+(v(i ,jc,k)-v(ib,jc,k))*rdx )**2 +  &
           ( (u(ic,j ,k)-u(ic,jb,k))*rdy+(v(ic,j ,k)-v(i ,j ,k))*rdx )**2 +  &
           ( (u(i ,j ,k)-u(i ,jb,k))*rdy+(v(i ,j ,k)-v(ib,j ,k))*rdx )**2 )   &
       + 0.5 * ( &
           ( (v(i,jc,k )-v0(k)-v(i,jc,kb)+v0(kb))*rdzw_dn+ &
             (w(i,jc,k )-w(i,j ,k ))*rdy_dn )**2 + &
           ( (v(i,j ,k )-v0(k)-v(i,j ,kb)+v0(kb))*rdzw_dn+ &
             (w(i,j ,k )-w(i,jb,k ))*rdy_dn )**2 ) &
 	+ 0.5 * ( &
           ( (u(ic,j,k )-u0(k)-u(ic,j,kb)+u0(kb))*rdzw_dn+ &
             (w(ic,j,k )-w(i ,j,k ))*rdx_dn )**2 + &
           ( (u(i ,j,k )-u0(k)-u(i ,j,kb)+u0(kb))*rdzw_dn+ &
             (w(i ,j,k )-w(ib,j,k ))*rdx_dn )**2 )
  end do
end do

end


! { dg-do compile }
! { dg-options "-O -fdump-tree-original" }
program main
  integer, parameter :: n=100
  real, parameter :: pi=4*atan(1.)
  real, parameter :: tmax=20.
  real, parameter :: dt = tmax/(2*pi)/real(n)
  real, parameter :: t0 = dt/30.
  integer :: i
  interface
     pure function purefunc(x)
       real :: purefunc
       real, intent(in) :: x
     end function purefunc
  end interface
  real :: a(n)
  do i=1,n
     a(i) = purefunc(dt*i + t0) * 3. + 2 * purefunc(t0 + i*dt)
  end do
  print *,a
end program main
! { dg-final { scan-tree-dump-times "purefunc" 1 "original" } }


! { dg-do run }
! { dg-add-options ieee }
! { dg-skip-if "NaN not supported" { spu-*-* } }
!
! List-directed part of PR fortran/43298
! and follow up to PR fortran/34319.
!
! Check handling of "NAN(alphanum)"
!
character(len=200) :: str
real :: r
complex :: z

! read_real:

r = 1.0
str = 'INfinity' ; read(str,*) r
if (r < 0 .or. r /= r*1.1) STOP 1

r = 1.0
str = '-INF' ; read(str,*) r
if (r > 0 .or. r /= r*1.1) STOP 2

r = 1.0
str = '+INF' ; read(str,*) r
if (r < 0 .or. r /= r*1.1) STOP 3

r = 1.0
str = '-inFiniTY' ; read(str,*) r
if (r > 0 .or. r /= r*1.1) STOP 4

r = 1.0
str = 'NAN' ; read(str,*) r
if (.not. isnan(r)) STOP 5

r = 1.0
str = '-NAN' ; read(str,*) r
if (.not. isnan(r)) STOP 6

r = 1.0
str = '+NAN' ; read(str,*) r
if (.not. isnan(r)) STOP 7

r = 1.0
str = 'NAN(0x111)' ; read(str,*) r
if (.not. isnan(r)) STOP 8

r = 1.0
str = '-NAN(123)' ; read(str,*) r
if (.not. isnan(r)) STOP 9

r = 1.0
str = '+NAN(0xFFE)' ; read(str,*) r
if (.not. isnan(r)) STOP 10

! parse_real

z = cmplx(-2.0,-4.0)
str = '(0.0,INfinity)' ; read(str,*) z
if (aimag(z) < 0 .or. aimag(z) /= aimag(z)*1.1) STOP 11

z = cmplx(-2.0,-4.0)
str = '(-INF,0.0)' ; read(str,*) z
if (real(z) > 0 .or. real(z) /= real(z)*1.1) STOP 12

z = cmplx(-2.0,-4.0)
str = '(0.0,+INF)' ; read(str,*) z
if (aimag(z) < 0 .or. aimag(z) /= aimag(z)*1.1) STOP 13

z = cmplx(-2.0,-4.0)
str = '(-inFiniTY,0.0)' ; read(str,*) z
if (real(z) > 0 .or. real(z) /= real(z)*1.1) STOP 14

z = cmplx(-2.0,-4.0)
str = '(NAN,0.0)' ; read(str,*) z
if (.not. isnan(real(z))) STOP 15

z = cmplx(-2.0,-4.0)
str = '(0.0,-NAN)' ; read(str,*) z
if (.not. isnan(aimag(z))) STOP 16

z = cmplx(-2.0,-4.0)
str = '(+NAN,0.0)' ; read(str,*) z
if (.not. isnan(real(z))) STOP 17

z = cmplx(-2.0,-4.0)
str = '(NAN(0x111),0.0)' ; read(str,*) z
if (.not. isnan(real(z))) STOP 18

z = cmplx(-2.0,-4.0)
str = '(0.0,-NaN(123))' ; read(str,*) z
if (.not. isnan(aimag(z))) STOP 19

z = cmplx(-2.0,-4.0)
str = '(+nan(0xFFE),0.0)' ; read(str,*) z
if (.not. isnan(real(z))) STOP 20

end


!Risolve equazioni 2grado

Program Equazioni
IMPLICIT none

REAL :: a, b, c, delta, sol1, sol2

a=1
b=1
c=1

WRITE(*,*) "Scrivi a, b e c"
WRITE(*,*) "Dell'equazione ax^2+bx+c=0"

READ (*,*) a, b, c

delta=determinante(a, b, c)

IF (delta==0) THEN
sol1=(-b)/(2*a)
WRITE(*,fmt='(A40,F5.2)') "Le due soluzioni coincidono e valgono:", sol1
STOP
ElSE
IF (delta>0) THEN
!$OMP PARALLEL
sol1=(-b-sqrt(delta))/(2*a)
sol2=(-b+sqrt(delta))/(2*a)
!$OMP END PARALLEL
WRITE(*,fmt='(A25,F5.2,F5.2)') "Le due soluzioni sono:", sol1, sol2
STOP
ELSE
WRITE(*,*) "Equazione impossibile!"
STOP
END IF
END IF

CONTAINS

REAL FUNCTION determinante (p, q, r)
    REAL:: p, q, r
    determinante=(q**2)-((4*p)*r)
END FUNCTION determinante

END PROGRAM


	FUNCTION PR_IGRO  ( tmpc, sstc, sped )
C************************************************************************
C* PR_IGRO								*
C*									*
C* This function computes IGRO, the rate of ice accretion/growth of ice *
C* on a vessel in salt water, in units of inches per 3 hours (the WMO   *
C* standard).                                                           *
C* The formula used is:                                                 *
C*									*
C*       IGRO = ( A*pr + B*pr*pr + C*pr*pr*pr ) * CVFAC                 *
C*   where                                                              *
C*	A  = 2.73 * 10e-2                                               *
C*	B  = 2.91 * 10e-4                                               *
C*	C  = 1.84 * 10e-6                                               *
C*	pr = ( sped * ( -1.7 - tmpc ) ) / ( 1 + 0.4 * ( sstc + 1.7 ) )  *
C*	        (priesendorfer regression)                              *
C*   and                                                                *
C*      CVFAC = 1.1811, to convert cm/hr to in/3hr.                     *
C*									*
C* REAL PR_IGRO  ( TMPC, SSTC, SPED )					*
C*									*
C* Input parameters:							*
C*	TMPC		REAL	Observed surface air temperature (C)    *
C*	SSTC 		REAL	Observed sea-surface temperature (C)    *
C*	SPED		REAL	Observed wind speed (m/s)               *
C*									*
C* Output parameters:							*
C*	PR_IGRO		REAL	Rate of ice accretion (in/3hr)          *
C**									*
C* Log:									*
C* D. Kidwell/NCEP	 3/00						*
C************************************************************************
        INCLUDE   'GEMPRM.PRM'
C*
	PARAMETER	( A = .273E-1, B = .291E-3, C = .184E-5 )
      	PARAMETER	( CVFAC = 1.1811 )
C*
	LOGICAL		good
C*
        INCLUDE   'ERMISS.FNC'
C------------------------------------------------------------------------
	PR_IGRO = RMISSD
C
	IF ( ERMISS ( tmpc ) .or. ERMISS ( sstc ) .or.
     +       ERMISS ( sped ) ) THEN
	    RETURN
	END IF
C
C*	Check that all values are within valid ranges for this formula.
C
	good = .true.
	IF ( ( sped .lt. 0. ) .or. ( sped .gt. 50. ) ) good = .false.
	IF ( ( tmpc .lt. (-20.) ) .or. ( tmpc .gt. 0. ) ) good = .false.
	IF ( ( sstc .lt. (-1.7) ) .or. ( sstc .gt. 12.) ) good = .false.
C
	IF ( good ) THEN
	    pr  = ( sped * ( -1.7 - tmpc ) ) /
     +            ( 1. + 0.4 * ( sstc + 1.7 ) )
	    pr2 = pr * pr
	    PR_IGRO = ( A * pr + B * pr2 + C * pr * pr2 ) * CVFAC
	END IF
C
	IF ( PR_IGRO .lt. 0. )  PR_IGRO = RMISSD
C*
	RETURN
	END


      subroutine ct3o_d(c1,o2,t4,dect4o)

      implicit double precision(a-h,o-z)

      dimension o2(3,3,3),t4(3,3,3,3),dect4o(3)

c  this subroutine evaluates the quadrupole-quadrupole
c  electrostatic interaction

      dimension a(3,10)

      a(1,1)=o2(1,1,1)*t4(1,1,1,1)
      a(1,2)=o2(1,1,2)*t4(1,1,1,2)*3.d0
      a(1,3)=o2(1,1,3)*t4(1,1,1,3)*3.d0
      a(1,4)=o2(1,2,2)*t4(1,1,2,2)*3.d0
      a(1,5)=o2(1,2,3)*t4(1,1,2,3)*6.d0
      a(1,6)=o2(1,3,3)*t4(1,1,3,3)*3.d0
      a(1,7)=o2(2,2,2)*t4(1,2,2,2)
      a(1,8)=o2(2,2,3)*t4(1,2,2,3)*3.d0
      a(1,9)=o2(2,3,3)*t4(1,2,3,3)*3.d0
      a(1,10)=o2(3,3,3)*t4(1,3,3,3)

      a(2,1)=o2(1,1,1)*t4(1,1,1,2)
      a(2,2)=o2(1,1,2)*t4(1,1,2,2)*3.d0
      a(2,3)=o2(1,1,3)*t4(1,1,2,3)*3.d0
      a(2,4)=o2(1,2,2)*t4(1,2,2,2)*3.d0
      a(2,5)=o2(1,2,3)*t4(1,2,2,3)*6.d0
      a(2,6)=o2(1,3,3)*t4(1,2,3,3)*3.d0
      a(2,7)=o2(2,2,2)*t4(2,2,2,2)
      a(2,8)=o2(2,2,3)*t4(2,2,2,3)*3.d0
      a(2,9)=o2(2,3,3)*t4(2,2,3,3)*3.d0
      a(2,10)=o2(3,3,3)*t4(2,3,3,3)

      a(3,1)=o2(1,1,1)*t4(1,1,1,3)
      a(3,2)=o2(1,1,2)*t4(1,1,2,3)*3.d0
      a(3,3)=o2(1,1,3)*t4(1,1,3,3)*3.d0
      a(3,4)=o2(1,2,2)*t4(1,2,2,3)*3.d0
      a(3,5)=o2(1,2,3)*t4(1,2,3,3)*6.d0
      a(3,6)=o2(1,3,3)*t4(1,3,3,3)*3.d0
      a(3,7)=o2(2,2,2)*t4(2,2,2,3)
      a(3,8)=o2(2,2,3)*t4(2,2,3,3)*3.d0
      a(3,9)=o2(2,3,3)*t4(2,3,3,3)*3.d0
      a(3,10)=o2(3,3,3)*t4(3,3,3,3)

      dect4o(1)=c1*(a(1,1)+a(1,2)+a(1,3)+a(1,4)+a(1,5)+a(1,6)+
     .          a(1,7)+a(1,8)+a(1,9)+a(1,10))

      dect4o(2)=c1*(a(2,1)+a(2,2)+a(2,3)+a(2,4)+a(2,5)+a(2,6)+
     .          a(2,7)+a(2,8)+a(2,9)+a(2,10))

      dect4o(3)=c1*(a(3,1)+a(3,2)+a(3,3)+a(3,4)+a(3,5)+a(3,6)+
     .          a(3,7)+a(3,8)+a(3,9)+a(3,10))

      return
      end


subroutine fuzzifier
use fdeclarations

implicit none
allocate(uf(z,e))
allocate(df(z,e))
allocate(tf(z,e))
allocate(sf(z,e))
sf(:,:)=0
uf(:,:)=0
df(:,:)=0
tf(:,:)=0

do i=1,z
if (ematrix(i,1)<=uvla) then
uf(i,1)=1
else if (ematrix(i,1)>uvla .and. ematrix(i,1)<=uvlb) then
uf(i,1)=(uvlb-ematrix(i,1))/(uvlb-uvla)
else
uf(i,1)=0
end if
if (ematrix(i,1)<=ula) then
uf(i,2)=0
else if (ematrix(i,1)>ula .and. ematrix(i,1)<=ulb) then
uf(i,2)=(ematrix(i,1)-ula)/(ulb-ula)
else if (ematrix(i,1)>ulb .and. ematrix(i,1)<=ulc) then
uf(i,2)=1
else if (ematrix(i,1)>ulc .and. ematrix(i,1)<=uld) then
uf(i,2)=(uld-ematrix(i,1))/(uld-ulc)
else
uf(i,2)=0
end if
if (ematrix(i,1)<=uma) then
uf(i,3)=0
else if (ematrix(i,1)>uma .and. ematrix(i,1)<=umb) then
uf(i,3)=(ematrix(i,1)-uma)/(umb-uma)
else if (ematrix(i,1)>umb .and. ematrix(i,1)<=umc) then
uf(i,3)=1
else if (ematrix(i,1)>umc .and. ematrix(i,1)<=umd) then
uf(i,3)=(umd-ematrix(i,1))/(umd-umc)
else
uf(i,3)=0
end if
if (ematrix(i,1)<=uha) then
uf(i,4)=0
else if (ematrix(i,1)>uha .and. ematrix(i,1)<=uhb) then
uf(i,4)=(ematrix(i,1)-uha)/(uhb-uha)
else if (ematrix(i,1)>uhb .and. ematrix(i,1)<=uhc) then
uf(i,4)=1
else if (ematrix(i,1)>uhc .and. ematrix(i,1)<=uhd) then
uf(i,4)=(uhd-ematrix(i,1))/(uhd-uhc)
else
uf(i,4)=0
end if
if (ematrix(i,1)<=uvha) then
uf(i,5)=0
else if (ematrix(i,1)>uvha .and. ematrix(i,1)<=uvhb) then
uf(i,5)=(ematrix(i,1)-uvha)/(uvhb-uvha)
else
uf(i,5)=1
end if
end do

do i=1,z
if (ematrix(i,2)<=dvla) then
df(i,1)=1
else if (ematrix(i,2)>dvla .and. (ematrix(i,2)<=dvlb)) then
df(i,1)=(dvlb-ematrix(i,2))/(dvlb-dvla)
else
df(i,1)=0
end if
if (ematrix(i,2)<=dla) then
df(i,2)=0
else if (ematrix(i,2)>dla .and. (ematrix(i,2)<=dlb)) then
df(i,2)=(ematrix(i,2)-dla)/(dlb-dla)
else if (ematrix(i,2)>dlb .and. ematrix(i,2)<=dlc) then
df(i,2)=1
else if (ematrix(i,2)>dlc .and. ematrix(i,2)<=dld) then
df(i,2)=(dld-ematrix(i,2))/(dld-dlc)
else
df(i,2)=0
end if
if (ematrix(i,2)<=dma) then
df(i,3)=0
else if (ematrix(i,2)>dma .and. ematrix(i,2)<=dmb) then
df(i,3)=(ematrix(i,2)-dma)/(dmb-dma)
else if (ematrix(i,2)>dmb .and. ematrix(i,2)<=dmc) then
df(i,3)=1
else if (ematrix(i,2)>dmc .and. ematrix(i,2)<=dmd) then
df(i,3)=(dmd-ematrix(i,2))/(dmd-dmc)
else
df(i,3)=0
end if
if (ematrix(i,2)<=dda) then
df(i,4)=0
else if (ematrix(i,2)>dda .and. ematrix(i,2)<=ddb) then
df(i,4)=(ematrix(i,2)-dda)/(ddb-dda)
else if (ematrix(i,2)>ddb .and. ematrix(i,2)<=ddc) then
df(i,4)=1
else if (ematrix(i,2)>ddc .and. ematrix(i,2)<=ddd) then
df(i,4)=(ddd-ematrix(i,2))/(ddd-ddc)
else
df(i,4)=0
end if
if (ematrix(i,2)<=dvda) then
df(i,5)=0
else if (ematrix(i,2)>dvda .and. ematrix(i,2)<=dvdb) then
df(i,5)=(ematrix(i,2)-dvda)/(dvdb-dvda)
else
df(i,5)=1
end if
end do

do i=1,z
if (ematrix(i,4)<=tvla) then
tf(i,1)=1
else if (ematrix(i,4)>tvla .and. ematrix(i,4)<=tvlb) then
tf(i,1)=(tvlb-ematrix(i,4))/(tvlb-tvla)
else
tf(i,1)=0
end if
if (ematrix(i,4)<=tla) then
tf(i,2)=0
else if (ematrix(i,4)>tla .and. ematrix(i,4)<=tlb) then
tf(i,2)=(ematrix(i,4)-tla)/(tlb-tla)
else if (ematrix(i,4)>tlb .and. ematrix(i,4)<=tlc) then
tf(i,2)=1
else if (ematrix(i,4)>tlc .and. ematrix(i,4)<=tld) then
tf(i,2)=(tld-ematrix(i,4))/(tld-tlc)
else
tf(i,2)=0
end if
if (ematrix(i,4)<=tma) then
tf(i,3)=0
else if (ematrix(i,4)>tma .and. ematrix(i,4)<=tmb) then
tf(i,3)=(ematrix(i,4)-tma)/(tmb-tma)
else if (ematrix(i,4)>tmb .and. ematrix(i,4)<=tmc) then
tf(i,3)=1
else if (ematrix(i,4)>tmc .and. ematrix(i,4)<=tmd) then
tf(i,3)=(tmd-ematrix(i,4))/(tmd-tmc)
else
tf(i,3)=0
end if
if (ematrix(i,4)<=tha) then
tf(i,4)=0
else if (ematrix(i,4)>tha .and. ematrix(i,4)<=thb) then
tf(i,4)=(ematrix(i,4)-tha)/(thb-tha)
else if (ematrix(i,4)>thb .and. ematrix(i,4)<=thc) then
tf(i,4)=1
else if (ematrix(i,4)>thc .and. ematrix(i,4)<=thd) then
tf(i,4)=(thd-ematrix(i,4))/(thd-thc)
else
tf(i,4)=0
end if
if (ematrix(i,4)<=tvha) then
tf(i,5)=0
else if (ematrix(i,4)>tvha .and. ematrix(i,4)<=tvhb) then
tf(i,5)=(ematrix(i,4)-tvha)/(tvhb-tvha)
else
tf(i,5)=1
end if
end do

!do i=1,z
!if (ematrix(i,4)<=tvla) then
!tf(i,1)=1
!else if (ematrix(i,4)>tvla .and. ematrix(i,4)<=tvlb) then
!tf(i,1)=(tvlb-ematrix(i,4))/(tvlb-tvla)
!else
!tf(i,1)=0
!end if
!if (ematrix(i,4)<=tla) then
!tf(i,1)=0
!else if (ematrix(i,4)>tla .and. ematrix(i,4)<=tlb) then
!tf(i,1)=(ematrix(i,4)-tla)/(tlb-tla)
!else if (ematrix(i,4)>tlb .and. ematrix(i,4)<=tlc) then
!tf(i,1)=1
!else if (ematrix(i,4)>tlc .and. ematrix(i,4)<=tld) then
!tf(i,1)=(tld-ematrix(i,4))/(tld-tlc)
!else
!tf(i,1)=0
!end if
!if (ematrix(i,4)<=tma) then
!tf(i,1)=0
!else if (ematrix(i,4)>tma .and. ematrix(i,4)<=tmb) then
!tf(i,1)=(ematrix(i,4)-tma)/(tmb-tma)
!else if (ematrix(i,4)>tmb .and. ematrix(i,4)<=tmc) then
!tf(i,1)=1
!else if (ematrix(i,4)>tmc .and. ematrix(i,4)<=tmd) then
!tf(i,1)=(tmd-ematrix(i,4))/(tmd-tmc)
!else
!tf(i,1)=0
!end if
!if (ematrix(i,4)<=tha) then
!tf(i,2)=0
!else if (ematrix(i,4)>tha .and. ematrix(i,4)<=thb) then
!tf(i,2)=(ematrix(i,4)-tha)/(thb-tha)
!else if (ematrix(i,4)>thb .and. ematrix(i,4)<=thc) then
!tf(i,2)=1
!else if (ematrix(i,4)>thc .and. ematrix(i,4)<=thd) then
!tf(i,2)=(thd-ematrix(i,4))/(thd-thc)
!else
!tf(i,2)=0
!end if
!if (ematrix(i,4)<=tvha) then
!tf(i,2)=0
!else if (ematrix(i,4)>tvha .and. ematrix(i,4)<=tvhb) then
!tf(i,2)=(ematrix(i,4)-tvha)/(tvhb-tvha)
!else
!tf(i,2)=1
!end if
!end do

!Substrate in 8 classes
if (vers==1) then
do i=1,z
if (ematrix(i,3)==silt) then
sf(i,1)=1
else if (ematrix(i,3)==sand) then
sf(i,2)=1
else if (ematrix(i,3)==fine_gravel) then
sf(i,3)=1
else if (ematrix(i,3)==medium_gravel) then
sf(i,4)=1
else if (ematrix(i,3)==large_gravel) then
sf(i,5)=1
elseif (ematrix(i,3)==small_stones) then
sf(i,6)=1
else if (ematrix(i,3)==large_stones) then
sf(i,7)=1
else if (ematrix(i,3)==boulders) then
sf(i,8)=1
end if
end do

else
do i=1,z
if (ematrix(i,3)<=svla) then
sf(i,1)=1
else if (ematrix(i,3)>svla .and. (ematrix(i,3)<=svlb)) then
sf(i,1)=(svlb-ematrix(i,3))/(svlb-svla)
else
sf(i,1)=0
end if
if (ematrix(i,3)<=sla) then
sf(i,2)=0
else if (ematrix(i,3)>sla .and. (ematrix(i,3)<=slb)) then
sf(i,2)=(ematrix(i,3)-sla)/(slb-sla)
else if (ematrix(i,3)>slb .and. ematrix(i,3)<=slc) then
sf(i,2)=1
else if (ematrix(i,3)>slc .and. ematrix(i,3)<=sld) then
sf(i,2)=(sld-ematrix(i,3))/(sld-slc)
else
sf(i,2)=0
end if
if (ematrix(i,3)<=sma) then
sf(i,3)=0
else if (ematrix(i,3)>sma .and. ematrix(i,3)<=smb) then
sf(i,3)=(ematrix(i,3)-sma)/(smb-sma)
else if (ematrix(i,3)>smb .and. ematrix(i,3)<=smc) then
sf(i,3)=1
else if (ematrix(i,3)>smc .and. ematrix(i,3)<=smd) then
sf(i,3)=(smd-ematrix(i,3))/(smd-smc)
else
sf(i,3)=0
end if
if (ematrix(i,3)<=sda) then
sf(i,4)=0
else if (ematrix(i,3)>sda .and. ematrix(i,3)<=sdb) then
sf(i,4)=(ematrix(i,3)-sda)/(sdb-sda)
else if (ematrix(i,3)>sdb .and. ematrix(i,3)<=sdc) then
sf(i,4)=1
else if (ematrix(i,3)>sdc .and. ematrix(i,3)<=sdd) then
sf(i,4)=(sdd-ematrix(i,3))/(sdd-sdc)
else
sf(i,4)=0
end if
if (ematrix(i,3)<=svda) then
sf(i,5)=0
else if (ematrix(i,3)>svda .and. ematrix(i,3)<=svdb) then
sf(i,5)=(ematrix(i,3)-svda)/(svdb-svda)
else
sf(i,5)=1
end if
end do
endif

end subroutine fuzzifier


      subroutine cova3(x1,y1,z1,x2,y2,z2,ivarg,nst,MAXNST,c0,it,cc,aa,
     +                 irot,MAXROT,rotmat,cmax,cova)
c-----------------------------------------------------------------------
c
c                    Covariance Between Two Points
c                    *****************************
c
c This subroutine calculated the covariance associated with a variogram
c model specified by a nugget effect and nested varigoram structures.
c The anisotropy definition can be different for each nested structure.
c
c
c
c INPUT VARIABLES:
c
c   x1,y1,z1         coordinates of first point
c   x2,y2,z2         coordinates of second point
c   nst(ivarg)       number of nested structures (maximum of 4)
c   ivarg            variogram number (set to 1 unless doing cokriging
c                       or indicator kriging)
c   MAXNST           size of variogram parameter arrays
c   c0(ivarg)        isotropic nugget constant
c   it(i)            type of each nested structure:
c                      1. spherical model of range a;
c                      2. exponential model of parameter a;
c                           i.e. practical range is 3a
c                      3. gaussian model of parameter a;
c                           i.e. practical range is a*sqrt(3)
c                      4. power model of power a (a must be gt. 0  and
c                           lt. 2).  if linear model, a=1,c=slope.
c                      5. hole effect model
c   cc(i)            multiplicative factor of each nested structure.
c                      (sill-c0) for spherical, exponential,and gaussian
c                      slope for linear model.
c   aa(i)            parameter "a" of each nested structure.
c   irot             index of the rotation matrix for the first nested
c                    structure (the second nested structure will use
c                    irot+1, the third irot+2, and so on)
c   MAXROT           size of rotation matrix arrays
c   rotmat           rotation matrices
c
c
c OUTPUT VARIABLES:
c
c   cmax             maximum covariance
c   cova             covariance between (x1,y1,z1) and (x2,y2,z2)
c
c
c
c EXTERNAL REFERENCES: sqdist    computes anisotropic squared distance
c                      rotmat    computes rotation matrix for distance
c-----------------------------------------------------------------------
      parameter(PI=3.14159265,PMX=999.,EPSLON=1.e-10)
      integer   nst(*),it(*)
      real      c0(*),cc(*),aa(*)
      real*8    rotmat(MAXROT,3,3),hsqd,sqdist
c
c Calculate the maximum covariance value (used for zero distances and
c for power model covariance):
c
      istart = 1 + (ivarg-1)*MAXNST
      cmax   = c0(ivarg)
      do is=1,nst(ivarg)
            ist = istart + is - 1
            if(it(ist).eq.4) then
                  cmax = cmax + PMX
            else
                  cmax = cmax + cc(ist)
            endif
      end do
c
c Check for "zero" distance, return with cmax if so:
c
      hsqd = sqdist(x1,y1,z1,x2,y2,z2,irot,MAXROT,rotmat)
      if(real(hsqd).lt.EPSLON) then
            cova = cmax
            return
      endif
c
c Loop over all the structures:
c
      cova = 0.0
      do is=1,nst(ivarg)
            ist = istart + is - 1
c
c Compute the appropriate distance:
c
            if(ist.ne.1) then
                  ir = min((irot+is-1),MAXROT)
                  hsqd=sqdist(x1,y1,z1,x2,y2,z2,ir,MAXROT,rotmat)
            end if
            h = real(dsqrt(hsqd))
c
c Spherical Variogram Model?
c
            if(it(ist).eq.1) then
                  hr = h/aa(ist)
                  if(hr.lt.1.) cova=cova+cc(ist)*(1.-hr*(1.5-.5*hr*hr))
c
c Exponential Variogram Model?
c
            else if(it(ist).eq.2) then
                  cova = cova + cc(ist)*exp(-3.0*h/aa(ist))
c
c Gaussian Variogram Model?
c
            else if(it(ist).eq.3) then
                  cova = cova + cc(ist)*exp(-3.*(h/aa(ist))*(h/aa(ist)))
c
c Power Variogram Model?
c
            else if(it(ist).eq.4) then
                  cova = cova + cmax - cc(ist)*(h**aa(ist))
c
c Hole Effect Model?
c
            else if(it(ist).eq.5) then
c                 d = 10.0 * aa(ist)
c                 cova = cova + cc(ist)*exp(-3.0*h/d)*cos(h/aa(ist)*PI)
                  cova = cova + cc(ist)*cos(h/aa(ist)*PI)
            endif
      end do
c
c Finished:
c
      return
      end