      PROGRAM MG3XDEMO
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C        'MGXDEMO' DEMONSTRATES THE CAPABILITIES OF A VERY SIMPLE MULTIGRID
C        SOLVER IN COMPUTING A THREE DIMENSIONAL POTENTIAL FIELD.  THIS IS
C        A SIMPLIFIED MULTIGRID SOLVER IN TWO IMPORTANT RESPECTS:
C
C                (1) IT SOLVES ONLY A CONSTANT COEFFICIENT EQUATION,
C                AND THAT ONLY ON A UNIFORM CUBICAL GRID,
C
C                (2) IT SOLVES ONLY A SINGLE EQUATION, REPRESENTING
C                A SCALAR FIELD RATHER THAN A VECTOR FIELD.
C
C        WE CHOSE IT FOR ITS PORTABILITY AND SIMPLICITY, AND EXPECT THAT A
C        SUPERCOMPUTER WHICH CAN RUN IT EFFECTIVELY WILL ALSO BE ABLE TO
C        RUN MORE COMPLEX MULTIGRID PROGRAMS AT LEAST AS WELL.
C
C              ERIC BARSZCZ                        PAUL FREDERICKSON
C                                                      RIACS
C        NASA AMES RESEARCH CENTER            NASA AMES RESEARCH CENTER
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      INTEGER LM, NM, NV, NR, NIT

      PARAMETER( LM=8 )
C      PARAMETER( NIT=40 )

      PARAMETER( NM=2+2**LM, NV=NM**3 )
      PARAMETER( NR = (8*(NM**3+NM**2+5*NM-23+7*LM))/7 )
C
      COMMON /X/ U, V, R, A, C, IR, MM
      REAL*8 U(NR),V(NV),R(NR),A(0:3),C(0:3)
      REAL*8 RNM2, RNMU, OLD2, OLDU
      REAL*8 XX
      INTEGER IR(LM), MM(LM)
      INTEGER IT, N
C
C
      A(0) = -8.0D0/3.0D0
      A(1) =  0.0D0
      A(2) =  1.0D0/6.0D0
      A(3) =  1.0D0/12.0D0
C
      C(0) =  -3.0D0/8.0D0
      C(1) =  +1.0D0/32.0D0
      C(2) =  -1.0D0/64.0D0
      C(3) =   0.0D0

      READ *,LMI
      READ *,NIT
      READ *,NTIMES
C
      N  = 2 + 2**LMI

      WRITE(6,7)N-2,N-2,N-2,NIT
C
      CALL SETUP(LMI,IR,MM)
      XX = 314159265.D0
      DO 1000 MTIME=1,NTIMES
      CALL ZERO3(U,N,N,N)
      CALL ZRAN3(XX,V,N,N,N)

      CALL RESID(U,V,R,N,A)
      CALL NORM2U3(R,N,N,N,RNM2,RNMU,N,N,N)
           OLD2 = RNM2
           OLDU = RNMU
C
      DO 20 IT=1,NIT
        CALL MG3P(U,V,R,N,A,C,NV,NR,IR,MM,LMI)
        CALL RESID(U,V,R,N,A)
 20   CONTINUE
C
C
        CALL NORM2U3(R,N,N,N,RNM2,RNMU,N,N,N)
        WRITE(6,'(A40)')
        WRITE(6,'(A40)')' IT    L2-NORM(R)         UNIF-NORM(R)'
        WRITE(6,6) 0, OLD2, OLDU
        WRITE(6,6) NIT, RNM2, RNMU

C //@; BEGIN(end0=CODE.Label)
1000  CONTINUE
C
C

 6    FORMAT( I4, 2E19.12)
 7    FORMAT(/,' KERNEL B:  SOLVING A POISSON PROBLEM ON A ',I3,' BY ',
     > I3,' BY ',I3,' GRID,',/,' USING ',I1,' MULTIGRID ITERATIONS.',/)
C
      STOP

      END
*
******  MG3P   IMPLEMENTS A SIMPLE, CONSTANT COEFFICIENT VERSION OF THE
******        MG ALGORITHM FAPIN (FAST APPROXIMATE INVERSE)
*
      SUBROUTINE MG3P(U,V,R,N,A,C,NV,NR,IR,MM,LM)
C
      INTEGER N,NV,NR,LM
      REAL*8 U(NR),V(NV),R(NR)
      REAL*8 A(0:3),C(0:3)
      INTEGER IR(LM), MM(LM)
C
      INTEGER K, J
C
      DO 50 K= LM, 2, -1
      J=K-1
      CALL RPRJ3(R(IR(K)),MM(K),R(IR(J)),MM(J))
 50   CONTINUE
C
      K = 1
      CALL ZERO3(U(IR(K)),MM(K),MM(K),MM(K))
      CALL PSINV(R(IR(K)),U(IR(K)),MM(K),C)
      IF( LM .EQ. 2 )GO TO 200
      DO 100 K = 2, LM-1
      J = K-1
      CALL ZERO3(U(IR(K)),MM(K),MM(K),MM(K))
      CALL INTERP(U(IR(J)),MM(J),U(IR(K)),MM(K))
      CALL RESID(U(IR(K)),R(IR(K)),R(IR(K)),MM(K),A)
      CALL PSINV(R(IR(K)),U(IR(K)),MM(K),C)
 100  CONTINUE
 200  CONTINUE
      J = LM - 1
      K = LM
      CALL INTERP(U(IR(J)),MM(J),U,N)
      CALL RESID(U,V,R,N,A)
      CALL PSINV(R,U,N,C)
C
      RETURN
      END
*
****** PSINV APPLIES AN APPROXIMATE INVERSE AS SMOOTHER:  U = U + CR
*
*      THIS SIMPLE IMPLEMENTATION COSTS  27A + 4M PER RESULT, WHERE
*      A AND M DENOTE THE COSTS OF ADDITION AND MULTIPLICATION.
*      BY USING SEVERAL TWO-DIMENSIONAL BUFFERS ONE CAN REDUCE THIS
*      COST TO  13A + 4M IN THE GENERAL CASE, OR  11A + 3M WHEN THE
*      COEFFICIENT C(3) IS ZERO.
*
      SUBROUTINE PSINV(R,U,N,C)
      INTEGER N
      REAL*8 U(N,N,N),R(N,N,N),C(0:3)
      INTEGER I3, I2, I1
C      WRITE(0,*) "SIZE", N
C
C //@; BEGIN(nest1=CODE.SingleLoop)
      DO 600 I3=2,N-1
      DO 600 I2=2,N-1
      DO 600 I1=2,N-1
 600  U(I1,I2,I3)=U(I1,I2,I3)
     >      +C(0)*( R(I1,  I2,  I3  ) )
     >      +C(1)*( R(I1-1,I2,  I3  ) + R(I1+1,I2,  I3  )
     >           +  R(I1,  I2-1,I3  ) + R(I1,  I2+1,I3  )
     >           +  R(I1,  I2,  I3-1) + R(I1,  I2,  I3+1) )
     >      +C(2)*( R(I1-1,I2-1,I3  ) + R(I1+1,I2-1,I3  )
     >           +  R(I1-1,I2+1,I3  ) + R(I1+1,I2+1,I3  )
     >           +  R(I1,  I2-1,I3-1) + R(I1,  I2+1,I3-1)
     >           +  R(I1,  I2-1,I3+1) + R(I1,  I2+1,I3+1)
     >           +  R(I1-1,I2,  I3-1) + R(I1-1,I2,  I3+1)
     >           +  R(I1+1,I2,  I3-1) + R(I1+1,I2,  I3+1) )
     >      +C(3)*( R(I1-1,I2-1,I3-1) + R(I1+1,I2-1,I3-1)
     >           +  R(I1-1,I2+1,I3-1) + R(I1+1,I2+1,I3-1)
     >           +  R(I1-1,I2-1,I3+1) + R(I1+1,I2-1,I3+1)
     >           +  R(I1-1,I2+1,I3+1) + R(I1+1,I2+1,I3+1) )
C
         CALL COMM3(U,N)
      WRITE (6,9000) (((U(I1,I2,I3),
     1               I1=1,N,69), I2=1,N,69), I3=1,N,69)
9000  FORMAT (1X, E15.6)
C
      RETURN
      END
*
******* RESID COMPUTES THE RESIDUAL:  R = V - AU
*
*      THIS SIMPLE IMPLEMENTATION COSTS  27A + 4M PER RESULT, WHERE
*      A AND M DENOTE THE COSTS OF ADDITION (OR SUBTRACTION) AND
*      MULTIPLICATION, RESPECTIVELY.  BY USING SEVERAL TWO-DIMENSIONAL
*      BUFFERS ONE CAN REDUCE THIS COST TO  13A + 4M IN THE GENERAL
*      CASE, OR  10A + 3M WHEN THE COEFFICIENT A(1) IS ZERO.
*
      SUBROUTINE RESID(U,V,R,N,A)
      INTEGER N
      REAL*8 U(N,N,N),V(N,N,N),R(N,N,N),A(0:3)
      INTEGER I3, I2, I1

C
C //@; BEGIN(nest2=CODE.SingleLoop)
      DO 600 I3=2,N-1
      DO 600 I2=2,N-1
      DO 600 I1=2,N-1
 600  R(I1,I2,I3)=V(I1,I2,I3)
     >      -A(0)*( U(I1,  I2,  I3  ) )
     >      -A(1)*( U(I1-1,I2,  I3  ) + U(I1+1,I2,  I3  )
     >                 +  U(I1,  I2-1,I3  ) + U(I1,  I2+1,I3  )
     >                 +  U(I1,  I2,  I3-1) + U(I1,  I2,  I3+1) )
     >      -A(2)*( U(I1-1,I2-1,I3  ) + U(I1+1,I2-1,I3  )
     >                 +  U(I1-1,I2+1,I3  ) + U(I1+1,I2+1,I3  )
     >                 +  U(I1,  I2-1,I3-1) + U(I1,  I2+1,I3-1)
     >                 +  U(I1,  I2-1,I3+1) + U(I1,  I2+1,I3+1)
     >                 +  U(I1-1,I2,  I3-1) + U(I1-1,I2,  I3+1)
     >                 +  U(I1+1,I2,  I3-1) + U(I1+1,I2,  I3+1) )
     >      -A(3)*( U(I1-1,I2-1,I3-1) + U(I1+1,I2-1,I3-1)
     >                 +  U(I1-1,I2+1,I3-1) + U(I1+1,I2+1,I3-1)
     >                 +  U(I1-1,I2-1,I3+1) + U(I1+1,I2-1,I3+1)
     >                 +  U(I1-1,I2+1,I3+1) + U(I1+1,I2+1,I3+1) )
C
         CALL COMM3(R,N)
C
      RETURN
      END
*
****** RPRJ3 PROJECTS ONTO THE NEXT COARSER GRID,
****** USING A TRILINEAR FINITE ELEMENT PROJECTION:  S = R' = P R
*
*      THIS SIMPLE IMPLEMENTATION COSTS  27A + 4M PER RESULT, WHERE
*      A AND M DENOTE THE COSTS OF ADDITION AND MULTIPLICATION.
*      BY USING SEVERAL TWO-DIMENSIONAL BUFFERS ONE CAN REDUCE THIS
*      COST TO  23A + 1M.  (NOTE, HOWEVER, THAT THE NUMBER OF RESULTS
*      IS ABOUT 1/8 THAT OF THE OTHER THREE OPERATORS.)
*
      SUBROUTINE RPRJ3(R,MK,S,MJ)
      INTEGER MK, MJ
      REAL*8 R(MK,MK,MK), S(MJ,MJ,MJ)
      INTEGER J3, J2, J1, I3, I2, I1
C
C //@; BEGIN(nest3=CODE.SingleLoop)
      DO 100 J3=2,MJ-1
        I3 = 2*J3-1
      DO 100 J2=2,MJ-1
        I2 = 2*J2-1
      DO 100 J1=2,MJ-1
        I1 = 2*J1-1
 100  S(J1,J2,J3) =
     >      0.5D0 * ( R(I1,  I2,  I3  ) )
     >   + 0.25D0 * ( R(I1-1,I2,  I3  ) + R(I1+1,I2,  I3  )
     >             +  R(I1,  I2-1,I3  ) + R(I1,  I2+1,I3  )
     >             +  R(I1,  I2,  I3-1) + R(I1,  I2,  I3+1) )
     >  + 0.125D0 * ( R(I1-1,I2-1,I3  ) + R(I1+1,I2-1,I3  )
     >             +  R(I1-1,I2+1,I3  ) + R(I1+1,I2+1,I3  )
     >             +  R(I1,  I2-1,I3-1) + R(I1,  I2+1,I3-1)
     >             +  R(I1,  I2-1,I3+1) + R(I1,  I2+1,I3+1)
     >             +  R(I1-1,I2,  I3-1) + R(I1-1,I2,  I3+1)
     >             +  R(I1+1,I2,  I3-1) + R(I1+1,I2,  I3+1) )
     > + 0.0625D0 * ( R(I1-1,I2-1,I3-1) + R(I1+1,I2-1,I3-1)
     >             +  R(I1-1,I2+1,I3-1) + R(I1+1,I2+1,I3-1)
     >             +  R(I1-1,I2-1,I3+1) + R(I1+1,I2-1,I3+1)
     >             +  R(I1-1,I2+1,I3+1) + R(I1+1,I2+1,I3+1) )
C
      CALL COMM3(S,MJ)
C
      RETURN
      END
*
****** INTERP ADDS THE TRILINEAR INTERPOLATION OF THE CORRECTION
****** FROM THE COARSER GRID TO THE CURRENT APPROXIMATION:  U = U + QU'
*
*      THIS SIMPLE IMPLEMENTATION COSTS  (27/8)A + (7/8)M PER RESULT,
*      WHERE A AND M DENOTE THE COSTS OF ADDITION AND MULTIPLICATION.
*      BY USING SEVERAL TWO-DIMENSIONAL BUFFERS ONE CAN REDUCE THIS
*      COST TO  (15/8)A + (7/8)M.
*
      SUBROUTINE INTERP(Z,M,U,N)
      REAL*8 Z(M,M,M),U(N,N,N)
      INTEGER M, N
      INTEGER I3, I2, I1
C
C //@; BEGIN(nest4=CODE.LoopNestList)
      DO 400 I3=2,M-1
         DO 200 I2=2,M-1
            DO 100 I1=2,M-1
            U(2*I1-1,2*I2-1,2*I3-1)=U(2*I1-1,2*I2-1,2*I3-1)
     >      +Z(I1,I2,I3)
 100        CONTINUE
            DO 200 I1=2,M-1
            U(2*I1-2,2*I2-1,2*I3-1)=U(2*I1-2,2*I2-1,2*I3-1)
     >      +0.5D0*(Z(I1-1,I2,I3)+Z(I1,I2,I3))
 200     CONTINUE
         DO 400 I2=2,M-1
            DO 300 I1=2,M-1
            U(2*I1-1,2*I2-2,2*I3-1)=U(2*I1-1,2*I2-2,2*I3-1)
     >      +0.5D0*(Z(I1,I2-1,I3)+Z(I1,I2,I3))
 300        CONTINUE
               DO 400 I1=2,M-1
            U(2*I1-2,2*I2-2,2*I3-1)=U(2*I1-2,2*I2-2,2*I3-1)
     >      +0.25D0*(Z(I1-1,I2-1,I3)+Z(I1-1,I2,I3)
     >            +Z(I1,  I2-1,I3)+Z(I1,  I2,I3))
 400  CONTINUE
C
      DO 800 I3=2,M-1
         DO 600 I2=2,M-1
            DO 500 I1=2,M-1
            U(2*I1-1,2*I2-1,2*I3-2)=U(2*I1-1,2*I2-1,2*I3-2)
     >      +0.5D0*(Z(I1,I2,I3-1)+Z(I1,I2,I3))
 500        CONTINUE
            DO 600 I1=2,M-1
            U(2*I1-2,2*I2-1,2*I3-2)=U(2*I1-2,2*I2-1,2*I3-2)
     >      +0.25D0*(Z(I1-1,I2,I3-1)+Z(I1,I2,I3-1)
     >            +Z(I1-1,I2,I3  )+Z(I1,I2,I3  ))
 600     CONTINUE
         DO 800 I2=2,M-1
            DO 700 I1=2,M-1
            U(2*I1-1,2*I2-2,2*I3-2)=U(2*I1-1,2*I2-2,2*I3-2)
     >      +0.25D0*(Z(I1,I2-1,I3-1)+Z(I1,I2,I3-1)
     >            +Z(I1,I2-1,I3  )+Z(I1,I2,I3  ))
 700        CONTINUE
               DO 800 I1=2,M-1
            U(2*I1-2,2*I2-2,2*I3-2)=U(2*I1-2,2*I2-2,2*I3-2)
     >      +0.125D0*(Z(I1-1,I2-1,I3-1)+Z(I1-1,I2,I3-1)
     >             +Z(I1,  I2-1,I3-1)+Z(I1,  I2,I3-1)
     >             +Z(I1-1,I2-1,I3  )+Z(I1-1,I2,I3  )
     >             +Z(I1,  I2-1,I3  )+Z(I1,  I2,I3  ))
 800  CONTINUE
C
        CALL COMM3(U,N)
C
      RETURN
      END
*
****** COMM3 COMMUNICATES ON ALL BORDERS OF AN ARRAY
*
      SUBROUTINE COMM3(U,N)
      INTEGER N
      REAL*8 U(N,N,N)
      INTEGER I3, I2, I1
C
      DO 100 I3=2,N-1
        DO 100 I2=2,N-1
          U(1,I2,I3) = U(N-1,I2,I3)
          U(N,I2,I3) = U( 2, I2,I3)
 100  CONTINUE
C
      DO 200 I3=2,N-1
        DO 200 I1=1,N
          U(I1,1,I3) = U(I1,N-1,I3)
          U(I1,N,I3) = U(I1, 2, I3)
 200  CONTINUE
      DO 300 I2=1,N
        DO 300 I1=1,N
          U(I1,I2,1) = U(I1,I2,N-1)
          U(I1,I2,N) = U(I1,I2, 2 )
 300  CONTINUE
C
      RETURN
      END
*
****** NORM2U3 EVALUATES APPROXIMATIONS TO THE L2 NORM AND THE
****** UNIFORM (OR L-INFINITY OR CHEBYSHEV) NORM, UNDER THE
****** ASSUMPTION THAT THE BOUNDARIES ARE PERIODIC OR ZERO.  ADD THE
****** BOUNDARIES IN WITH HALF WEIGHT (QUARTER WEIGHT ON THE EDGES
****** AND EIGTH WEIGHT AT THE CORNERS) FOR INHOMOGENEOUS BOUNDARIES.
*
      SUBROUTINE NORM2U3(R,N1,N2,N3,RNM2,RNMU,NX,NY,NZ)
      INTEGER N1, N2, N3, NX, NY, NZ
      REAL*8 RNM2, RNMU, R(N1,N2,N3)
      REAL*8 S, A
      INTEGER I3, I2, I1
C
      S=0.0D0
      RNMU = 0.0D0
      DO 100 I3=2,N3-1
         DO 100 I2=2,N2-1
            DO 100 I1=2,N1-1
               S=S+R(I1,I2,I3)**2
               A=ABS(R(I1,I2,I3))
               IF(A.GT.RNMU)RNMU=A
 100  CONTINUE
      RNM2=SQRT(S/FLOAT((NX-2)*(NY-2)*(NZ-2)))
C
      RETURN
      END
*
****** SETUP   MUST BE CALLED BEFORE MG3P
*
      SUBROUTINE SETUP(LM,IR,MM)
      INTEGER LM, IR(LM), MM(LM)
      INTEGER L, K
C
        MM(LM) = 2+2**LM
        DO 100 K = LM-1, 1, -1
          MM(K) = 1 + MM(K+1)/2
 100     CONTINUE
            L = LM
C
            IR(L)=1
            DO 200 K = L-1, 1, -1
            IR(K)=IR(K+1)+MM(K+1)**3
 200        CONTINUE
C
      RETURN
      END
*
***
*
      SUBROUTINE ZERO3(Z,NX,NY,NZ)
      INTEGER NX,NY,NZ
      REAL*8 Z(NX,NY,NZ)
      INTEGER I1, I2, I3
C
      DO 100 I3=1,NZ
      DO 100 I2=1,NY
      DO 100 I1=1,NX
 100  Z(I1,I2,I3)=0.0D0
C
      RETURN
      END
*
****** ZRAN3  LOADS +1 AT TEN RANDOMLY CHOSEN POINTS,
******        LOADS -1 AT A DIFFERENT TEN RANDOM POINTS,
******        AND ZERO ELSEWHERE.
*
      SUBROUTINE ZRAN3(X,Z,N1,N2,N3)
      INTEGER N1, N2, N3
      REAL*8 Z(N1,N2,N3)
      INTEGER M, I1, I2, I3
      REAL*8 X, A
      PARAMETER( M = 10,  A = 5.D0 ** 13 )
      INTEGER I, J1( M, 0:1 ), J2( M, 0:1 ), J3( M, 0:1 )
C
C
        READ(5,*)
	READ(5,9007)(J1(I,0),J2(I,0),J3(I,0),I=1,M)
        READ(5,*)
	READ(5,9007)(J1(I,1),J2(I,1),J3(I,1),I=1,M)
9007	FORMAT(5(2X,I3,2(1X,I3),1X))
C
        WRITE(6,*)' NEGATIVE CHARGES AT'
	WRITE(6,7)(J1(I,0),J2(I,0),J3(I,0),I=1,M)
        WRITE(6,*)' POSITIVE CHARGES AT'
	WRITE(6,7)(J1(I,1),J2(I,1),J3(I,1),I=1,M)
 7	FORMAT(5(' (',I3,2(',',I3),')'))
C
      DO 400 I3=1,N3
      DO 400 I2=1,N2
      DO 400 I1=1,N1
	Z(I1,I2,I3) = 0.0D0
 400  CONTINUE
C
	DO 500 I=1,M
	  Z( J1(I,0), J2(I,0), J3(I,0) ) = -1.0D0
	  Z( J1(I,1), J2(I,1), J3(I,1) ) = +1.0D0
 500	CONTINUE
C
        CALL COMM3(Z,N1)
C
      RETURN
      END
*
***** BUBBLE	DOES A BUBBLE SORT IN DIRECTION DIR
*
	SUBROUTINE BUBBLE( TEN, J1, J2, J3, M, IND )
	REAL*8 TEN( M, 0:1 )
        INTEGER M, IND, J1( M, 0:1 ), J2( M, 0:1 ), J3( M, 0:1 )
	REAL*8 DIR, TEMP
	INTEGER I, JXTEMP
C
	IF( IND .EQ. 1 )THEN
	  DIR = +1.0D0
	ELSE
	  DIR = -1.0D0
	ENDIF
C
	DO 100 I=1,M-1
	  IF( DIR*TEN(I,IND) .GT. DIR*TEN(I+1,IND) )THEN
	    TEMP = TEN( I+1, IND )
	    TEN( I+1, IND ) = TEN( I, IND )
	    TEN( I, IND ) = TEMP
C
	    JXTEMP	   = J1( I+1, IND )
	    J1( I+1, IND ) = J1( I,   IND )
	    J1( I,   IND ) = JXTEMP
C
	    JXTEMP	   = J2( I+1, IND )
	    J2( I+1, IND ) = J2( I,   IND )
	    J2( I,   IND ) = JXTEMP
C
	    JXTEMP	   = J3( I+1, IND )
	    J3( I+1, IND ) = J3( I,   IND )
	    J3( I,   IND ) = JXTEMP
C
	  ELSE
	    RETURN
	  ENDIF
C
 100	CONTINUE
C
	RETURN
	END


      SUBROUTINE PDLAHRD( N, K, NB, A, IA, JA, DESCA, TAU, T, Y, IY, JY,
     $                    DESCY, WORK )
*
*  -- ScaLAPACK auxiliary routine (version 1.7) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     May 1, 1997
*
*     .. Scalar Arguments ..
      INTEGER             IA, IY, JA, JY, K, N, NB
*     ..
*     .. Array Arguments ..
      INTEGER             DESCA( * ), DESCY( * )
      DOUBLE PRECISION    A( * ), T( * ), TAU( * ), WORK( * ), Y( * )
*     ..
*
*  Purpose
*  =======
*
*  PDLAHRD reduces the first NB columns of a real general N-by-(N-K+1)
*  distributed matrix A(IA:IA+N-1,JA:JA+N-K) so that elements below the
*  k-th subdiagonal are zero. The reduction is performed by an orthogo-
*  nal similarity transformation Q' * A * Q. The routine returns the
*  matrices V and T which determine Q as a block reflector I - V*T*V',
*  and also the matrix Y = A * V * T.
*
*  This is an auxiliary routine called by PDGEHRD. In the following
*  comments sub( A ) denotes A(IA:IA+N-1,JA:JA+N-1).
*
*  Arguments
*  =========
*
*  N       (global input) INTEGER
*          The number of rows and columns to be operated on, i.e. the
*          order of the distributed submatrix sub( A ).
*          N >= 0.
*
*  K       (global input) INTEGER
*          The offset for the reduction. Elements below the k-th
*          subdiagonal in the first NB columns are reduced to zero.
*
*  NB      (global input) INTEGER
*          The number of columns to be reduced.
*
*  A       (local input/local output) DOUBLE PRECISION pointer into
*          the local memory to an array of dimension (LLD_A,
*          LOCc(JA+N-K)). On entry, this array contains the the local
*          pieces of the N-by-(N-K+1) general distributed matrix
*          A(IA:IA+N-1,JA:JA+N-K). On exit, the elements on and above
*          the k-th subdiagonal in the first NB columns are overwritten
*          with the corresponding elements of the reduced distributed
*          matrix; the elements below the k-th subdiagonal, with the
*          array TAU, represent the matrix Q as a product of elementary
*          reflectors. The other columns of A(IA:IA+N-1,JA:JA+N-K) are
*          unchanged. See Further Details.
*
*  IA      (global input) INTEGER
*          The row index in the global array A indicating the first
*          row of sub( A ).
*
*  JA      (global input) INTEGER
*          The column index in the global array A indicating the
*          first column of sub( A ).
*
*  DESCA   (global and local input) INTEGER array of dimension DLEN_.
*          The array descriptor for the distributed matrix A.
*
*  TAU     (local output) DOUBLE PRECISION array, dimension LOCc(JA+N-2)
*          The scalar factors of the elementary reflectors (see Further
*          Details). TAU is tied to the distributed matrix A.
*
*  T       (local output) DOUBLE PRECISION array, dimension (NB_A,NB_A)
*          The upper triangular matrix T.
*
*  Y       (local output) DOUBLE PRECISION pointer into the local memory
*          to an array of dimension (LLD_Y,NB_A). On exit, this array
*          contains the local pieces of the N-by-NB distributed
*          matrix Y. LLD_Y >= LOCr(IA+N-1).
*
*  IY      (global input) INTEGER
*          The row index in the global array Y indicating the first
*          row of sub( Y ).
*
*  JY      (global input) INTEGER
*          The column index in the global array Y indicating the
*          first column of sub( Y ).
*
*  DESCY   (global and local input) INTEGER array of dimension DLEN_.
*          The array descriptor for the distributed matrix Y.
*
*  WORK    (local workspace) DOUBLE PRECISION array, dimension (NB)
*
*  Further Details
*  ===============
*
*  The matrix Q is represented as a product of nb elementary reflectors
*
*     Q = H(1) H(2) . . . H(nb).
*
*  Each H(i) has the form
*
*     H(i) = I - tau * v * v'
*
*  where tau is a real scalar, and v is a real vector with
*  v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in
*  A(ia+i+k:ia+n-1,ja+i-1), and tau in TAU(ja+i-1).
*
*  The elements of the vectors v together form the (n-k+1)-by-nb matrix
*  V which is needed, with T and Y, to apply the transformation to the
*  unreduced part of the matrix, using an update of the form:
*  A(ia:ia+n-1,ja:ja+n-k) := (I-V*T*V')*(A(ia:ia+n-1,ja:ja+n-k)-Y*V').
*
*  The contents of A(ia:ia+n-1,ja:ja+n-k) on exit are illustrated by the
*  following example with n = 7, k = 3 and nb = 2:
*
*     ( a   h   a   a   a )
*     ( a   h   a   a   a )
*     ( a   h   a   a   a )
*     ( h   h   a   a   a )
*     ( v1  h   a   a   a )
*     ( v1  v2  a   a   a )
*     ( v1  v2  a   a   a )
*
*  where a denotes an element of the original matrix
*  A(ia:ia+n-1,ja:ja+n-k), h denotes a modified element of the upper
*  Hessenberg matrix H, and vi denotes an element of the vector
*  defining H(i).
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
     $                   LLD_, MB_, M_, NB_, N_, RSRC_
      PARAMETER          ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
     $                     CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
     $                     RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            IPROC
      INTEGER            I, IACOL, IAROW, ICTXT, IOFF, II, J, JJ, JL,
     $                   JT, JW, L, MYROW, MYCOL, NPCOL, NPROW, NQ
      DOUBLE PRECISION   EI
*     ..
*     .. Local Arrays ..
      INTEGER            DESCW( DLEN_ )
*     ..
*     .. External Functions ..
      INTEGER            NUMROC
      EXTERNAL           NUMROC
*     ..
*     .. External Subroutines ..
      EXTERNAL           BLACS_GRIDINFO, DAXPY, DESCSET, DCOPY,
     $                   DSCAL, DTRMV, INFOG2L, PDELSET,
     $                   PDGEMV, PDLARFG, PDSCAL
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MIN, MOD
*     ..
*     .. Executable Statements ..
*
*     Quick return if possible
*
      IF( N.LE.1 )
     $   RETURN
*
      ICTXT = DESCA( CTXT_ )
      CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
*
      IOFF = MOD( JA-1, DESCA( NB_ ) )
      CALL INFOG2L( IA+K, JA, DESCA, NPROW, NPCOL, MYROW, MYCOL, II,
     $              JJ, IAROW, IACOL )
*
      IPROC = ( MYROW.EQ.IAROW .AND. MYCOL.EQ.IACOL )
      NQ = NUMROC( N+JA-1, DESCA( NB_ ), MYCOL, IACOL, NPCOL )
      IF( MYCOL.EQ.IACOL )
     $   NQ = NQ - IOFF
*
      EI = ZERO

      JW = IOFF + 1
      CALL DESCSET( DESCW, 1, DESCA( MB_ ), 1, DESCA( MB_ ), IAROW,
     $              IACOL, ICTXT, 1 )
*
      DO 10 L = 1, NB
         I = IA + K + L - 2
         J = JA + L - 1
*
         IF( L.GT.1 ) THEN
*
*           Update A(ia:ia+n-1,j)
*
*           Compute i-th column of A - Y * V'
*
            CALL PDGEMV( 'No transpose', N, L-1, -ONE, Y, IY, JY, DESCY,
     $                   A, I, JA, DESCA, DESCA( M_ ), ONE, A, IA, J,
     $                   DESCA, 1 )
*
*           Apply I - V * T' * V' to this column (call it b) from the
*           left, using the last column of T as workspace
*
*           Let  V = ( V1 )   and   b = ( b1 )   (first I-1 rows)
*                    ( V2 )             ( b2 )
*
*           where V1 is unit lower triangular
*
*           w := V1' * b1
*
            IF( IPROC ) THEN
               CALL DCOPY( L-1, A( (JJ+L-2)*DESCA( LLD_ )+II ), 1,
     $                     WORK( JW ), 1 )
               CALL DTRMV( 'Lower', 'Transpose', 'Unit', L-1,
     $                     A( (JJ-1)*DESCA( LLD_ )+II ), DESCA( LLD_ ),
     $                     WORK( JW ), 1 )
            END IF
*
*           w := w + V2'*b2
*
            CALL PDGEMV( 'Transpose', N-K-L+1, L-1, ONE, A, I+1, JA,
     $                   DESCA, A, I+1, J, DESCA, 1, ONE, WORK, 1, JW,
     $                   DESCW, DESCW( M_ ) )
*
*           w := T'*w
*
            IF( IPROC )
     $         CALL DTRMV( 'Upper', 'Transpose', 'Non-unit', L-1, T,
     $                     DESCA( NB_ ), WORK( JW ), 1 )
*
*           b2 := b2 - V2*w
*
            CALL PDGEMV( 'No transpose', N-K-L+1, L-1, -ONE, A, I+1, JA,
     $                   DESCA, WORK, 1, JW, DESCW, DESCW( M_ ), ONE,
     $                   A, I+1, J, DESCA, 1 )
*
*           b1 := b1 - V1*w
*
            IF( IPROC ) THEN
               CALL DTRMV( 'Lower', 'No transpose', 'Unit', L-1,
     $                     A( (JJ-1)*DESCA( LLD_ )+II ), DESCA( LLD_ ),
     $                     WORK( JW ), 1 )
               CALL DAXPY( L-1, -ONE, WORK( JW ), 1,
     $                     A( ( JJ+L-2 )*DESCA( LLD_ )+II ), 1 )
            END IF
            CALL PDELSET( A, I, J-1, DESCA, EI )
         END IF
*
*        Generate the elementary reflector H(i) to annihilate
*        A(ia+k+i:ia+n-1,j)
*
         CALL PDLARFG( N-K-L+1, EI, I+1, J, A, MIN( I+2, N+IA-1 ), J,
     $                 DESCA, 1, TAU )
         CALL PDELSET( A, I+1, J, DESCA, ONE )
*
*        Compute  Y(iy:y+n-1,jy+l-1)
*
         CALL PDGEMV( 'No transpose', N, N-K-L+1, ONE, A, IA, J+1,
     $                DESCA, A, I+1, J, DESCA, 1, ZERO, Y, IY, JY+L-1,
     $                DESCY, 1 )
         CALL PDGEMV( 'Transpose', N-K-L+1, L-1, ONE, A, I+1, JA, DESCA,
     $                A, I+1, J, DESCA, 1, ZERO, WORK, 1, JW, DESCW,
     $                DESCW( M_ ) )
         CALL PDGEMV( 'No transpose', N, L-1, -ONE, Y, IY, JY, DESCY,
     $                WORK, 1, JW, DESCW, DESCW( M_ ), ONE, Y, IY,
     $                JY+L-1, DESCY, 1 )
         JL = MIN( JJ+L-1, JA+NQ-1 )
         CALL PDSCAL( N, TAU( JL ), Y, IY, JY+L-1, DESCY, 1 )
*
*        Compute T(1:i,i)
*
         IF( IPROC ) THEN
            JT = ( L-1 ) * DESCA( NB_ )
            CALL DSCAL( L-1, -TAU( JL ), WORK( JW ), 1 )
            CALL DCOPY( L-1, WORK( JW ), 1, T( JT+1 ), 1 )
            CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', L-1, T,
     $                  DESCA( NB_ ), T( JT+1 ), 1 )
            T( JT+L ) = TAU( JL )
         END IF
   10 CONTINUE
*
      CALL PDELSET( A, K+NB+IA-1, J, DESCA, EI )
*
      RETURN
*
*     End of PDLAHRD
*
      END


      subroutine sortbins
     1     (imsgin,xmsgin,cmsgin,msgtyp,nwds,ier)
C
C#######################################################################
C    FORMAT - sort/cmoname/bins/
C                  [ASCENDING|descending]/[ikey]/in_att/[epsilon_user]
C    FORMAT - sort/cmoname/index|rank/
C                  [ASCENDING|descending]/[ikey]/in_att1 in_att2 in_att3 ...
C    FORMAT - sort/cmoname/line_graph/
C                  [ASCENDING|descending]/[ikey]/lg_sort_type
C
C    INPUT ARGUMENTS - imsgin,xmsgin,cmsgin,msgtyp,nwds
C    TOKENS
C     1      sort
C     2      cmoname = name of MO to operate on ( / / and /-def/ supported)
C
C     3      index - multi-key sort such that in_att1(ikey(i)) i=1,...nnodes
C                    lists the attribute in_att1 in ascending or descending order.
C
C                    The ikey attribute will contain the permutation vector
C                    that could then be used in reordering the MO.
C                    (i.e. reorder/cmo/ikey)
C
C     3      rank  - multi-key sort such that ikey(i) lists the ranking of the node
C                    in the sorted list.
C     3      bins  - single-key sort which assigns each in_att1 value a bin.
C                    ikey(i) list the bin number of in_att1(i)
C                    If all array values are unique, then the maximum
C                    value of the index array will equal the number of
C                    entries in the sorted list. Otherwise, the
C                    maximum value of the index array will be less than
C                    the number of entries in the sorted list but will
C                    equal the number of unique entries in the list.
C
C                    When the bins option is used there is an optional
C                    argument, epsilon_user, that sets the epsilon value
C                    used to compare bins. Default is 1.e-10.
C
C     3      line_graph algorithm sorts elements or nodes
C                    default calls sort on elements
C
C     4      ascending - default, sort in ascending order
C
C     4      descending - sort in descending order
C
C     5      ikey - integer vector (VINT) which will hold the output
C                   sorted key values. If it exists it will be used,
C                   if it does not exist it will be created.
C                   If token is -def- the default key attribute name
C                   will be concatination of 'ikey_' and the first
C                   input attribute name. (i.e. /-def-/imt will produce
C                   a sort key named ikey_imt). If the line_graph option
C		    is used, and token is -def- the key_name name will
C		    be named 'lg_ikey_nodes' or 'lg_ikey_elements'
C
C
C      6     in_att - input attribute node based array upon which the
C                     sorting routine will sort
C
C                     Multi-key sorts can have an arbitrary number of input
C                     attributes. Attribute in_att1(n) has priority over
C                     in_att2(n) in breaking ties.
C
C
C      6     lg_sort_type (for line_graph) - character string which controls
C                           the key_name
C			    that will be created by the line_graph
C			    algorithm. Options are 'nodes' and 'elements'
C                           Default is elements
C
C             Note: all attributes are put into a real*8 work array
C             before being sent to the sort routine.
C
C    Old Syntax still supported
C
C    USAGE - sort/xyz/[INDEX|bins|rank]
C
C            sort/xyz/index - sorts the x,y,z coordinates integer arrays
C            i_index, J_index, k_index such that xic(i_index(i)) i=1,..nnodes
C            lists the coordinate in ascending order.
C            sort/xyz/bins - sorts the x,y,z coordinates and assigns each
C            i_index, j_index, k_index values in ascending order of
C            the bin number of the sorted list.
C            sort/xyz/rank - sorts the x,y,z coordinates and assigns each
C            i_index, j_index, k_index values the ranking of the
C            node in the sorted list.
C
C            If all array values are unique, then the maximum
C            value of the index array will equal the number of
C            entries in the sorted list. Otherwise, the
C            maximum value of the index array will be less than
C            the number of entries in the sorted list but will
C            equal the number of unique entries in the list.
C
C            For example given                 x = 0, 1, 2, 1, 0
c            sort/xyz/index would return i_index = 5, 1, 4, 2, 3
C            sort/xyz/bins  would return i_index = 1, 2, 3, 2, 1
C            sort/xyz/rank  would return i_index = 2, 4, 5, 3, 1
C
C
C
C     OUTPUT ARGUMENTS - creates 3 new node lenght vector integer attributes
C                        i_index, j_index, k_index.
C
C    END OF Old Syntax still supported
C
C     CHANGE HISTORY -
C        $Log: sortbins.f,v $
C        Revision 2.00  2007/11/09 20:04:03  spchu
C        Import to CVS
C
CPVCS
CPVCS       Rev 1.9   29 Aug 2007 10:52:50   gable
CPVCS    Corrected spelling of keyword descending. Left in option of using misspelled
CPVCS    keyword decending.
CPVCS
CPVCS       Rev 1.8   25 Jul 2007 10:01:54   gable
CPVCS    Added option for user control of epsilon value in bins option.
CPVCS
CPVCS       Rev 1.7   08 Feb 2006 14:35:32   dcg
CPVCS    "enforce lower case - add external statements for shift routines
CPVCS    these changes needed to compile with absoft pro fortran"
CPVCS
CPVCS       Rev 1.6   12 May 2003 10:46:18   dcg
CPVCS    allow attributes of arbitrary length not just nnodes or nelements
CPVCS
CPVCS       Rev 1.5   01 Nov 2002 13:06:52   gable
CPVCS    Added ability to sort on element attributes.
CPVCS
CPVCS       Rev 1.4   24 Apr 2001 10:16:14   jan
CPVCS    changed order of variable definition for nwds
CPVCS
CPVCS
CPVCS       Rev 1.3   06 Apr 2001 13:58:24   gable
CPVCS    Total change to syntax. Now supports multi-key sorting.
CPVCS
CPVCS       Rev 1.2   27 Apr 2000 12:07:14   dcg
CPVCS    remove call to cmo_get_info for iwork - iwork is not a mesh object attribute
CPVCS
CPVCS       Rev 1.1   Fri Jan 22 16:50:20 1999   dcg
CPVCS    move declaration of array length type before array declaration
CPVCS
CPVCS       Rev 1.0   Thu Sep 24 11:30:00 1998   gable
CPVCS    Initial revision.
C
C
C#######################################################################
C
      implicit none
      include 'local_element.h'
C
C     Variable/Data Dictionary
C
C     isort_type - string, which sort method to use.
C     catt_name - string, the name of array to sort.
C     itype_att - value, Type of array to sort, int-1 real-2
C     att_r - array, stores real values of array to sort.
C     att_i - array, stores int values of array to sort.
C
C     DEFINE THE MESH_OBJECT POINTERS.
C
      pointer (ipatt, att_r)
      pointer (ipatt, att_i)
      pointer (ipikey, ikey)
      pointer (ipiwork,iwork)
      pointer (iprwork,rwork)
      pointer (ipitet, itet)
      pointer (ipitettyp, itettyp)
C
C     Component id, component type, and loop id attributes, to be
C     created if the line_graph option is used.
C
      pointer (ipcid, cid)
C     Ordinarily we would call this attribute ctype. But let's call it
C     comptype because the variable ctype is already in use in this
C     source file.
      pointer (ipcomptype, comptype)
      pointer (iploopid, loopid)

      real*8 rwork(10000000)
      real*8 att_r(10000000)
      integer att_i(10000000)
      integer ikey(10000000)
      integer iwork(10000000)
      integer itet(10000000)
      integer itettyp(10000000)
      integer itype, ilen, ier, itype_att, irank
      integer ierror, ierr
      integer nwds, nnodes, nkey, mkey, nsize, ioff_set, narg_input
      integer cid, comptype, loopid
      integer nelem, nsort
      integer isort_order
      integer i, index, nend
      real*8 rsort_order
      real*8 epsilon_user
      real*8 xmsgin(nwds)
      integer imsgin(nwds),msgtyp(nwds)
      integer icharlnf

      character*32 cmsgin(nwds)
      character*32 isubname, cmonam
      character*32 key_name
C     nsort_clen will either be 'nnodes' or 'nelements'.
      character*32 nsort_clen, lg_sort_type
      character*32 isort_type
      character*32 sort_order
      character*32 catt_name
      character*32 ctype,crank,clen,cinter,cpers,cio
      character*132 cmdmessage
      character*132 logmess
C
C#######################################################################
C begin BEGIN SORT

C     set defaults for some important name strings and counters
      isubname='sortbins'
      isort_type = 'notset'
      nsort_clen = 'notset'
      lg_sort_type = 'notset'
      key_name = 'notset'
      nnodes = 0
      nelem = 0
      nsort = 0
      ier = 0
c
C#######################################################################
C    SETUP and PARSE TOKENS
C#######################################################################
c
c    TOKEN 2 - Get the mesh object
c

c     Get default mesh object if -def-
      cmonam = cmsgin(2)
      if((cmsgin(2)(1:icharlnf(cmsgin(2))) .eq. '-def-'))
     1   then
         call cmo_get_name(cmonam, ier)
         if(ier.ne.0) then
           write(logmess,9000) cmsgin(2)(1:icharlnf(cmsgin(2)))
 9000   format(" ERROR SORT: found bad mesh object: ",a)
           call writloga('default',0,logmess,0,ier)
           goto 9999
         endif
      endif

C     Check that cmonam is a valid mesh object

      call cmo_exist(cmonam,ier)
      if(ier.ne.0) then
        write(logmess,*)
     *  ' ERROR SORT: mesh object does not exist: '
     *   //cmonam(1:icharlnf(cmonam))
        call writloga('default',0,logmess,1,ierr)
        goto 9999
      endif

      call cmo_get_intinfo('nnodes',cmonam,nnodes,ilen,itype,ier)
      if(ier .ne. 0) then
        write(logmess,9005) cmonam(1:icharlnf(cmonam))
 9005  format(" ERROR SORT: looking for nnodes of mesh object: ",a)
        call writloga('default',0,logmess,0,ier)
        goto 9999
      endif

C     Check that mesh object has elements
C
C      call cmo_get_intinfo('nelements',cmonam,nelem,ilen,itype,ier)
C      if(ier .ne. 0)then
C        write(logmess,9006) cmonam(1:icharlnf(cmonam))
C 9006  format(" ERROR SORT: looking for nelements of mesh object: ",a)
C        call writloga('default',0,logmess,1,ier)
C        goto 9999
C      endif
C      if (nelem .eq. 0) then
C         write(logmess, '(a)')
C     *   ' ERROR SORT: mesh object has 0 elements.'
C         call writloga('default',0,logmess,1,ier)
C         goto 9999
C      endif

C
C#######################################################################
C
C    TOKEN 3 - Get the sort method to be used (bins,index,rank,etc.)
C              also check on specific tokens related to each
C

C     isort_type index
      if((cmsgin(3)(1:icharlnf(cmsgin(3))) .eq. 'index') .or.
     1   (cmsgin(3)(1:icharlnf(cmsgin(3))) .eq. '-def-') .or.
     2   (nwds .eq. 1).or. (nwds .eq. 2))then
         isort_type = 'index'

C     isort_type bins
      elseif(cmsgin(3)(1:icharlnf(cmsgin(3))) .eq. 'bins') then
         isort_type = 'bins'
C
C        TOKEN 7 for bins - user specified epsilon

         epsilon_user = 1.e-10
         if(nwds .gt. 6)then
           if(msgtyp(7) .eq. 2)then
              epsilon_user = xmsgin(7)
           else
              write(logmess,9008) msgtyp(7)
 9008       format(" Warning SORT: Arg 7 epsilon_user not float: ",i2)
              call writloga('default',0,logmess,0,ier)
              write(logmess,'(a)')
     *        " SORT: Using default epsilon = 1.e-10 "
              call writloga('default',0,logmess,0,ier)
           endif
         endif

C     isort_type rank
      elseif(cmsgin(3)(1:icharlnf(cmsgin(3))) .eq. 'rank') then
         isort_type = 'rank'

C     isort_type line_graph
      elseif(cmsgin(3)(1:icharlnf(cmsgin(3))) .eq. 'line_graph') then

C        Check that mesh object has elements
         call cmo_get_intinfo('nelements',cmonam,nelem,ilen,itype,ier)
         if(ier .ne. 0)then
           write(logmess,9006) cmonam(1:icharlnf(cmonam))
 9006      format(" ERROR SORT: looking for nelements of
     *            mesh object: ",a)
           call writloga('default',0,logmess,1,ier)
           goto 9999
         endif
         if (nelem .eq. 0) then
            write(logmess, '(a)')
     *      ' ERROR SORT: mesh object has 0 elements.'
            call writloga('default',0,logmess,1,ier)
            goto 9999
         endif

         isort_type = 'line_graph'

         if (nwds .gt. 6) then
           write(logmess,'(a)')
     *      ' ERROR SORT: Too many arguments for line_graph option'
           call writloga('default',0,logmess,1,ier)
           goto 9999
         endif

      else
C       TOKEN 3 has not been recognized

        write(logmess,9010) cmsgin(3)(1:icharlnf(cmsgin(3)))
 9010   format(" ERROR SORT: invalid option 3 : ",a)
        call writloga('default',0,logmess,0,ier)
        write(logmess,9015)
 9015   format
     1  ("Usage: sort/cmo/[INDEX,bins,rank,line_graph]/...")
        call writloga('default',0,logmess,1,ier)
        goto 9999

      endif
C
C
C#######################################################################
C
C    TOKEN 4 - Determine if sort is in ascending or descending order
C
      sort_order = cmsgin(4)
      if((cmsgin(4)(1:icharlnf(cmsgin(4))) .eq. '-def-')) then
        isort_order = 1
        rsort_order = 1.0d0
      elseif((cmsgin(4)(1:icharlnf(cmsgin(4))) .eq. 'ascending')) then
        isort_order = 1
        rsort_order = 1.0d0
      elseif((cmsgin(4)(1:icharlnf(cmsgin(4))) .eq. 'descending')) then
        isort_order = -1
        rsort_order = -1.0d0
      elseif((cmsgin(4)(1:icharlnf(cmsgin(4))) .eq. 'decending')) then
C
C       Spelling of descending corrected, but keep around the old incorrect
C       spelling just to support old control files.
C
        isort_order = -1
        rsort_order = -1.0d0

      else
        write(logmess,'(a,a)')
     *  " ERROR SORT: invalid option 4: ",
     *    cmsgin(4)(1:icharlnf(cmsgin(4)))
        call writloga('default',0,logmess,0,ier)
        write(logmess,'(a)')
     *  " SORT: option should be ascending or descending"
        call writloga('default',0,logmess,1,ier)
        goto 9999
      endif

C######################################################################
C     TOKEN 5 - Get or create the sort key array name key_name
C
C     If default -def- then use the name of the first
C     attribute (command line argument 6) to name the sort key.
C
      if((cmsgin(5)(1:icharlnf(cmsgin(5))) .ne.'-def-') .and.
     *   nwds.ge.5 .and. msgtyp(5).eq.3  ) then
         key_name = cmsgin(5)

      elseif ((cmsgin(5)(1:icharlnf(cmsgin(5))).eq.'-def-') .and.
     *    nwds.ge.6 .and. msgtyp(6).eq.3 ) then

        key_name = 'ikey'//'_'//(cmsgin(6)(1:icharlnf(cmsgin(6))))
        write(logmess,'(a,a)')
     *  " SORT: using created name for sort key: ",
     *  key_name(1:icharlnf(key_name))
        call writloga('default',0,logmess,0,ier)

      elseif (nwds.lt.5 .and. key_name(1:6).eq.'notset') then

        key_name = 'lg_key_line_graph'
        write(logmess,'(a,a)')
     *  " SORT: using default name for sort key: ",
     *  key_name(1:icharlnf(key_name))
        call writloga('default',0,logmess,0,ier)

      endif

C######################################################################
C    TOKEN 6 - depends on isort_type
C            - get key name and add attribute of appropriate length

C     line_graph
C     TOKEN 6 is lg_sort_type
C     defined as elements or nodes (elements is the default)
C     note, we use lg_sort_type, but may be able to just use nsort_clen
      if (isort_type .eq. 'line_graph') then

        if (nwds .gt. 6) then
           write(logmess,'(a)')
     *      ' SORT ERROR: Too many arguments for line_graph option'
           call writloga('default',0,logmess,1,ier)
           goto 9999

         elseif (nwds .lt. 6 ) then
              lg_sort_type = "elements"
              write(logmess, '(a)')
     *        ' Default line_graph option: using "elements"'
              call writloga('default',0,logmess,0,ier)
         else
C           if nwds equal 6 look for valid key word tokens

            lg_sort_type = cmsgin(6)

C           allow short version node or nodes, elem or elements
            if(lg_sort_type(1:4).ne.'node' .and.
     *        lg_sort_type(1:4) .ne.'elem' )
     *        then
              write(logmess, '(a)')
     *        'Invalid option: line_graph must be "nodes" or "elements"'
              call writloga('default',0,logmess,0,ier)
              goto 9999
            endif

         endif

C        check for valid cmo and set attribute name
         if (lg_sort_type(1:4) .eq. 'node') then
            if (nnodes .eq. 0) then
                write(logmess, '(a)')
     *      ' ERROR SORT: Quitting early because there are 0 nodes.'
                call writloga('default',0,logmess,0,ier)
                goto 9999
             endif
             nsort = nnodes
             if (key_name(1:8) .eq. '-notset-')
     *           key_name = "lg_key_nodes"
             nsort_clen = "nnodes"
             lg_sort_type = "nodes"

         else
            if (nelem .eq. 0) then
               write(logmess, '(a)')
     *    ' ERROR SORT: Quitting early because there are 0 elements.'
               call writloga('default',0,logmess,0,ier)
               goto 9999
             endif
             nsort = nelem
             if (key_name(1:8) .eq. '-notset-')
     *           key_name = "lg_key_elements"
             nsort_clen = "nelements"
             lg_sort_type = "elements"
         endif

      else
C     TOKEN 6 - for all except line_graph
C     Get arrays that control the multi-key sort and put them
C     into a real*8 work arrays.

         narg_input = 6
C
C        TOKEN(S) narg_input through nwds
C        will be the arrays that control the sort.
C
         if(isort_type .ne. 'bins')then
            nkey = nwds - narg_input + 1
            nend = nwds
         else
            nkey = 1
            nend = narg_input
         endif
C
C        Use the first sort array to decide on the length of the sort
C        vector. All other sort vectors must be the same length.
C
         catt_name = cmsgin(narg_input)(1:icharlnf(cmsgin(narg_input)))
         call cmo_get_attparam(
     1      catt_name,cmonam,index,
     2      ctype,
     3      crank,
     4      clen,
     5      cinter,
     6      cpers,
     7      cio,
     8      ier)
         call cmo_get_length(catt_name,cmonam,ilen,irank,ier)
         nsize = ilen * nkey
         nsort = ilen
         nsort_clen = clen

         if(nsort .le. 0)then
          write(logmess, '(a,a,a,a)') " ERROR SORT: attribute: "
     *     ,catt_name(1:icharlnf(catt_name))
     *     ," of length ", clen
           call writloga('default',0,logmess,0,ier)
           write(logmess,9027) nsort
 9027     format(" ERROR SORT: nsort = ",i11)
           call writloga('default',0,logmess,1,ier)
           goto 9999
         endif

C
C        Allocate a 1D array that is nsort*nkey long. This
C        will be passed into the heap sort routine and treated
C        as a 2D array rwork(nkey,nsort)
C
         call mmgetblk('rwork',isubname,iprwork,nsize,2,ier)
         if(ier .ne. 0)then
           write(logmess, '(a,a,a,i11)')
     *     " ERROR SORT: allocating work array: rwork for option "
     *     ,isort_type(1:icharlnf(isort_type))
     *     ," of size ",nsize
           call writloga('default',0,logmess,1,ier)
           goto 9999
         endif

C
C        Fill the real*8 work array that will be passed to the sort
C        routine
C
         do mkey = narg_input, nend

         catt_name = cmsgin(mkey)(1:icharlnf(cmsgin(mkey)))

         call cmo_get_info(catt_name,cmonam,ipatt,ilen,itype_att,ier)
C
C        Check that attribute is nsort long
C
         call cmo_get_length(catt_name,cmonam,ilen,irank,ier)

         if(ilen .ne. nsort)then
           write(logmess,9026) ilen
 9026      format(" ERROR SORT: att_in length = ",i11)
           call writloga('default',0,logmess,0,ier)
           write(logmess,9027) nsort
           call writloga('default',0,logmess,1,ier)
           goto 9999
         endif
C
         call cmo_get_attparam(
     1      catt_name,cmonam,index,
     2      ctype,
     3      crank,
     4      clen,
     5      cinter,
     6      cpers,
     7      cio,
     8      ier)

            ioff_set = (mkey - narg_input)*nnodes
C
C           Kind of a funky counter system to get index value
C           but that's the way it is....
C
            if(ctype(1:4) .eq. 'VINT')then
               itype_att = 1
               do i = 1, nsort
                  index = (i-1)*nkey + (mkey - narg_input + 1)
                  rwork(index) = att_i(i)
               enddo
            elseif(ctype(1:7) .eq. 'VDOUBLE')then
               itype_att = 2
               do i = 1, nsort
                  index = (i-1)*nkey + (mkey - narg_input + 1)
                  rwork(index) = att_r(i)
               enddo
            else
               write(logmess,9028) ctype(1:icharlnf(ctype))
 9028          format(" ERROR SORT: attribute type=",a,
     *            " Must be VINT or VDOUBLE")
               call writloga('default',0,logmess,1,ier)
               goto 9999
            endif
         enddo

      endif
C     end TOKEN 6

C######################################################################
C     SETUP DONE - PARSED TOKENS DONE
C######################################################################
C     Allocate or get arrays for sort key pointer

C      get or create the sort key array with length type nsort_clen
C      Check to see if value in 'key_name' exists as a variable,
C      if not, then create it using a dotask call
C
C      Note,this should correctly create the attribute length
C      as nnodes or nelements as defined in value of nsort_clen
C
C      Note, there are some redundancies in the code with error
C      checking and extra variables that can be cleaned up.
C      For now they are left errors are caught if there are holes in logic
C
      ier = 0
      call mmfindbk(key_name,cmonam,ipikey,ilen,ier)

C     extra checks to make sure attribute for sort key is correct
C     some logic in above code will not have created the attribute yet
      if(ier .ne. 0) then

         ier = 0
         cmdmessage='cmo/addatt/'//cmonam(1:icharlnf(cmonam)) //
     1   '/'// key_name(1:icharlnf(key_name))//
     2   '/vint/scalar/'//nsort_clen//'/ / /gax/0 ; finish'
         call dotaskx3d(cmdmessage, ier)

      else
C     check that existing attribute has the correct length
C     we may want to delete these, but should work to reuse
C     as key array is intialized each time to 1 thru nsort

          if (nsort_clen(1:6) .eq. 'nnodes') then

             if (ilen .ne. nnodes) then
               cmdmessage='cmo/DELATT/'//cmonam(1:icharlnf(cmonam)) //
     *         '/'// key_name(1:icharlnf(key_name))//' ; finish'
               call dotaskx3d(cmdmessage, ier)

               cmdmessage='cmo/addatt/'//cmonam(1:icharlnf(cmonam)) //
     *         '/'// key_name(1:icharlnf(key_name))//
     *         '/vint/scalar/'//nsort_clen//'/ / /gax/0 ; finish'
               call dotaskx3d(cmdmessage, ier)

             endif

          elseif (nsort_clen(1:9) .eq. 'nelements') then

             if (ilen .ne. nelem ) then
               cmdmessage='cmo/DELATT/'//cmonam(1:icharlnf(cmonam)) //
     *         '/'// key_name(1:icharlnf(key_name))//' ; finish'
               call dotaskx3d(cmdmessage, ier)

               cmdmessage='cmo/addatt/'//cmonam(1:icharlnf(cmonam)) //
     *         '/'// key_name(1:icharlnf(key_name))//
     *         '/vint/scalar/'//nsort_clen//'/ / /gax/0 ; finish'
               call dotaskx3d(cmdmessage, ier)
             endif

          endif

      endif

C######################################################################
C     Allocate work array for index pointers and check ikey
C
      call cmo_get_info(key_name,cmonam,ipikey,ilen,itype,ier)

C     this is an extra check, nsort should be correctly set
C     to nnodes or nelements by this point
      if ( (nsort.ne.ilen) .or. (ier.ne.0) ) then
           write(logmess,'(a,a5,i11,a,a)')
     *      " ERROR SORT: invalid length  ",
     *      nsort_clen(1:4), nsort,
     *      " for attribute: ", key_name
           call writloga('default',0,logmess,1,ier)
           goto 9999
      endif

      call mmgetblk('iwork',isubname,ipiwork,nsort,1,ier)
      if (ier.ne.0 .or. nsort.eq.0) then
          write(logmess,9030) nsort
 9030   format(" ERROR SORT: work array allocation length = ",i11)
          call writloga('default',0,logmess,1,ier)
          goto 9999
      else
        do i = 1, nsort
           iwork(i) = i
           ikey(i) = i
        enddo
      endif
C
C
C     Old version had to distinguish between real or integer arrays
C     but now the data vector to sort is always a real*8 work array.
C     No longer distinguish between real or integer when using the
C     hpsort routine.
C
      if(isort_type(1:4) .eq. 'bins')then
        if(itype_att .eq. 2)then
         call hpsortrmp(nsort, nkey, nkey, rwork, rsort_order, iwork)
         call index_bins_r(nsort,iwork,att_r,ikey,epsilon_user)
        else
         call hpsortip(nsort,att_i,rsort_order,ikey)
         call index_bins_i(nsort,iwork,att_i,ikey)
        endif
      elseif(isort_type(1:5) .eq. 'index')then
         call hpsortrmp(nsort, nkey, nkey, rwork, rsort_order, ikey)
      elseif(isort_type(1:4) .eq. 'rank')then
         call hpsortrmp(nsort, nkey, nkey, rwork, rsort_order, iwork)
         call index_rank(nsort,iwork,ikey)
      elseif(isort_type(1:10) .eq. 'line_graph') then
         call cmo_get_info('itet', cmonam, ipitet, ilen, itype, ier)
         if(ier.ne.0) call x3d_error(isubname,'get info itet')
         call cmo_get_info('itettyp', cmonam, ipitettyp, ilen, itype,
     *      ier)
         if(ier.ne.0) call x3d_error(isubname,'get info itettyp')
C
C        Loop through and make sure that itet consists solely of line
C        segments.
C
         do i = 1, ilen
            if (itettyp(i) .ne. ifelmlin) then
               write(logmess, *)
     *    ' ERROR SORT: line_graph elements must be of type line.'
               call writloga('default',0,logmess,0,ier)
               ier = 1
               goto 9999
            endif
         enddo

C    SORT BY ELEMENT
      if (lg_sort_type .eq. 'elements') then
C
C          Create new temporary attributes.
C          remove attributes to zero them out.
           ier = 0

           cmdmessage='cmo/DELATT/'//cmonam(1:icharlnf(cmonam))//
     *     '/cid; finish'
           call dotaskx3d(cmdmessage, ier)
           cmdmessage='cmo/addatt/'//cmonam(1:icharlnf(cmonam))//
     *     '/cid/VINT/scalar/nelements/linear/temporary; finish'
           call dotaskx3d(cmdmessage, ier)

           call cmo_get_info('cid', cmonam(1:icharlnf(cmonam)), ipcid,
     *        ilen, itype, ier)
           if(ier.ne.0) call x3d_error(isubname,'get info cid')

           cmdmessage = 'cmo/DELATT/' // cmonam(1:icharlnf(cmonam)) //
     *      '/ctype; finish'
           call dotaskx3d(cmdmessage, ier)
           cmdmessage='cmo/addatt/'//cmonam(1:icharlnf(cmonam)) //
     *      '/ctype/VINT/scalar/nelements/linear/temporary; finish'
           call dotaskx3d(cmdmessage, ier)

           call cmo_get_info('ctype', cmonam(1:icharlnf(cmonam)),
     *        ipcomptype, ilen, itype, ier)
           if(ier.ne.0) call x3d_error(isubname,'get info ctype')

           cmdmessage='cmo/DELATT/'//cmonam(1:icharlnf(cmonam)) //
     *      '/loopid; finish'
           call dotaskx3d(cmdmessage, ier)
           cmdmessage='cmo/addatt/'// cmonam(1:icharlnf(cmonam)) //
     *      '/loopid/VINT/scalar/nelements/linear/temporary; finish'
           call dotaskx3d(cmdmessage, ier)

           call cmo_get_info('loopid', cmonam(1:icharlnf(cmonam)),
     *        iploopid, ilen, itype, ier)
           if(ier.ne.0) call x3d_error(isubname,'get info loopid')

C
C   setup done, now let the C++ code take care of the rest!
C
           call line_graph_sort(itet, cid, comptype, loopid, ikey,
     &        nelem)

C   SORT BY NODE
C   note the last argument is the number of elements
        elseif (lg_sort_type .eq. 'nodes') then

          call line_graph_nsort(itet, ikey, nelem)

        endif
      endif
C
C
C######################################################################
C

        write(logmess,'(a,a)')
     *  " SORT: order key written to attribute: ",
     *  key_name(1:icharlnf(key_name))
        call writloga('default',0,logmess,1,ier)

 9999 call mmrelprt(isubname,ierror)

      return
      end
C
C######################################################################
      subroutine sort_old
     1     (imsgin,xmsgin,cmsgin,msgtyp,nwds,ier)
C
C
C     Macro routine to support old sort syntax
C
C    Old Syntax still supported
C
C    USAGE - sort/xyz/[INDEX|bins|rank]
C
C
      implicit none

      integer ier, nwds
      character*32 cmsgin(nwds)
      integer imsgin(nwds)
      integer msgtyp(nwds)
      real*8  xmsgin(nwds)

      integer icharlnf

      character*32 isort_type
      character*132 logmess
      character*132 cbuff

C######################################################################
C begin BEGIN OLD SORT

C    NWDS = 3
C    TOKEN 3 - Get the sort method to be used (bins,index, or rank)
C
      if((cmsgin(3)(1:icharlnf(cmsgin(3))) .eq. 'index') .or.
     1   (cmsgin(2)(1:icharlnf(cmsgin(3))) .eq. '-def-') .or.
     2   (nwds .eq. 1).or. (nwds .eq. 2))then
            isort_type = 'index'
      elseif(cmsgin(3)(1:icharlnf(cmsgin(3))) .eq. 'bins') then
            isort_type = 'bins'
      elseif(cmsgin(3)(1:icharlnf(cmsgin(3))) .eq. 'rank') then
            isort_type = 'rank'
      else
        write(logmess,9010) cmsgin(3)(1:icharlnf(cmsgin(3)))
 9010   format(" SORT ERROR: Invalid option: ",a)
        call writloga('default',0,logmess,0,ier)
        write(logmess,9015)
 9015   format
     1  ("Usage: sort/xyz/[index,bins,rank] ")
        call writloga('default',0,logmess,0,ier)
        goto 9999
      endif

      if(isort_type(1:5) .eq. 'index')then
         ier = 0
         cbuff = 'sort/-def-/index/ascending/i_index/xic;finish'
         call dotaskx3d(cbuff, ier)
         cbuff = 'sort/-def-/index/ascending/j_index/yic;finish'
         call dotaskx3d(cbuff, ier)
         cbuff = 'sort/-def-/index/ascending/k_index/zic;finish'
         call dotaskx3d(cbuff, ier)
      elseif(isort_type(1:4) .eq. 'bins')then
         ier = 0
         cbuff = 'sort/-def-/bins/ascending/i_index/xic;finish'
         call dotaskx3d(cbuff, ier)
         cbuff = 'sort/-def-/bins/ascending/j_index/yic;finish'
         call dotaskx3d(cbuff, ier)
         cbuff = 'sort/-def-/bins/ascending/k_index/zic;finish'
         call dotaskx3d(cbuff, ier)
      elseif(isort_type(1:4) .eq. 'rank')then
         ier = 0
         cbuff = 'sort/-def-/rank/ascending/i_index/xic;finish'
         call dotaskx3d(cbuff, ier)
         cbuff = 'sort/-def-/rank/ascending/j_index/yic;finish'
         call dotaskx3d(cbuff, ier)
         cbuff = 'sort/-def-/rank/ascending/k_index/zic;finish'
         call dotaskx3d(cbuff, ier)
      endif

 9999 continue
      return
      end
C
C###################################################################
C
      subroutine index_rank(n_value,indx,irank)
      implicit none
      integer n_value, i
      integer indx(n_value), irank(n_value)
      do i = 1, n_value
         irank(indx(i)) = i
      enddo
      return
      end
C###################################################################
C
      subroutine index_bins_r(n_value,indx,arrin,index_array,eps_tst)
      implicit none
      integer n_value
      real*8 arrin(n_value)
      real*8 eps, eps_tst, value_test
      integer indx(n_value), index_array(n_value)
      integer n, index_test
C
      index_test = 1
      value_test = arrin(indx(1))
      eps = abs(value_test*eps_tst)
      do n = 1, n_value
         if((arrin(indx(n)) .ge. value_test - eps) .and.
     1      (arrin(indx(n)) .le. value_test + eps)) then
               index_array(indx(n)) = index_test
         else
            index_test = index_test + 1
            index_array(indx(n)) = index_test
            value_test = arrin(indx(n))
            eps = abs(value_test*eps_tst)
         endif
      enddo
      return
      end
C##################################################################
C
      subroutine index_bins_i(n_value,indx,iarrin,index_array)
      implicit none
      integer n_value
      integer iarrin(n_value)
      integer ivalue_test
      integer indx(n_value), index_array(n_value)
      integer n, index_test
C
      index_test = 1
      ivalue_test = iarrin(indx(1))
      do n = 1, n_value
         if((iarrin(indx(n)) .ge. ivalue_test) .and.
     1      (iarrin(indx(n)) .le. ivalue_test)) then
               index_array(indx(n)) = index_test
         else
            index_test = index_test + 1
            index_array(indx(n)) = index_test
            ivalue_test = iarrin(indx(n))
         endif
      enddo
      return
      end
C#################################################################
C
      subroutine indexx_r(n,arrin,indx)
C
C     indexx routine taken from Numerical Recipes,
C     Press, Flannery, Teukolsky, Vetterling
C
      implicit none
      integer i, j, n, l, ir, indxt
      real*8 arrin
      integer indx
      real*8 q
      dimension arrin(n),indx(n)
c
      do 11 j=1,n
        indx(j)=j
11    continue
      l=n/2+1
      ir=n
10    continue
        if(l.gt.1)then
          l=l-1
          indxt=indx(l)
          q=arrin(indxt)
        else
          indxt=indx(ir)
          q=arrin(indxt)
          indx(ir)=indx(1)
          ir=ir-1
          if(ir.eq.1)then
            indx(1)=indxt
            return
          endif
        endif
        i=l
        j=l+l
20      if(j.le.ir)then
          if(j.lt.ir)then
            if(arrin(indx(j)).lt.arrin(indx(j+1)))j=j+1
          endif
          if(q.lt.arrin(indx(j)))then
            indx(i)=indx(j)
            i=j
            j=j+j
          else
            j=ir+1
          endif
        go to 20
        endif
        indx(i)=indxt
      go to 10
      end
c#################################################################
c
      subroutine indexx_i(n,iarrin,indx)
c
c     indexx routine taken from numerical recipes,
c     press, flannery, teukolsky, vetterling
c
      implicit none
      integer i, j, n, l, ir, indxt
      integer iarrin
      integer indx
      real*8 q
      dimension iarrin(n),indx(n)
c
      do 11 j=1,n
        indx(j)=j
11    continue
      l=n/2+1
      ir=n
10    continue
        if(l.gt.1)then
          l=l-1
          indxt=indx(l)
          q=iarrin(indxt)
        else
          indxt=indx(ir)
          q=iarrin(indxt)
          indx(ir)=indx(1)
          ir=ir-1
          if(ir.eq.1)then
            indx(1)=indxt
            return
          endif
        endif
        i=l
        j=l+l
20      if(j.le.ir)then
          if(j.lt.ir)then
            if(iarrin(indx(j)).lt.iarrin(indx(j+1)))j=j+1
          endif
          if(q.lt.iarrin(indx(j)))then
            indx(i)=indx(j)
            i=j
            j=j+j
          else
            j=ir+1
          endif
        go to 20
        endif
        indx(i)=indxt
      go to 10
      end


*> \brief \b CTREVC
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CTREVC + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE CTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
*                          LDVR, MM, M, WORK, RWORK, INFO )
*
*       .. Scalar Arguments ..
*       CHARACTER          HOWMNY, SIDE
*       INTEGER            INFO, LDT, LDVL, LDVR, M, MM, N
*       ..
*       .. Array Arguments ..
*       LOGICAL            SELECT( * )
*       REAL               RWORK( * )
*       COMPLEX            T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ),
*      $                   WORK( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> CTREVC computes some or all of the right and/or left eigenvectors of
*> a complex upper triangular matrix T.
*> Matrices of this type are produced by the Schur factorization of
*> a complex general matrix:  A = Q*T*Q**H, as computed by CHSEQR.
*>
*> The right eigenvector x and the left eigenvector y of T corresponding
*> to an eigenvalue w are defined by:
*>
*>              T*x = w*x,     (y**H)*T = w*(y**H)
*>
*> where y**H denotes the conjugate transpose of the vector y.
*> The eigenvalues are not input to this routine, but are read directly
*> from the diagonal of T.
*>
*> This routine returns the matrices X and/or Y of right and left
*> eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an
*> input matrix.  If Q is the unitary factor that reduces a matrix A to
*> Schur form T, then Q*X and Q*Y are the matrices of right and left
*> eigenvectors of A.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] SIDE
*> \verbatim
*>          SIDE is CHARACTER*1
*>          = 'R':  compute right eigenvectors only;
*>          = 'L':  compute left eigenvectors only;
*>          = 'B':  compute both right and left eigenvectors.
*> \endverbatim
*>
*> \param[in] HOWMNY
*> \verbatim
*>          HOWMNY is CHARACTER*1
*>          = 'A':  compute all right and/or left eigenvectors;
*>          = 'B':  compute all right and/or left eigenvectors,
*>                  backtransformed using the matrices supplied in
*>                  VR and/or VL;
*>          = 'S':  compute selected right and/or left eigenvectors,
*>                  as indicated by the logical array SELECT.
*> \endverbatim
*>
*> \param[in] SELECT
*> \verbatim
*>          SELECT is LOGICAL array, dimension (N)
*>          If HOWMNY = 'S', SELECT specifies the eigenvectors to be
*>          computed.
*>          The eigenvector corresponding to the j-th eigenvalue is
*>          computed if SELECT(j) = .TRUE..
*>          Not referenced if HOWMNY = 'A' or 'B'.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrix T. N >= 0.
*> \endverbatim
*>
*> \param[in,out] T
*> \verbatim
*>          T is COMPLEX array, dimension (LDT,N)
*>          The upper triangular matrix T.  T is modified, but restored
*>          on exit.
*> \endverbatim
*>
*> \param[in] LDT
*> \verbatim
*>          LDT is INTEGER
*>          The leading dimension of the array T. LDT >= max(1,N).
*> \endverbatim
*>
*> \param[in,out] VL
*> \verbatim
*>          VL is COMPLEX array, dimension (LDVL,MM)
*>          On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
*>          contain an N-by-N matrix Q (usually the unitary matrix Q of
*>          Schur vectors returned by CHSEQR).
*>          On exit, if SIDE = 'L' or 'B', VL contains:
*>          if HOWMNY = 'A', the matrix Y of left eigenvectors of T;
*>          if HOWMNY = 'B', the matrix Q*Y;
*>          if HOWMNY = 'S', the left eigenvectors of T specified by
*>                           SELECT, stored consecutively in the columns
*>                           of VL, in the same order as their
*>                           eigenvalues.
*>          Not referenced if SIDE = 'R'.
*> \endverbatim
*>
*> \param[in] LDVL
*> \verbatim
*>          LDVL is INTEGER
*>          The leading dimension of the array VL.  LDVL >= 1, and if
*>          SIDE = 'L' or 'B', LDVL >= N.
*> \endverbatim
*>
*> \param[in,out] VR
*> \verbatim
*>          VR is COMPLEX array, dimension (LDVR,MM)
*>          On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
*>          contain an N-by-N matrix Q (usually the unitary matrix Q of
*>          Schur vectors returned by CHSEQR).
*>          On exit, if SIDE = 'R' or 'B', VR contains:
*>          if HOWMNY = 'A', the matrix X of right eigenvectors of T;
*>          if HOWMNY = 'B', the matrix Q*X;
*>          if HOWMNY = 'S', the right eigenvectors of T specified by
*>                           SELECT, stored consecutively in the columns
*>                           of VR, in the same order as their
*>                           eigenvalues.
*>          Not referenced if SIDE = 'L'.
*> \endverbatim
*>
*> \param[in] LDVR
*> \verbatim
*>          LDVR is INTEGER
*>          The leading dimension of the array VR.  LDVR >= 1, and if
*>          SIDE = 'R' or 'B'; LDVR >= N.
*> \endverbatim
*>
*> \param[in] MM
*> \verbatim
*>          MM is INTEGER
*>          The number of columns in the arrays VL and/or VR. MM >= M.
*> \endverbatim
*>
*> \param[out] M
*> \verbatim
*>          M is INTEGER
*>          The number of columns in the arrays VL and/or VR actually
*>          used to store the eigenvectors.  If HOWMNY = 'A' or 'B', M
*>          is set to N.  Each selected eigenvector occupies one
*>          column.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is COMPLEX array, dimension (2*N)
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*>          RWORK is REAL array, dimension (N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit
*>          < 0:  if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complexOTHERcomputational
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*>
*>  The algorithm used in this program is basically backward (forward)
*>  substitution, with scaling to make the the code robust against
*>  possible overflow.
*>
*>  Each eigenvector is normalized so that the element of largest
*>  magnitude has magnitude 1; here the magnitude of a complex number
*>  (x,y) is taken to be |x| + |y|.
*> \endverbatim
*>
*  =====================================================================
      SUBROUTINE CTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
     $                   LDVR, MM, M, WORK, RWORK, INFO )
*
*  -- LAPACK computational routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      CHARACTER          HOWMNY, SIDE
      INTEGER            INFO, LDT, LDVL, LDVR, M, MM, N
*     ..
*     .. Array Arguments ..
      LOGICAL            SELECT( * )
      REAL               RWORK( * )
      COMPLEX            T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ),
     $                   WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
      COMPLEX            CMZERO, CMONE
      PARAMETER          ( CMZERO = ( 0.0E+0, 0.0E+0 ),
     $                   CMONE = ( 1.0E+0, 0.0E+0 ) )
*     ..
*     .. Local Scalars ..
      LOGICAL            ALLV, BOTHV, LEFTV, OVER, RIGHTV, SOMEV
      INTEGER            I, II, IS, J, K, KI
      REAL               OVFL, REMAX, SCALE, SMIN, SMLNUM, ULP, UNFL
      COMPLEX            CDUM
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ICAMAX
      REAL               SCASUM, SLAMCH
      EXTERNAL           LSAME, ICAMAX, SCASUM, SLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           CCOPY, CGEMV, CLATRS, CSSCAL, SLABAD, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, AIMAG, CMPLX, CONJG, MAX, REAL
*     ..
*     .. Statement Functions ..
      REAL               CABS1
*     ..
*     .. Statement Function definitions ..
      CABS1( CDUM ) = ABS( REAL( CDUM ) ) + ABS( AIMAG( CDUM ) )
*     ..
*     .. Executable Statements ..
*
*     Decode and test the input parameters
*
      BOTHV = LSAME( SIDE, 'B' )
      RIGHTV = LSAME( SIDE, 'R' ) .OR. BOTHV
      LEFTV = LSAME( SIDE, 'L' ) .OR. BOTHV
*
      ALLV = LSAME( HOWMNY, 'A' )
      OVER = LSAME( HOWMNY, 'B' )
      SOMEV = LSAME( HOWMNY, 'S' )
*
*     Set M to the number of columns required to store the selected
*     eigenvectors.
*
      IF( SOMEV ) THEN
         M = 0
         DO 10 J = 1, N
            IF( SELECT( J ) )
     $         M = M + 1
   10    CONTINUE
      ELSE
         M = N
      END IF
*
      INFO = 0
      IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN
         INFO = -1
      ELSE IF( .NOT.ALLV .AND. .NOT.OVER .AND. .NOT.SOMEV ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN
         INFO = -8
      ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN
         INFO = -10
      ELSE IF( MM.LT.M ) THEN
         INFO = -11
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'CTREVC', -INFO )
         RETURN
      END IF
*
*     Quick return if possible.
*
      IF( N.EQ.0 )
     $   RETURN
*
*     Set the constants to control overflow.
*
      UNFL = SLAMCH( 'Safe minimum' )
      OVFL = ONE / UNFL
      CALL SLABAD( UNFL, OVFL )
      ULP = SLAMCH( 'Precision' )
      SMLNUM = UNFL*( N / ULP )
*
*     Store the diagonal elements of T in working array WORK.
*
      DO 20 I = 1, N
         WORK( I+N ) = T( I, I )
   20 CONTINUE
*
*     Compute 1-norm of each column of strictly upper triangular
*     part of T to control overflow in triangular solver.
*
      RWORK( 1 ) = ZERO
      DO 30 J = 2, N
         RWORK( J ) = SCASUM( J-1, T( 1, J ), 1 )
   30 CONTINUE
*
      IF( RIGHTV ) THEN
*
*        Compute right eigenvectors.
*
         IS = M
         DO 80 KI = N, 1, -1
*
            IF( SOMEV ) THEN
               IF( .NOT.SELECT( KI ) )
     $            GO TO 80
            END IF
            SMIN = MAX( ULP*( CABS1( T( KI, KI ) ) ), SMLNUM )
*
            WORK( 1 ) = CMONE
*
*           Form right-hand side.
*
            DO 40 K = 1, KI - 1
               WORK( K ) = -T( K, KI )
   40       CONTINUE
*
*           Solve the triangular system:
*              (T(1:KI-1,1:KI-1) - T(KI,KI))*X = SCALE*WORK.
*
            DO 50 K = 1, KI - 1
               T( K, K ) = T( K, K ) - T( KI, KI )
               IF( CABS1( T( K, K ) ).LT.SMIN )
     $            T( K, K ) = SMIN
   50       CONTINUE
*
            IF( KI.GT.1 ) THEN
               CALL CLATRS( 'Upper', 'No transpose', 'Non-unit', 'Y',
     $                      KI-1, T, LDT, WORK( 1 ), SCALE, RWORK,
     $                      INFO )
               WORK( KI ) = SCALE
            END IF
*
*           Copy the vector x or Q*x to VR and normalize.
*
            IF( .NOT.OVER ) THEN
               CALL CCOPY( KI, WORK( 1 ), 1, VR( 1, IS ), 1 )
*
               II = ICAMAX( KI, VR( 1, IS ), 1 )
               REMAX = ONE / CABS1( VR( II, IS ) )
               CALL CSSCAL( KI, REMAX, VR( 1, IS ), 1 )
*
               DO 60 K = KI + 1, N
                  VR( K, IS ) = CMZERO
   60          CONTINUE
            ELSE
               IF( KI.GT.1 )
     $            CALL CGEMV( 'N', N, KI-1, CMONE, VR, LDVR, WORK( 1 ),
     $                        1, CMPLX( SCALE ), VR( 1, KI ), 1 )
*
               II = ICAMAX( N, VR( 1, KI ), 1 )
               REMAX = ONE / CABS1( VR( II, KI ) )
               CALL CSSCAL( N, REMAX, VR( 1, KI ), 1 )
            END IF
*
*           Set back the original diagonal elements of T.
*
            DO 70 K = 1, KI - 1
               T( K, K ) = WORK( K+N )
   70       CONTINUE
*
            IS = IS - 1
   80    CONTINUE
      END IF
*
      IF( LEFTV ) THEN
*
*        Compute left eigenvectors.
*
         IS = 1
         DO 130 KI = 1, N
*
            IF( SOMEV ) THEN
               IF( .NOT.SELECT( KI ) )
     $            GO TO 130
            END IF
            SMIN = MAX( ULP*( CABS1( T( KI, KI ) ) ), SMLNUM )
*
            WORK( N ) = CMONE
*
*           Form right-hand side.
*
            DO 90 K = KI + 1, N
               WORK( K ) = -CONJG( T( KI, K ) )
   90       CONTINUE
*
*           Solve the triangular system:
*              (T(KI+1:N,KI+1:N) - T(KI,KI))**H*X = SCALE*WORK.
*
            DO 100 K = KI + 1, N
               T( K, K ) = T( K, K ) - T( KI, KI )
               IF( CABS1( T( K, K ) ).LT.SMIN )
     $            T( K, K ) = SMIN
  100       CONTINUE
*
            IF( KI.LT.N ) THEN
               CALL CLATRS( 'Upper', 'Conjugate transpose', 'Non-unit',
     $                      'Y', N-KI, T( KI+1, KI+1 ), LDT,
     $                      WORK( KI+1 ), SCALE, RWORK, INFO )
               WORK( KI ) = SCALE
            END IF
*
*           Copy the vector x or Q*x to VL and normalize.
*
            IF( .NOT.OVER ) THEN
               CALL CCOPY( N-KI+1, WORK( KI ), 1, VL( KI, IS ), 1 )
*
               II = ICAMAX( N-KI+1, VL( KI, IS ), 1 ) + KI - 1
               REMAX = ONE / CABS1( VL( II, IS ) )
               CALL CSSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 )
*
               DO 110 K = 1, KI - 1
                  VL( K, IS ) = CMZERO
  110          CONTINUE
            ELSE
               IF( KI.LT.N )
     $            CALL CGEMV( 'N', N, N-KI, CMONE, VL( 1, KI+1 ), LDVL,
     $                        WORK( KI+1 ), 1, CMPLX( SCALE ),
     $                        VL( 1, KI ), 1 )
*
               II = ICAMAX( N, VL( 1, KI ), 1 )
               REMAX = ONE / CABS1( VL( II, KI ) )
               CALL CSSCAL( N, REMAX, VL( 1, KI ), 1 )
            END IF
*
*           Set back the original diagonal elements of T.
*
            DO 120 K = KI + 1, N
               T( K, K ) = WORK( K+N )
  120       CONTINUE
*
            IS = IS + 1
  130    CONTINUE
      END IF
*
      RETURN
*
*     End of CTREVC
*
      END


function vrefmod(z,ips)

common/refmod/nref,zref(600),vref(600,2)

vrefmod=-900.

if(nref.eq.0) then
    write(*,*)' the reference model is not defined!'
    pause
end if

if(z.le.zref(1))then
    vrefmod=vref(1,ips)
else if(z.ge.zref(nref)) then
    vrefmod=vref(nref,ips)
else
    do i=1,nref-1
        z1=zref(i)
        z2=zref(i+1)
        if((z-z1)*(z-z2).gt.0.)cycle
        v1=vref(i,ips)
        v2=vref(i+1,ips)
        vrefmod=v1+((v2-v1)/(z2-z1))*(z-z1)
        exit
    end do
end if

return
end


program test_sto_be
use types, only: dp
use sto, only: stoints2, get_basis2
use utils, only: assert
use radialscf, only: doscf, kinetic_energy
use hfprint, only: printall, printlam
implicit none

integer, allocatable :: nl(:, :), nbfl(:)
real(dp), allocatable :: zl(:, :), focc(:, :)

real(dp), allocatable :: S(:, :, :), T(:, :, :), V(:, :, :), slater(:, :)
integer :: n, Z, m, Nscf, Lmax, ndof
real(dp) :: alpha, Etot, tolE, tolP, Ekin
real(dp), allocatable :: H(:, :, :), P_(:, :, :), C(:, :, :), lam(:, :)

allocate(nbfl(0:2), nl(12, 0:2), zl(12, 0:2), focc(2, 0:2))
!allocate(nbfl(0:3), nl(12, 0:3), zl(12, 0:3), focc(2, 0:3))
nbfl = 0
focc = 0
focc(:2, 0) = [2, 2]
nbfl(0) = 12
nl(:12, 0) = [1, 1, 1, 1, 2, 2, 2, 2, 3, 3, 3, 3]
zl(:12, 0) = [0.1_dp, 1.5_dp, 3.4703_dp, 6.3681_dp, &
    0.7516_dp, 0.9084_dp, 5.80765_dp, 8.53828_dp, &
    0.08_dp, 16.1268_dp, 20.2055_dp, 31.4944_dp]
nbfl(1) = 12
nl(:12, 1) = [2, 2, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4]
zl(:12, 1) = [0.20135_dp, 0.95703_dp, 1.943_dp, 2.6986_dp, &
    0.09_dp, 1.46565_dp, 3.35114_dp, 5.1389_dp, &
    0.15969_dp, 0.75902_dp, 8.80274_dp, 11.521_dp]
nbfl(2) = 12
nl(:12, 2) = [3, 3, 3, 3, 4, 4, 4, 4, 5, 5, 5, 5]
zl(:12, 2) = [0.074284_dp, 0.373267_dp, 0.83752_dp, 1.3652_dp, &
    1.8273_dp, 2.30093_dp, 0.0805239_dp, 0.512334_dp, &
    3.22431_dp, 4.47682_dp, 6.2468_dp, 8.68472_dp]
!nbfl(3) = 12
!nl(:12, 3) = [4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 5]
!zl(:12, 3) = [14.64884_dp, 1.17503_dp, 17.49577_dp, 4.91401_dp, 9.22804_dp, &
!    11.94673_dp, 2.73331_dp, 3.15699_dp, 5.23396_dp, 0.71385_dp, 20.02434_dp, &
!    0.84142_dp]
!zl = zl * 0.4_dp

Z = 4
tolE = 1e-10_dp
tolP = 1e-4_dp
alpha = 0.6_dp
Nscf = 100

n = maxval(nbfl)
Lmax = ubound(nbfl, 1)
ndof = sum(nbfl)
print *, "total  DOFs =", ndof
allocate(H(n, n, 0:Lmax), S(n, n, 0:Lmax), T(n, n, 0:Lmax), V(n, n, 0:Lmax))
m = ndof*(ndof+1)/2
allocate(slater(m*(m+1)/2, 0:2*Lmax))
call stoints2(Z, nbfl, nl, zl, S, T, V, slater)

allocate(P_(n, n, 0:Lmax), C(n, n, 0:Lmax), lam(n, 0:Lmax))

H = T + V

print *, "SCF cycle:"
call doscf(nbfl, H, slater, S, focc, Nscf, tolE, tolP, alpha, C, P_, lam, Etot)
Ekin = kinetic_energy(nbfl, P_, T)
call printall(nbfl, nl, zl, lam, C, Ekin, Etot)
call printlam(nbfl, lam, Ekin, Etot)

call assert(abs(Etot - (-14.57279688_dp)) < 1e-8_dp)
call assert(all(abs(lam(:2, 0) - [-4.733142_dp, -0.309212_dp]) < 1e-6_dp))
call assert(all(abs(lam(10:, 1) - [18.840697_dp, 47.564325_dp, &
    146.358091_dp]) < 1e-6_dp))
call assert(all(abs(lam(10:, 2) - [8.393357_dp, 16.676739_dp, &
    31.940327_dp]) < 1e-6_dp))

end program


c$Header: /data/petsun4/data1/src_solaris/nonlin/RCS/imgval0.f,v 1.1 2004/10/14 23:59:49 rsachs Exp $
c$Log: imgval0.f,v $
c Revision 1.1  2004/10/14  23:59:49  rsachs
c Initial revision
c
      subroutine imgval0(imgt,nx,ny,nz,voxdim,x,val)
c     returns in val the interpolated value of imgt at locus x.
c     val = 0 if imgt is undefined at x.

      real*4 imgt(0:nx-1,0:ny-1,0:nz-1),voxdim(3),x(3),val
      logical*4 ldefined,lok
      real*4 wx(3),xf(3)
      integer*4 ix(3),mx(3)

      mx(1)=nx
      mx(2)=ny
      mx(3)=nz

      ldefined=.true.
      do 1 k=1,3
c1      center(k)=sign(center(k),mmppix(k))
c1      xf(k)=(center(k)+x(k))/mmppix(k)
      xf(k)=x(k)/voxdim(k)            ! the fractional index
      ix(k)=nint(xf(k)-0.5)
      wx(k)=xf(k)-float(ix(k))
      if((ix(k).eq.-1.and.wx(k).gt.0.999).or.mx(k).eq.1)then
        ix(k)=0       !  ix(k)=1
        wx(k)=0.
      endif
c1    if(mx(k).gt.1.and.ix(k).eq.mx(k).and.wx(k).lt.0.001)then
      if(mx(k).gt.1.and.ix(k).eq.(mx(k)-1).and.wx(k).lt.0.001)then
        ix(k)=mx(k)-2         !    ix(k)=mx(k)-1
        wx(k)=1.
      endif
c1    1 ldefined=ldefined.and.((mx(k).eq.1).or.(ix(k).gt.0).and.(ix(k).lt.mx(k)))

    1  ldefined=ldefined.and.((mx(k).eq.1).or.(ix(k).ge.0).and.(ix(k).lt.mx(k)-1))
      if(.not.ldefined)then
        val=0.
        return
      endif

      lok=(imgt(ix(1)+0,ix(2)+0,ix(3)+0).ge.0.0.or.imgt(ix(1)+0,ix(2)+0,ix(3)+0).le.0.0).and.
     &    (imgt(ix(1)+1,ix(2)+0,ix(3)+0).ge.0.0.or.imgt(ix(1)+1,ix(2)+0,ix(3)+0).le.0.0).and.
     &    (imgt(ix(1)+0,ix(2)+1,ix(3)+0).ge.0.0.or.imgt(ix(1)+0,ix(2)+1,ix(3)+0).le.0.0).and.
     &    (imgt(ix(1)+1,ix(2)+1,ix(3)+0).ge.0.0.or.imgt(ix(1)+1,ix(2)+1,ix(3)+0).le.0.0).and.
     &    (imgt(ix(1)+0,ix(2)+0,ix(3)+1).ge.0.0.or.imgt(ix(1)+0,ix(2)+0,ix(3)+1).le.0.0).and.
     &    (imgt(ix(1)+1,ix(2)+0,ix(3)+1).ge.0.0.or.imgt(ix(1)+1,ix(2)+0,ix(3)+1).le.0.0).and.
     &    (imgt(ix(1)+0,ix(2)+1,ix(3)+1).ge.0.0.or.imgt(ix(1)+0,ix(2)+1,ix(3)+1).le.0.0).and.
     &    (imgt(ix(1)+1,ix(2)+1,ix(3)+1).ge.0.0.or.imgt(ix(1)+1,ix(2)+1,ix(3)+1).le.0.0)
      if(.not.lok)then
        val=0.
        return
      endif

      val=
     & +(1.-wx(3))*((1.-wx(2))*(
     &               (1.-wx(1))*imgt(ix(1)+0,ix(2)+0,ix(3)+0)
     &                  +wx(1) *imgt(ix(1)+1,ix(2)+0,ix(3)+0))
     &               +wx(2)*(
     &               (1.-wx(1))*imgt(ix(1)+0,ix(2)+1,ix(3)+0)
     &                  +wx(1) *imgt(ix(1)+1,ix(2)+1,ix(3)+0)))
       if(mx(3).gt.1) val=val
     &      +wx(3)*((1.-wx(2))*(
     &               (1.-wx(1))*imgt(ix(1)+0,ix(2)+0,ix(3)+1)
     &                  +wx(1) *imgt(ix(1)+1,ix(2)+0,ix(3)+1))
     &               +wx(2)*(
     &               (1.-wx(1))*imgt(ix(1)+0,ix(2)+1,ix(3)+1)
     &                  +wx(1) *imgt(ix(1)+1,ix(2)+1,ix(3)+1)))
      return
      end


! Copyright (c) 2017-2018 Etienne Descamps
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification,
! are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
!    this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
!    this list of conditions and the following disclaimer in the documentation and/or
!    other materials provided with the distribution.
!
! 3. Neither the name of the copyright holder nor the names of its contributors may be
!    used to endorse or promote products derived from this software without specific prior
!    written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
! ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
! WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
! IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
! INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
! (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
! LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
! THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
! EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Program test_funbasis
  Use ieee_arithmetic
  Use iso_c_binding
  Use mlf_intf
  Use mlf_rsc_array
  Use mlf_utils
  Use mlf_matrix
  Use mlf_fun_intf
  Use mlf_funbasis
  Use mlf_models
  Use test_functions
  IMPLICIT NONE

  integer :: infoX
  infoX = mlf_init()
  infoX = RunTest()

  infoX = mlf_quit()

Contains
  integer function RunTest() result(info)
    type(mlf_basis_test) :: f_test
    integer, parameter :: nR = 32, nG = 16
    real(c_double) :: YB(2,nG,nR), a0, a1, b0, b1, YT(2,2), WB(nG,nR), W1, W0, X, Y
    integer :: i, j
    real(c_double), parameter :: Ri(nR) = [(5d-2*exp(i/real(nR-1)*log(2d1)), i=0,(NR-1))]
    real(c_double), parameter :: Gi(nG) = [(exp(-i/real(nG-1)), i=0,(nG-1))]

    info = mlf_init()

    a0 = -1.5; a1 = 2.0
    b0 = 0.1; b1 = 10.0
    forall(i=1:nG) YB(2,i,:) = Ri
    forall(i=1:nR) YB(1,:,i) = Gi
    do i=1,nG
      X = (i-1d0)/real(nG-1)
      W0 = 1d0*(1d0-X)+0.01*X
      W1 = 0.2d0*(1d0-X)+ 1d0*X
      do j=1,nR
        Y = (j-1d0)/real(nR-1)
        WB(i,j) = W0*(1d0-Y)+W1*Y
      End do
    End do
    ! print *, YB
    YT(:,1) = YB(:,1,2)
    YT(:,2) = YB(:,nG-5,nR-2)
    f_test%evalT => FExpInv
    info = testfb(f_test, reshape(YB, [2,nR*nG]), YT, reshape(sqrt(WB), [nR*nG]))

  End function RunTest

  integer function testfb(f_test, Ybasis, Ytests, WP) result(info)
    class(mlf_basis_test), intent(inout) :: f_test
    type(mlf_algo_funbasis) :: fb
    real(c_double), intent(in) :: Ybasis(:,:), Ytests(:,:), WP(:)
    real(c_double) :: infty
    real(c_double), parameter :: ferr = 1d-8, alpha = 1d0
    real(c_double), allocatable :: W(:,:), AError(:,:), U1(:,:), U2(:,:)
    integer, parameter :: nparam = 8, nx=16, nxp=65536
    integer :: nt, i, j
    real(c_double) :: X0(nx) =  [(-1d0/alpha*log(1d0-i/real(nx)),i=0,(nx-1))]
    infty = ieee_value(infty, ieee_positive_inf)
    info = fb%initF(f_test, alpha, 0d0, infty, Ybasis, nparam, nX = nxp, WP = WP)
    if(info /= 0) then
      print *, "fb%init error ", info
      RETURN
    endif
    nt = size(Ytests,1)
    allocate(W(nparam,nt), Aerror(nt,2), U1(nx,nt), U2(nx,nt))
    print *,ferr
    info = mlf_getProj(fb%model, Ytests, W, Aerror)
    print *, Aerror(:,1)
    print *, Aerror(:,2)
    call FExpInv(X0, Ytests, U1(:,:))
    do i=1,nt
      do j=1,nx
        U2(j,i) = (mlf_getValue(fb%model, W(:,i), X0(j))-U1(j,i))*exp(-alpha*X0(j))
      end do
    end do
    print *, U2(:,:)
  end function testfb
End Program test_funbasis


!===============================
! DEFINING variables
!  except for prm_var
!===============================

module prm_fwd

	use prm_matrix

	!== ESTMPR ==
	real(8) x(kfg,4,5), er(kfg,4,5)
	!== FORWDI ==
	character(len=24), save :: fwdjac(5), hd_jac(5)
	!== FWPRM ==
	integer, save :: isf, ihf, ivf
	real(8), save :: zf(kfo,kmp), yf(kfo), stf(2,kif)
	!== JUSTIN ==
	integer :: ndgs(5), js0(5), jt0(5), jd2(5), just(4,5)
	!== OCOD ==
	real(8), save :: alat0, alng0
	integer, save :: icord
	real(8), save :: xtr(ms), ytr(ms,mt), ztr(ms,mt), da2

	real(8), save :: e_gsi, e_jcg, herr, setalpha

end module prm_fwd


!-----------------------------------------------------------------------------------
! Name: rpt3(ixyz,icoor,imp,maxm,meqn,mwaves,maux,mbc,mx,ql,qr,aux1,aux2,aux3,asdq,
!            bmasdq,bpasdq)
!
! Description: Roe f-wave solver in the transverse direction for the
!              3D Euler equations in general geometries
!
! Inputs:
!         ixyz <INTEGER>   : direction to take slice x-direction if ixyz=1
!                                                    y-direction if ixyz=2.
!                                                    z-direction if ixyz=3.
!         icoor <INTEGER>  : direction in which the transverse solve should be
!                            performed.  icoor=2 (split in y-like direction)
!                                        icoor=3 (split in z-like direction)
!                            ixyz=1, icoor=2 means asdq=A^*\Dq, split in y into:
!                                            bmasdq = B^-A^*\Dq,
!                                            bpasdq = B^+A^*\Dq.
!                            ixyz=2, icoor=2 means asdq=B^*\Dq, split in z into:
!                                            bmasdq = C^-B^*\Dq,
!                                            bpasdq = C^+B^*\Dq.
!         imp <INTEGER>    : index for aux arrays
!         maxm <INTEGER>   : max number of grid cells (less the ghost cells)
!         meqn <INTEGER>   : number of equations in the system
!         mwaves <INTEGER> : nuber of waves in the system
!         maux <INTEGER>   : number of auxilary equations
!         mbc <INTEGER>    : number of ghost cells on either end
!         mx <INTEGER>     : number of elements
!         ql <REAL>        : state vector at left edge of each cell
!                            Note the i'th Riemann problem has left state qr(:,i-1)
!         qr <REAL>        : state vector at right edge of each cell
!                            Note the i'th Riemann problem has right state ql(:,i)
!         aux1 <REAL>      :
!         aux2 <REAL>      :
!         aux3 <REAL>      :
!         asdq <REAL>      : array of flux differences (A*\Dq).  asdq(:,i) is the
!                            flux difference propagating away from the interface
!                            between cells i-1 and i.  Note: asdq represents
!                            B*\Dq if ixyz=2 or C*\Dq if ixyz=3.
!
! Outputs:
!          bmasdq <REAL>   : left-going flux differences
!          bpasdq <REAL>   : right-going flux differences
!
! Adapted from rpt3_euler.f90 in $CLAWHOME/riemann/src
!-----------------------------------------------------------------------------------
SUBROUTINE rpt3(ixyz,icoor,imp,maxm,meqn,mwaves,maux,mbc,mx,ql,qr,aux1,aux2,aux3,&
     asdq,bmasdq,bpasdq)

  IMPLICIT NONE

  ! Input
  INTEGER, INTENT(IN) :: ixyz,icoor,imp,maxm,meqn,mwaves,maux,mbc,mx
  REAL(kind=8), DIMENSION(meqn,1-mbc:maxm+mbc), INTENT(IN) :: ql,qr,asdq
  REAL(kind=8), DIMENSION(maux,1-mbc:maxm+mbc,3), INTENT(IN) :: aux1,aux2,aux3

  ! Output
  REAL(kind=8), DIMENSION(meqn,1-mbc:maxm+mbc), INTENT(INOUT) :: bmasdq,bpasdq

  ! Local Storage
  REAL(kind=8), DIMENSION(meqn) :: beta
  REAL(kind=8), DIMENSION(-1:maxm+mbc) :: u2v2w2,u,v,w,enth,a,g1a2,euv
  REAL(kind=8) :: gamma1,asqrd,pl,pr,rhsq2,rhsqrtl,rhsqrtr,nx,ny,nz,vn,&
       areaRatioMinus,areaRatioPlus
  REAL(kind=8), DIMENSION(meqn,mwaves) :: waveb
  REAL(kind=8), DIMENSION(mwaves) :: sb
  INTEGER :: i,j,mu=2,mv=3,mw=4,mws,nu=1,nv=2,nw=3,iratio=4
  CHARACTER(20) :: nonsingularNormal

  ! Common block storage for ideal gas constant
  REAL(kind=8) :: gamma
  COMMON /cparam/ gamma

  ! Set (gamma-1)
  gamma1 = gamma - 1.d0

  ! Make sure the number of waves is 3 for the 3D Euler equations
  IF (mwaves /= 3) THEN
     WRITE(6,*) '*** Should have mwaves=3 for this Riemann solver'
     STOP
  ENDIF

  ! Set mu to point to  the component of the system that corresponds to momentum in
  !  the direction of this slice, mv and mw to the orthogonal momentums.
  !
  !  ixyz indicates the direction of the original Riemann solve,
  !  called the x-like direction in the table below:
  !
  !          x-like direction   y-like direction   z-like direction
  !  ixyz=1:        x                  y                  z
  !  ixyz=2:        y                  z                  x
  !  ixyz=3:        z                  x                  y
  IF(ixyz == 1)THEN ! x-like direction
     mu = 2
     mv = 3
     mw = 4
     ! Choose the coordinate direction to solve the Riemann problem
     !   Permute nu,nv,nw for the original ixyz incident direction (x-like)
     IF(icoor == 2)THEN ! y-like direction
        nu = 5
        nv = 6
        nw = 7
        iratio = 8
     ELSEIF(icoor == 3)THEN ! z-like direction
        nu = 9
        nv = 10
        nw = 11
        iratio = 12
     END IF
  ELSEIF(ixyz == 2)THEN ! y-like direction
     mu = 3
     mv = 4
     mw = 2
     ! Choose the coordinate direction to solve the Riemann problem
     !   Permute nu,nv,nw for the original ixyz incident direction (y-like)
     IF(icoor == 2)THEN ! z-like direction
        nu = 10
        nv = 11
        nw = 9
        iratio = 12
     ELSEIF(icoor == 3)THEN ! x-like direction
        nu = 2
        nv = 3
        nw = 1
        iratio = 4
     END IF
  ELSEIF(ixyz == 3)THEN ! z-like direction
     mu = 4
     mv = 2
     mw = 3
     ! Choose the coordinate direction to solve the Riemann problem
     !   Permute nu,nv,nw for the original ixyz incident direction (z-like)
     IF(icoor == 2)THEN ! x-like direction
        nu = 3
        nv = 1
        nw = 2
        iratio = 4
     ELSEIF(icoor == 3)THEN ! y-like direction
        nu = 7
        nv = 5
        nw = 6
        iratio = 8
     END IF
  ENDIF

  ! Note that notation for u,v, and w reflects assumption that the
  !   Riemann problems are in the x-direction with u in the normal
  !   direction and v and w in the orthogonal directions, but with the
  !   above definitions of mu, mv, and mw the routine also works with
  !   ixyz=2 and ixyz = 3
  !   and returns, for example, f0 as the Godunov flux g0 for the
  !   Riemann problems u_t + g(u)_y = 0 in the y-direction.
  !
  ! Compute the Roe-averaged variables needed in the Roe solver.

  ! Loop over grid cell interfaces
  DO i = 2-mbc, mx+mbc
     IF (qr(1,i-1) <= 0.d0 .OR. ql(1,i) <= 0.d0) THEN
        WRITE(*,*) i, mu, mv, mw
        WRITE(*,'(5e12.4)') (qr(j,i-1),j=1,5)
        WRITE(*,'(5e12.4)') (ql(j,i),j=1,5)
        IF (ixyz == 1) WRITE(6,*) '*** (rpt3) rho <= 0 in x-sweep at ',i
        IF (ixyz == 2) WRITE(6,*) '*** (rpt3) rho <= 0 in y-sweep at ',i
        IF (ixyz == 3) WRITE(6,*) '*** (rpt3) rho <= 0 in z-sweep at ',i
        WRITE(6,*) 'stopped with rho <= 0...'
        STOP
     ENDIF
     rhsqrtl = SQRT(qr(1,i-1))
     rhsqrtr = SQRT(ql(1,i))
     pl = gamma1*(qr(5,i-1) - 0.5d0*(qr(mu,i-1)**2 + &
          qr(mv,i-1)**2 + qr(mw,i-1)**2)/qr(1,i-1))
     pr = gamma1*(ql(5,i) - 0.5d0*(ql(mu,i)**2 + &
          ql(mv,i)**2 + ql(mw,i)**2)/ql(1,i))
     rhsq2 = rhsqrtl + rhsqrtr
     u(i) = (qr(mu,i-1)/rhsqrtl + ql(mu,i)/rhsqrtr) / rhsq2
     v(i) = (qr(mv,i-1)/rhsqrtl + ql(mv,i)/rhsqrtr) / rhsq2
     w(i) = (qr(mw,i-1)/rhsqrtl + ql(mw,i)/rhsqrtr) / rhsq2
     enth(i) = (((qr(5,i-1)+pl)/rhsqrtl &
          + (ql(5,i)+pr)/rhsqrtr)) / rhsq2
     u2v2w2(i) = u(i)**2 + v(i)**2 + w(i)**2
     asqrd = gamma1*(enth(i) - .5d0*u2v2w2(i))

     IF (i>=0 .AND. i<=mx .AND. asqrd <= 0.d0) THEN
        IF (ixyz == 1) WRITE(6,*) '*** (rpt3) a**2 <= 0 in x-sweep at ',i
        IF (ixyz == 2) WRITE(6,*) '*** (rpt3) a**2 <= 0 in y-sweep at ',i
        IF (ixyz == 3) WRITE(6,*) '*** (rpt3) a**2 <= 0 in z-sweep at ',i
        WRITE(6,*) 'stopped with a**2 < 0...'
        STOP
     ENDIF
     a(i) = SQRT(asqrd)
     g1a2(i) = gamma1 / asqrd
     euv(i) = enth(i) - u2v2w2(i)
  END DO

  ! Solve the Riemann Problem
  DO i = 2-mbc, mx+mbc

     nx = aux2(nu,i,2)
     ny = aux2(nv,i,2)
     nz = aux2(nw,i,2)
     vn = u(i)*nx + v(i)*ny + w(i)*nz
     IF(icoor == 2)THEN
        areaRatioMinus = aux2(iratio,i-2+imp,2)
        areaRatioPlus  = aux3(iratio,i-2+imp,2)
     ELSEIF(icoor == 3)THEN
        areaRatioMinus = aux2(iratio,i-2+imp,2)
        areaRatioPlus  = aux2(iratio,i-2+imp,3)
     ENDIF
     ! Pick the largest normal to avoid using a singular direction
     IF(ABS(nx) >= ABS(ny) .AND. ABS(nx) >= ABS(nz))THEN
        nonsingularNormal = "x"
     ELSEIF(ABS(ny) >= ABS(nx) .AND. ABS(ny) >= ABS(nz))THEN
        nonsingularNormal = "y"
     ELSEIF(ABS(nz) >= ABS(nx) .AND. ABS(nz) >= ABS(ny))THEN
        nonsingularNormal = "z"
     ELSE
        WRITE(*,*)"Invalid Normal Vector..."
        WRITE(*,*)"nx: ",nx,"ny: ",ny,"nz: ",nz
        STOP
     END IF

     beta(4) = g1a2(i)*(euv(i)*asdq(1,i) &
          + u(i)*asdq(mu,i) + v(i)*asdq(mv,i) + w(i)*asdq(mw,i) - asdq(5,i))
     beta(5) = ( (a(i)-vn)*asdq(1,i) - a(i)*beta(4) &
          + nx*asdq(mu,i) + ny*asdq(mv,i) + nz*asdq(mw,i) )/(2.d0*a(i))
     beta(1) = asdq(1,i) - beta(4) - beta(5)

     SELECT CASE(TRIM(nonsingularNormal))
     CASE("x")
        beta(2) = ( (v(i)-vn*ny)*asdq(1,i) + nx*ny*asdq(mu,i) &
             + (ny**2-1)*asdq(mv,i) + ny*nz*asdq(mw,i) )/nx
        beta(3) = (-(w(i)-vn*nz)*asdq(1,i) - nx*nz*asdq(mu,i) &
             - ny*nz*asdq(mv,i) - (nz**2-1)*asdq(mw,i) )/nx
     CASE("y")
        beta(2) = (-(u(i)-vn*nx)*asdq(1,i) - (nx**2-1)*asdq(mu,i) &
             - ny*nx*asdq(mv,i) - nx*nz*asdq(mw,i) )/ny
        beta(3) = ( (w(i)-vn*nz)*asdq(1,i) + nx*nz*asdq(mu,i) &
             + ny*nz*asdq(mv,i) + (nz**2-1)*asdq(mw,i) )/ny
     CASE("z")
        beta(2) = ( (u(i)-vn*nx)*asdq(1,i) + (nx**2-1)*asdq(mu,i) &
             + nx*ny*asdq(mv,i) + nz*nx*asdq(mw,i) )/nz
        beta(3) = (-(v(i)-vn*ny)*asdq(1,i) - nx*ny*asdq(mu,i) &
             - (ny**2-1)*asdq(mv,i) - nz*ny*asdq(mw,i) )/nz
     END SELECT

     waveb(1,1)  = beta(1)
     waveb(mu,1) = beta(1)*(u(i)-a(i)*nx)
     waveb(mv,1) = beta(1)*(v(i)-a(i)*ny)
     waveb(mw,1) = beta(1)*(w(i)-a(i)*nz)
     waveb(5,1)  = beta(1)*(enth(i) - vn*a(i))
     sb(1) = vn - a(i)

     waveb(1,2)  = beta(4)
     SELECT CASE(TRIM(nonsingularNormal))
     CASE("x")
        waveb(mu,2) = beta(4)*u(i) + beta(2)*ny - beta(3)*nz
        waveb(mv,2) = beta(4)*v(i) - beta(2)*nx
        waveb(mw,2) = beta(4)*w(i) + beta(3)*nx
        waveb(5,2)  = beta(4)*0.5d0*u2v2w2(i)  &
             + beta(2)*(u(i)*ny-v(i)*nx) + beta(3)*(w(i)*nx-u(i)*nz)
     CASE("y")
        waveb(mu,2) = beta(4)*u(i) + beta(2)*ny
        waveb(mv,2) = beta(4)*v(i) - beta(2)*nx + beta(3)*nz
        waveb(mw,2) = beta(4)*w(i) - beta(3)*ny
        waveb(5,2)  = beta(4)*0.5d0*u2v2w2(i)  &
             + beta(2)*(u(i)*ny-v(i)*nx) + beta(3)*(v(i)*nz-w(i)*ny)
     CASE("z")
        waveb(mu,2) = beta(4)*u(i) - beta(2)*nz
        waveb(mv,2) = beta(4)*v(i) + beta(3)*nz
        waveb(mw,2) = beta(4)*w(i) + beta(2)*nx - beta(3)*ny
        waveb(5,2)  = beta(4)*0.5d0*u2v2w2(i)  &
             + beta(2)*(w(i)*nx-u(i)*nz) + beta(3)*(v(i)*nz-w(i)*ny)
     END SELECT
     sb(2) = vn

     waveb(1,3)  = beta(5)
     waveb(mu,3) = beta(5)*(u(i) + a(i)*nx)
     waveb(mv,3) = beta(5)*(v(i) + a(i)*ny)
     waveb(mw,3) = beta(5)*(w(i) + a(i)*nz)
     waveb(5,3)  = beta(5)*(enth(i) + vn*a(i))
     sb(3) = vn + a(i)

     bmasdq(:,i) = 0.d0
     bpasdq(:,i) = 0.d0
     DO mws = 1,mwaves
        IF (sb(mws) < 0.d0)THEN
           waveb(:,mws) = waveb(:,mws)*areaRatioMinus
           bmasdq(:,i) = bmasdq(:,i) + sb(mws)*waveb(:,mws)
        ELSE
           waveb(:,mws) = waveb(:,mws)*areaRatioPlus
           bpasdq(:,i) = bpasdq(:,i) + sb(mws)*waveb(:,mws)
        END IF
     END DO
  END DO

END SUBROUTINE rpt3