      subroutine rotabc (global, iBC, code)
c---------------------------------------------------------------------
c
c This subroutine is responsible for rotating
c the residual and solution vectors for axisymmetric BC's.
c
c input:
c     global(nshg,n): global vector to be rotated.
c     code:            = 'in' for rotating with the residual
c                      = 'out' for rotating the solution
c
c  note that the cos and sin of the rotation angles are preprocessed and
c  stored in acs(1 and 2) respectively.
c
c---------------------------------------------------------------------
c
      use specialBC  ! gives us acs, contains (:,1)=cos(theta) (:,2)=sin(theta)
      include "common.h"

      dimension global(nshg,2),             iBC(nshg),
     &          tmp(nshg)

      character*3 code

      if (code .eq. 'in ') then
         where( btest(iBC,10))
            tmp         =  global(:,1)*acs(:,1) - global(:,2)*acs(:,2)
            global(:,2) =  global(:,1)*acs(:,2) + global(:,2)*acs(:,1)
            global(:,1) = tmp
         endwhere
      else  if (code .eq. 'out') then
         where( btest(iBC,10))
            tmp         =  global(:,1)*acs(:,1) + global(:,2)*acs(:,2)
            global(:,2) = -global(:,1)*acs(:,2) + global(:,2)*acs(:,1)
            global(:,1) = tmp
         endwhere
      else
         call error ('rotabc  ','code    ',0)
      endif

      return
      end


	FUNCTION PR_WVPH  ( powv, howv, group )
C************************************************************************
C* PR_WVPH								*
C*									*
C* This function computes WVPH, the combined wave period and wave       *
C* height, from POWV and HOWV.  A group number is prefixed to the       *
C* combined value to distinguish among instrument waves, wind waves,    *
C* predominant swell waves, and secondary swell waves.  On output, the  *
C* period of the waves is in seconds and the height of the waves is in  *
C* units determined by the calling routine.                             *
C* The following equation is used:                                      *
C*									*
C*       WVPH = ( GROUP * 10000 ) + ( POWV * 100 ) + HOWV               *
C*									*
C* REAL PR_WVPH  ( POWV, HOWV, GROUP )					*
C*									*
C* Input parameters:							*
C*	POWV		REAL	Wave period in seconds                  *
C*	HOWV 		REAL	Wave height (units from calling rtn)    *
C*	GROUP		REAL	Wave group number                       *
C*				  0 = no group				*
C*				  1 = instrument waves			*
C*				  2 = wind waves                        *
C*				  4 = predominant swell waves           *
C*				  5 = secondary swell waves             *
C*									*
C* Output parameters:							*
C*	PR_WVPH		REAL	Combined wave period and height         *
C**									*
C* Log:									*
C* D. Kidwell/NCEP	12/98						*
C* D. Kidwell/NCEP	 2/99	Changed to use NINT; generalized        *
C************************************************************************
        INCLUDE   'GEMPRM.PRM'
        INCLUDE   'ERMISS.FNC'
C------------------------------------------------------------------------
	PR_WVPH = RMISSD
C
	IF ( ( .not. ERMISS ( powv ) ) .and.
     +       ( .not. ERMISS ( howv ) ) .and.
     +       ( .not. ERMISS ( group ) ) ) THEN
	    ipowv  = NINT ( powv )
	    ihowv  = NINT ( howv )
	    igroup = NINT ( group )
	    IF ( ( ipowv .ge. 0 ) .and. ( ipowv .le. 99 ) .and.
     +		 ( ihowv .ge. 0 ) .and. ( ihowv .le. 99 ) .and.
     +		 ( igroup .ge. 0 ) .and. ( igroup .le. 9 ) ) THEN
		PR_WVPH = igroup * 10000 + ipowv * 100 + ihowv
	    END IF
	END IF
C*
	RETURN
	END


      ! This is sample UMAT subroutine made by yossy11, on 20200419
      SUBROUTINE UMAT(STRESS,STATEV,DDSDDE,SSE,SPD,SCD,RPL,DDSDDT,
     & DRPLDE,DRPLDT,STRAN,DSTRAN,TIME,DTIME,TEMP,DTEMP,PREDEF,DPRED,
     & CMNAME,NDI,NSHR,NTENS,NSTATV,PROPS,NPROPS,COORDS,DROT,PNEWDT,
     & CELENT,DFGRD0,DFGRD1,NOEL,NPT,LAYER,KSPT,KSTEP,KINC)

      INCLUDE 'ABA_PARAM.INC'
      CHARACTER*80 CMNAME
      DIMENSION STRESS(NTENS),STATEV(NSTATV),
     & DDSDDE(NTENS,NTENS),DDSDDT(NTENS),DRPLDE(NTENS),
     & STRAN(NTENS),DSTRAN(NTENS),TIME(2),PREDEF(1),DPRED(1),
     & PROPS(NPROPS),COORDS(3),DROT(3,3),DFGRD0(3,3),DFGRD1(3,3)

      PARAMETER(TOLER=1.0D-6,PI=180,YOUNG=70300D0,POISSON=0.3D0)
      DOUBLE PRECISION val,lame,shearMod

      ! initialize DDSDDE
      lame = YOUNG * POISSON / ((1 - 2 * POISSON) * (1 + POISSON))
      shearMod = YOUNG / (2 * (1 + POISSON))
      DDSDDE(:,:) = 0.0D0
      DDSDDE(1:NDI,1:NDI) = lame
      DO i=1,NDI
        DDSDDE(i,i) = lame + 2*shearMod
      END DO
      DO i=NDI+1,NTENS
        DDSDDE(i,i) = shearMod
      END DO

      ! update STRESS
      STRESS(:) = STRESS(:) + MATMUL(DDSDDE,DSTRAN)

      val = 5.0D0
      val = testFunc(.FALSE.,val)
      WRITE(6,*),"Hello",val
      RETURN
      END

      DOUBLE PRECISION FUNCTION testFunc(isAH,value,opValue)
        DOUBLE PRECISION value, opValue
        OPTIONAL opValue
        LOGICAL isAH
        IF (isAH) THEN
          IF (.NOT. PRESENT(opValue)) THEN
            WRITE(6,*),"opValue is required in testFunc"
            RETURN
          ENDIF
          testFunc = value * opValue
        ELSE
          testFunc = value ** 2.0D0
        ENDIF
        RETURN
      END FUNCTION testFunc

      SUBROUTINE testSub(isAH,value,opValue)
        DOUBLE PRECISION value, opValue
        OPTIONAL opValue
        LOGICAL isAH
        IF (isAH) THEN
          IF (.NOT. PRESENT(opValue)) THEN
            WRITE(6,*),"opValue is required in testSub"
            RETURN
          ENDIF
          value = value * opValue
        ELSE
          value = value ** 2.0D0
        ENDIF
        RETURN
      END SUBROUTINE testSub


        subroutine e_solve(s,t,p,e,n,k,s0,t0,p0,sns,tns,pns,iter)
ccc
ccc
ccc
ccc     DESCRIPTION :   Find the zero of the e function using a
ccc                     bisection method
ccc
ccc     PRECISION :     Double
ccc
ccc     INPUT :         s(n)            array of cast salinities
ccc                     t(n)            array of cast in situ temperatures
ccc                     p(n)            array of cast pressures
ccc                     e(n)            array of cast e values
ccc                     n               length of cast
ccc                     k               interval (k-1,k) contains the zero
ccc                     s0              the bottle salinity
ccc                     t0              the bottle in situ temperature
ccc                     p0              the bottle pressure
ccc
ccc     OUTPUT :        sns             salinity of the neutral surface
ccc                                     intersection with the cast
ccc                     tns             in situ temperature of the intersection
ccc                     pns             pressure of the intersection
ccc
ccc
ccc     UNITS :         salinities      psu (IPSS-78)
ccc                     temperatures    degrees C (IPTS-68)
ccc                     pressures       db
ccc
ccc
ccc     AUTHOR :        David Jackett
ccc
ccc     CREATED :       June 1993
ccc
ccc     REVISION :      1.1             30/6/93
ccc
ccc
ccc
        implicit double precision (a-h,o-z)

        dimension s(n),t(n),p(n),e(n)

        data n2/2/

        pl = p(k-1)
        el = e(k-1)
        pu = p(k)
        eu = e(k)

        iter = 0
        isuccess = 0

        do while(isuccess.eq.0)

          iter = iter+1

          pm = (pl+pu)/2

          call stp_interp(s(k-1),t(k-1),p(k-1),n2,sm,tm,pm)

          call sig_vals(s0,t0,p0,sm,tm,pm,sigl,sigu)
          em = sigu-sigl

          if(el*em.lt.0.) then
            pu = pm
            eu = em
          elseif(em*eu.lt.0.) then
            pl = pm
            el = em
          elseif(em.eq.0.) then
            sns = sm
            tns = tm
            pns = pm
            isuccess = 1
          end if

          if(isuccess.eq.0) then
            if(abs(em).le.5.d-5.and.abs(pu-pl).le.5.d-3) then
              sns = sm
              tns = tm
              pns = pm
              isuccess = 1
            elseif(iter.le.20) then
              isuccess = 0
            else
              print *, 'WARNING 1 in e-solve.f'
              print *, iter,'  em',abs(em),'  dp',pl,pu,abs(pu-pl)
              sns = -99.0
              tns = -99.0
              pns = -99.0
              isuccess = 1
            end if
          end if

        end do

        return

        end


      subroutine csalbr(xtau,xalb)
      real xtau,xalb,fintexp3
      xalb=(3*xtau-fintexp3(xtau)*(4+2*xtau)+2*exp(-xtau))
      xalb=xalb/(4.+3*xtau)
      return
      end
      real function fintexp3(xtau)
      real xx,xtau,fintexp1
      xx=(exp(-xtau)*(1.-xtau)+xtau*xtau*fintexp1(xtau))/2.
      fintexp3=xx
      return
      end
      real function fintexp1(xtau)
c accuracy 2e-07... for 0<xtau<1
      real xx,a(0:5),xtau,xftau
      integer i
      data (a(i),i=0,5) /-.57721566,0.99999193,-0.24991055,
     c                  0.05519968,-0.00976004,0.00107857/
      xx=a(0)
      xftau=1.
      do i=1,5
      xftau=xftau*xtau
      xx=xx+a(i)*xftau
      enddo
      fintexp1=xx-log(xtau)
      return
      end


C
C**************************  FHUSE *************************************
C
C  calculate effective saturation using Huyakorn characteristic equation
C
C***********************************************************************
C
      DOUBLE PRECISION FUNCTION FHUSE(PSI)
C
      IMPLICIT NONE
      INCLUDE 'CATHY.H'
      REAL*8   LAMBDA
      REAL*8   PSI
      INCLUDE 'SOILCHAR.H'
C
      IF (PSI .LT. HUPSIA) THEN
         LAMBDA=HUALB*((HUPSIA - PSI)**HUBETA)
         FHUSE=(1.0D0/(1.0D0 + LAMBDA))**HUGAMA
      ELSE
         FHUSE=1.0D0
      END IF
C
      RETURN
      END


c*************************************************************************
c                        DRIFT_KEPU_LAG.F
c*************************************************************************
c subroutine for solving kepler's equation in universal variables.
c using LAGUERRE'S METHOD
c
c             Input:
c                 s             ==>  inital value of universal variable
c                 dt            ==>  time step (real scalor)
c                 r0            ==>  Distance between `Sun' and paritcle
c                                     (real scalor)
c                 mu            ==>  Reduced mass of system (real scalor)
c                 alpha         ==>  energy (real scalor)
c                 u             ==>  angular momentun  (real scalor)
c             Output:
c                 s             ==>  final value of universal variable
c                 fp            ==>  f' from p170
c                                       (real scalors)
c                 c1,c2,c3      ==>  c's from p171-172
c                                       (real scalors)
c                 iflgn          ==>  =0 if converged; !=0 if not
c
c Author:  Hal Levison
c Date:    2/3/93
c Last revision: 4/21/93

      subroutine drift_kepu_lag(s,dt,r0,mu,alpha,u,fp,c1,c2,c3,iflg)

      include '../../swift.inc'

c...  Inputs:
      real*8 s,dt,r0,mu,alpha,u

c...  Outputs:
      real*8 fp,c1,c2,c3
      integer iflg

c...  Internals:
      integer nc,ncmax
      real*8 ln
      real*8 x,fpp,ds,c0,f
      real*8 fdt

      integer NTMP
      parameter(NTMP=NLAG2+1)

c----
c...  Executable code

c...    To get close approch needed to take lots of iterations if alpha<0
        if(alpha.lt.0.0) then
           ncmax = NLAG2
        else
           ncmax = NLAG2
        endif

        ln = 5.0
c...    start laguere's method
        do nc =0,ncmax
           x = s*s*alpha
           call drift_kepu_stumpff(x,c0,c1,c2,c3)
           c1 = c1*s
           c2 = c2*s*s
           c3 = c3*s*s*s
           f = r0*c1 + u*c2 + mu*c3 - dt
           fp = r0*c0 + u*c1 + mu*c2
           fpp = (-40.0*alpha + mu)*c1 + u*c0
           ds = - ln*f/(fp + dsign(1.d0,fp)*sqrt(abs((ln - 1.0)*
     &       (ln - 1.0)*fp*fp - (ln - 1.0)*ln*f*fpp)))
           s = s + ds

           fdt = f/dt

c..        quartic convergence
           if( fdt*fdt.lt.DANBYB*DANBYB) then
             iflg = 0
             return
           endif
c...      Laguerre's method succeeded
        enddo

        iflg = 2

        return

        end    !    drift_kepu_leg
c-----------------------------------------------------------------------


      SUBROUTINE MB02OD( SIDE, UPLO, TRANS, DIAG, NORM, M, N, ALPHA, A,
     $                   LDA, B, LDB, RCOND, TOL, IWORK, DWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To solve (if well-conditioned) one of the matrix equations
C
C        op( A )*X = alpha*B,   or   X*op( A ) = alpha*B,
C
C     where alpha is a scalar, X and B are m-by-n matrices, A is a unit,
C     or non-unit, upper or lower triangular matrix and op( A ) is one
C     of
C
C        op( A ) = A   or   op( A ) = A'.
C
C     An estimate of the reciprocal of the condition number of the
C     triangular matrix A, in either the 1-norm or the infinity-norm, is
C     also computed as
C
C        RCOND = 1 / ( norm(A) * norm(inv(A)) ).
C
C     and the specified matrix equation is solved only if RCOND is
C     larger than a given tolerance TOL.  In that case, the matrix X is
C     overwritten on B.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     SIDE    CHARACTER*1
C             Specifies whether op( A ) appears on the left or right
C             of X as follows:
C             = 'L':  op( A )*X = alpha*B;
C             = 'R':  X*op( A ) = alpha*B.
C
C     UPLO    CHARACTER*1
C             Specifies whether the matrix A is an upper or lower
C             triangular matrix as follows:
C             = 'U':  A is an upper triangular matrix;
C             = 'L':  A is a lower triangular matrix.
C
C     TRANS   CHARACTER*1
C             Specifies the form of op( A ) to be used in the matrix
C             multiplication as follows:
C             = 'N':  op( A ) = A;
C             = 'T':  op( A ) = A';
C             = 'C':  op( A ) = A'.
C
C     DIAG    CHARACTER*1
C             Specifies whether or not A is unit triangular as follows:
C             = 'U':  A is assumed to be unit triangular;
C             = 'N':  A is not assumed to be unit triangular.
C
C     NORM    CHARACTER*1
C             Specifies whether the 1-norm condition number or the
C             infinity-norm condition number is required:
C             = '1' or 'O':  1-norm;
C             = 'I':         Infinity-norm.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of rows of B.  M >= 0.
C
C     N       (input) INTEGER
C             The number of columns of B.  N >= 0.
C
C     ALPHA   (input) DOUBLE PRECISION
C             The scalar  alpha. When alpha is zero then A is not
C             referenced and B need not be set before entry.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,k),
C             where k is M when SIDE = 'L' and is N when SIDE = 'R'.
C             On entry with UPLO = 'U', the leading k-by-k upper
C             triangular part of this array must contain the upper
C             triangular matrix and the strictly lower triangular part
C             of A is not referenced.
C             On entry with UPLO = 'L', the leading k-by-k lower
C             triangular part of this array must contain the lower
C             triangular matrix and the strictly upper triangular part
C             of A is not referenced.
C             Note that when DIAG = 'U', the diagonal elements of A are
C             not referenced either, but are assumed to be unity.
C
C     LDA     INTEGER
C             The leading dimension of array A.
C             LDA >= max(1,M) when SIDE = 'L';
C             LDA >= max(1,N) when SIDE = 'R'.
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
C             On entry, the leading M-by-N part of this array must
C             contain the right-hand side matrix B.
C             On exit, if INFO = 0, the leading M-by-N part of this
C             array contains the solution matrix X.
C             Otherwise, this array is not modified by the routine.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= max(1,M).
C
C     RCOND   (output) DOUBLE PRECISION
C             The reciprocal of the condition number of the matrix A,
C             computed as RCOND = 1/(norm(A) * norm(inv(A))).
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             The tolerance to be used to test for near singularity of
C             the matrix A. If the user sets TOL > 0, then the given
C             value of TOL is used as a lower bound for the reciprocal
C             condition number of that matrix; a matrix whose estimated
C             condition number is less than 1/TOL is considered to be
C             nonsingular. If the user sets TOL <= 0, then an implicitly
C             computed, default tolerance, defined by TOLDEF = k*k*EPS,
C             is used instead, where EPS is the machine precision (see
C             LAPACK Library routine DLAMCH).
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (k)
C
C     DWORK   DOUBLE PRECISION array, dimension (3*k)
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  the matrix A is numerically singular, i.e. the
C                   condition number estimate of A (in the specified
C                   norm) exceeds 1/TOL.
C
C     METHOD
C
C     An estimate of the reciprocal of the condition number of the
C     triangular matrix A (in the specified norm) is computed, and if
C     this estimate is larger then the given (or default) tolerance,
C     the specified matrix equation is solved using Level 3 BLAS
C     routine DTRSM.
C
C
C     REFERENCES
C
C     None.
C
C     NUMERICAL ASPECTS
C                             2
C     The algorithm requires k N/2 operations.
C
C     CONTRIBUTORS
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997.
C
C     REVISIONS
C
C     February 20, 1998.
C
C     KEYWORDS
C
C     Condition number, matrix algebra, matrix operations.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER          DIAG, NORM, SIDE, TRANS, UPLO
      INTEGER            INFO, LDA, LDB, M, N
      DOUBLE PRECISION   ALPHA, RCOND, TOL
C     .. Array Arguments ..
      INTEGER            IWORK(*)
      DOUBLE PRECISION   A(LDA,*), B(LDB,*), DWORK(*)
C     .. Local Scalars ..
      LOGICAL            LSIDE, ONENRM
      INTEGER            NROWA
      DOUBLE PRECISION   TOLDEF
C     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH, LSAME
C     .. External Subroutines ..
      EXTERNAL           DTRCON, DTRSM, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          DBLE, MAX
C     .. Executable Statements ..
C
      LSIDE  = LSAME( SIDE, 'L' )
      IF( LSIDE )THEN
         NROWA = M
      ELSE
         NROWA = N
      END IF
      ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
C
C     Test the input scalar arguments.
C
      INFO = 0
      IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN
         INFO = -1
      ELSE IF( ( .NOT.LSAME( UPLO,  'U' ) ).AND.
     $         ( .NOT.LSAME( UPLO,  'L' ) )      )THEN
         INFO = -2
      ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ).AND.
     $         ( .NOT.LSAME( TRANS, 'T' ) ).AND.
     $         ( .NOT.LSAME( TRANS, 'C' ) )      )THEN
         INFO = -3
      ELSE IF( ( .NOT.LSAME( DIAG,  'U' ) ).AND.
     $         ( .NOT.LSAME( DIAG,  'N' ) )      )THEN
         INFO = -4
      ELSE IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
         INFO = -5
      ELSE IF( M.LT.0 )THEN
         INFO = -6
      ELSE IF( N.LT.0 )THEN
         INFO = -7
      ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
         INFO = -10
      ELSE IF( LDB.LT.MAX( 1, M ) )THEN
         INFO = -12
      END IF
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB02OD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( NROWA.EQ.0 ) THEN
         RCOND = ONE
         RETURN
      END IF
C
      TOLDEF = TOL
      IF ( TOLDEF.LE.ZERO )
     $   TOLDEF = DBLE( NROWA*NROWA )*DLAMCH( 'Epsilon' )
C
      CALL DTRCON( NORM, UPLO, DIAG, NROWA, A, LDA, RCOND, DWORK,
     $             IWORK, INFO )
C
      IF ( RCOND.GT.TOLDEF ) THEN
         CALL DTRSM( SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, LDA, B,
     $               LDB )
      ELSE
         INFO = 1
      END IF
C *** Last line of MB02OD ***
      END


! This program is free software: you can redistribute it and/or modify
!    it under the terms of the GNU General Public License as published by
!    the Free Software Foundation, either version 3 of the License, or
!    (at your option) any later version.
!
!    This program is distributed in the hope that it will be useful,
!    but WITHOUT ANY WARRANTY; without even the implied warranty of
!    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!    GNU General Public License for more details.
!
!    You should have received a copy of the GNU General Public License
!    along with this program.  If not, see <https://www.gnu.org/licenses/>.

program SOET_DMET
!---------------!
  !
  ! ==== Local Data ====
  !
 implicit none
 integer,parameter :: dp=kind(1.d0), OUT=99
 integer :: i,j,L,Nelec,nocc,imp
 real(dp) :: t,U
 DOUBLE PRECISION, allocatable :: D_SOFT(:,:),D_SOFT_diag(:,:), &
                                  D(:,:), D_F(:,:),D_E(:,:),D_unocc_F(:,:), D_occ_E(:,:),D_unocc_E(:,:), &
                                  U_SVD(:,:),V_SVD(:,:),S(:),D_occ_F(:,:), &
                                  sqrt_n0(:,:),n0(:,:), sqrt_un_n0(:,:), inv_sqrt_un_n0(:,:), &
                                  V_F(:,:),V_E(:,:),Socc(:,:),tildeC_F(:,:),C_B(:,:), &
                                  D_provisoir(:,:),eig(:),P(:,:),Pbar(:,:)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!         Allocation and Initialization           !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 open(10,file='mat.dat',status='old')
 read(10,*)L, Nelec, U, t, imp ! #sites, #electrons, t, U, #impurities
 allocate(D_F(imp,L))
 allocate(D_E(L-imp,L))
 allocate(D_SOFT(L,L))
 allocate(D_SOFT_diag(L,L))
 allocate(D(L,L))
 allocate(eig(L))

 open ( UNIT = OUT, FILE = 'Schmidt_decomposition.out', ACCESS = 'SEQUENTIAL' )

 write(OUT,*)'%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%'
 write(OUT,*)'% This program performs the Schmidt Decomposition %'
 write(OUT,*)'% on the Slater determinant obtained by KS-SOFT.  %'
 write(OUT,*)'% It returns the embedded problem to be solved    %'
 write(OUT,*)'% either by DMRG for 2 or more than 2 impurities, %'
 write(OUT,*)'% or analytically for a single impurity site.     %'
 write(OUT,*)'%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%'
 write(OUT,*)
 write(OUT,*)'Number sites                :', L
 write(OUT,*)'Number of impurity sites    :', imp
 write(OUT,*)'Number of electrons         :', Nelec
 write(OUT,*)'On-site Coulomb repulsion U :', U
 write(OUT,*)'Hopping parameter t         :', t

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!             READ MATRIX ELEMENTS                !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

 write(OUT,*)
 write(OUT,*)'Step 1. Read the matrix representation of :'
 write(OUT,*)'        - the 1RDM of the KS-SOFT system, D_soft (size L x L)'
!!! SOFT density matrix
 do i=1,L
    read(10,*)(D_SOFT(i,j),j=1,L)
 enddo
 close(10)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!   Diagonalize the non-interacting Hamiltonian   !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 write(OUT,*)
 write(OUT,*)'Step 2. Diagonalize D_soft. Determine the transformation matrix D.'
 write(OUT,*)'        D_diag = D^T D_soft D'

! Initialize the transformation D to be set in diasym.
! The minus sign to sort from the biggest to the lowest one.
 D=-D_SOFT
 call diasym(D,eig,L)
 D_SOFT_diag=matmul(matmul(transpose(D),D_SOFT),D)

! Determine nocc
 nocc = 0
 do i=1,L
    if (D_SOFT_diag(i,i) > 0.99999) then
       nocc = nocc + 1
    endif
 enddo

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!        Split transformation matrix into         !
!         fragment (F) + environment (E)          !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 write(OUT,*)
 write(OUT,*)'Step 3. Split the transformation matrix D (L x L) into:'
 write(OUT,*)'         -  a fragment part D_F (n_imp x L),'
 write(OUT,*)'         -  an environment part D_E (L-n_imp x L).'
 do i=1,imp
  do j=1,L
    D_F(i,j)=D(i,j)
  enddo
 enddo

 do i=1,L-imp
  do j=1,L
     D_E(i,j)=D(i+imp,j)
  enddo
 enddo

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!        Split transformation matrix into         !
!            occupied and unoccupied              !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 write(OUT,*)
 write(OUT,*)'Step 4. Split D_F and D_E into occupied and unoccupied parts:'
 write(OUT,*)'        -  D_occ_F (n_imp x n_occ),'
 write(OUT,*)'        -  D_unocc_F (n_imp x L-n_occ),'
 write(OUT,*)'        -  D_occ_E(L-n_imp x n_occ),'
 write(OUT,*)'        -  D_unocc_E(L-n_imp x L-n_occ).'
 allocate(D_occ_F(imp,nocc))
 allocate(D_unocc_F(imp,L-nocc))
 allocate(D_occ_E(L-imp,nocc))
 allocate(D_unocc_E(L-imp,L-nocc))

 do i=1,imp
  do j=1,nocc
     D_occ_F(i,j)=D_F(i,j)
  enddo
 enddo

 do i=1,imp
  do j=1,L-nocc
     D_unocc_F(i,j)=D_F(i,j+nocc)
  enddo
 enddo

 do i=1,L-imp
  do j=1,nocc
     D_occ_E(i,j)=D_E(i,j)
  enddo
 enddo

 do i=1,L-imp
  do j=1,L-nocc
     D_unocc_E(i,j)=D_E(i,j+nocc)
  enddo
 enddo

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!          Singular Value Decomposition           !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 write(OUT,*)
 write(OUT,*)'Step 5. Perform a Singular Value Decomposition of D_occ_F.'
 write(OUT,*)'        D_occ_F = U_SVD sqrt_n0 V_SVD with size:'
 write(OUT,*)'        - U_SVD (n_imp x n_imp),'
 write(OUT,*)'        - sqrt_n0 (n_imp x n_imp),'
 write(OUT,*)'        - V_SVD (n_occ x n_occ).'
 allocate(D_provisoir(imp,nocc))
 allocate(S(nocc)) ! temporary matrix for having sqrt_n0 in SVD calculation.
 allocate(sqrt_n0(imp,imp))
 D_provisoir=D_occ_F ! because the input is destroyed in DGSEDD, and I don't want to destroy D_occ_F
 allocate(U_SVD(imp,imp))
 allocate(V_SVD(nocc,nocc))

 call SVD(D_provisoir,U_SVD,S,sqrt_n0,V_SVD,imp,nocc)

 deallocate(D_provisoir)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!            Decomposition of V_SVD into          !
!           fragment (F) + environment (E)        !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 write(OUT,*)
 write(OUT,*)'Step 6. Decompose V_SVD into:'
 write(OUT,*)'        - a fragment part V_F (n_occ x n_imp),'
 write(OUT,*)'        - an environment part V_E (n_occ x n_occ-n_imp).'
 allocate(V_F(nocc,imp))
 allocate(V_E(nocc,nocc-imp))

 do i=1,nocc
  do j=1,imp
     V_F(i,j)=V_SVD(i,j)
  enddo
  do j=1,nocc-imp
     V_E(i,j)=V_SVD(i,j+imp)
  enddo
 enddo

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!        Compute the overlap matrix Socc          !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 write(OUT,*)
 write(OUT,*)'Step 7. Compute the overlap matrix, S_occ (n_occ x n_occ)'
 write(OUT,*)'        S_occ = V_F n0 V_F^T, '
 write(OUT,*)'        where n0 = sqrt_n0^T sqrt_n0.'

 allocate(Socc(nocc,nocc))
 allocate(n0(imp,imp))
 n0=matmul(transpose(sqrt_n0),sqrt_n0)
 Socc=matmul(matmul(V_F,n0),transpose(V_F))

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!            Compute the Projector                !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 write(OUT,*)
 write(OUT,*)'Step 8. Compute the Projector P (L x 2n_imp):'
 write(OUT,*)'        P = Pbar x Block_matrix[[U_SVD^T,0],[0,U_SVD^T]],'
 write(OUT,*)'        where Pbar is the Projector in the basis of natural orbital:'
 write(OUT,*)'        Pbar = Block_matrix[[U_SVD,0],[0,C_B]],'
 write(OUT,*)'        C_B = D_occ_E V_F (sqrt(1 - n0))^-1.'
 allocate(tildeC_F(imp,imp))
 allocate(sqrt_un_n0(imp,imp))
 allocate(inv_sqrt_un_n0(imp,imp))
 allocate(C_B(L-imp,imp))
 allocate(Pbar(L,2*imp))
 allocate(P(L,2*imp))
 allocate(D_provisoir(2*imp,2*imp))

 tildeC_F=matmul(D_occ_F,V_F)

 sqrt_un_n0=0
 do i=1,imp
    sqrt_un_n0(i,i)=sqrt(1-n0(i,i))
 enddo

 call inverse(sqrt_un_n0,inv_sqrt_un_n0,imp)

 C_B = matmul(matmul(D_occ_E,V_F),inv_sqrt_un_n0)

 Pbar=0
 do i=1,imp
  do j=1,imp
    Pbar(i,j)=U_SVD(i,j)
  enddo
 enddo

 do i=imp+1,L
  do j=imp+1,2*imp
    Pbar(i,j)=C_B(i-imp,j-imp)
  enddo
 enddo

 D_provisoir=0
 do i=1,imp
  do j=1,imp
     D_provisoir(i,j)=U_SVD(j,i)
     D_provisoir(i+imp,j+imp)=U_SVD(j,i)
  enddo
 enddo

 P=matmul(Pbar,D_provisoir)

 write(OUT,*)
 write(OUT,*)' Projector P :'
 do i=1,L
   write(OUT,10)(P(i,j),j=1,2*imp)
 enddo
 write(OUT,*)
 write(OUT,*)'End of file.'
 open (98,FILE='projector.dat',ACCESS ='SEQUENTIAL')
 do i=1,L
   write(98,10)(P(i,j),j=1,2*imp)
 enddo
 close(98)

close(OUT)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!                      Format                     !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    10 format(500f25.15)

 end program SOET_DMET


!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------

MODULE m_tetraef
   ! -----------------------------------------------------------------------
   ! This subroutine evaluates the density of states with the tetrahedron method
   ! and sets the weight factors needed for the charge density for bulk systems.
   ! Adapted for the FLEUR code                                          GB 2000
   ! -----------------------------------------------------------------------
   USE m_types
   USE m_constants
   USE m_juDFT

   IMPLICIT NONE

   CONTAINS

   SUBROUTINE tetra_ef(kpts,jspins,lb,ub,eig,zc,xfac,efermi,w)

      TYPE(t_kpts),     INTENT(IN)    :: kpts
      INTEGER,          INTENT(IN)    :: jspins
      REAL,             INTENT(IN)    :: lb,ub,zc,xfac
      REAL,             INTENT(INOUT) :: eig(:,:,:)  !(neigd,nkptd,jspd)
      REAL,             INTENT(OUT)   :: w(:,:,:)    !(neigd,nkptd,jspd)
      REAL,             INTENT(OUT)   :: efermi

      INTEGER :: i,j,jspin,iBand,ikpt,nelec,ncr,itet,it,icorn,jcorn
      REAL    :: elow,dlow,eup,dup,ttt,dfermi,wgs
      REAL    :: weight(4),ecmax(2,size(w,1))
      REAL    :: wght(2,kpts%nkpt,size(w,1)),eval(4)

      DO iBand = 1,size(w,1)
         DO jspin = 1,jspins
            ecmax(jspin,iBand) = -1.0e25
            DO ikpt = 1,kpts%nkpt
               wght(jspin,ikpt,iBand) = 0.0e0
               w(iBand,ikpt,jspin) = 0.0e0
               IF(eig(iBand,ikpt,jspin).GT.ecmax(jspin,iBand)) ecmax(jspin,iBand) = eig(iBand,ikpt,jspin)
            ENDDO
         ENDDO
      ENDDO
      !
      !  check for energy degeneracies in tetrahedrons
      !
      DO jspin = 1,jspins
         DO itet = 1,kpts%ntet
            DO iBand = 1,size(w,1)
               DO i = 1,3
                  icorn = kpts%ntetra(i,itet)
                  DO j = i+1,4
                     jcorn = kpts%ntetra(j,itet)
                     IF(abs(eig(iBand,icorn,jspin)-eig(iBand,jcorn,jspin)).LT.1.0e-7) THEN
                        eig(iBand,icorn,jspin) = eig(iBand,icorn,jspin) + 1.0e-7
                        eig(iBand,jcorn,jspin) = eig(iBand,jcorn,jspin) - 1.0e-7
                     ENDIF
                  ENDDO
               ENDDO
            ENDDO
         ENDDO
      ENDDO
      !
      ! calculate weight factors
      !
      DO itet=1,kpts%ntet
         DO iBand=1,size(w,1)
            DO jspin=1,jspins

               eval = eig(iBand,kpts%ntetra(:,itet),jspin)

               IF(ANY(eval.GE.9999.9)) CYCLE

               DO i=1,4
                  weight(i) = 1.0
                  DO j=1,4
                     IF(i.NE.j) weight(i) = weight(i)*(eval(j)-eval(i))
                  ENDDO
               ENDDO
               DO i=1,4
                  icorn = kpts%ntetra(i,itet)
                  weight(i) = 6.0*kpts%voltet(itet)/(weight(i)*kpts%ntet)
                  wght(jspin,icorn,iBand) = wght(jspin,icorn,iBand) + weight(i)
               ENDDO

            ENDDO
         ENDDO
      ENDDO
      !
      !xfac = 2.0/jspins
      DO iBand = 1,size(w,1)
         DO ikpt = 1,kpts%nkpt
            DO jspin = 1,jspins
               wght(jspin,ikpt,iBand)=xfac*wght(jspin,ikpt,iBand)
            ENDDO
         ENDDO
      ENDDO
      !
      !---------------------------------------------------
      ! determine fermi energy
      !---------------------------------------------------
      !
      nelec = zc                                     ! determine # of electrons
      ncr   = 0                                      ! (modified gb2000)

      elow = lb                                      ! determine lower bound
      dlow = ncr
      DO ikpt = 1,kpts%nkpt
         DO iBand = 1,size(w,1)
            DO jspin = 1,jspins
               ttt = elow - eig(iBand,ikpt,jspin)
               IF ( elow.GT.ecmax(jspin,iBand) ) ttt = ecmax(jspin,iBand) - eig(iBand,ikpt,jspin)
               IF (ttt.LT.0.0e0)                ttt = 0.0e0
               dlow = dlow + wght(jspin,ikpt,iBand)*ttt*ttt*ttt/6
            ENDDO
         ENDDO
      ENDDO
      IF (dlow.GT.nelec) THEN
         WRITE (oUnit,180) elow,dlow,nelec
180      FORMAT (' valence band too high ',/,'  elow ',f10.5,' dlow ',f10.5,' nelec ',i5)
         CALL juDFT_error("dos: valence band too high ",calledby="tetra_ef")
      ENDIF

      it  = 0
      eup = ub
      dup = 0.0 ! determine upper bound
      DO WHILE ((dup-nelec).LT.0.00001)
         dup = ncr
         DO ikpt = 1,kpts%nkpt
            DO iBand = 1,size(w,1)
               DO jspin = 1,jspins
                  ttt = eup - eig(iBand,ikpt,jspin)
                  IF ( eup.GT.ecmax(jspin,iBand) ) ttt = ecmax(jspin,iBand) - eig(iBand,ikpt,jspin)
                  IF (ttt.LT.0.0e0)               ttt = 0.0e0
                  dup = dup + wght(jspin,ikpt,iBand)*ttt*ttt*ttt/6
               ENDDO
            ENDDO
         ENDDO

         IF((dup-nelec).LT.0.00001) THEN
            eup = eup + 0.2
            it  = it + 1
            IF(it .gt. 10) THEN
               WRITE (oUnit,200) eup,dup,nelec
200            FORMAT (' valence band too low ',/,'  eup  ',f10.5,' dup  ',f10.5,' nelec ',i5)
               CALL juDFT_error("dos: valence band too low ",calledby ="tetra_ef")
            END IF
         ENDIF
      ENDDO

      DO WHILE ((eup-elow).GT.1.0e-10)          ! iterate for fermi-energy
         efermi = 0.5*(elow+eup)
         dfermi = real(ncr)
         DO ikpt = 1,kpts%nkpt
            DO iBand = 1,size(w,1)
               DO jspin = 1,jspins
                  ttt  =efermi-eig(iBand,ikpt,jspin)
                  IF ( efermi.GT.ecmax(jspin,iBand) ) ttt = ecmax(jspin,iBand) - eig(iBand,ikpt,jspin)
                  IF (ttt.LT.0.0e0)                   ttt = 0.0e0
                  dfermi = dfermi + wght(jspin,ikpt,iBand)*ttt*ttt*ttt/6
               ENDDO
            ENDDO
         ENDDO
         IF (dfermi.GT.nelec) THEN
            eup = efermi
         ELSE
            elow = efermi
         ENDIF
      ENDDO

      WRITE (oUnit,220) efermi,dfermi,nelec
220   FORMAT (//,'>>> D O S <<<',//,'   fermi energy =',f10.5,' dtot =',f10.5,' nelec =',i5)
      !
      !---------------------------------------------------
      ! calculate weight factors for charge density integration
      !---------------------------------------------------
      !
      DO itet = 1,kpts%ntet
         DO iBand = 1,size(w,1)
            DO jspin = 1,jspins
               eval = eig(iBand,kpts%ntetra(:,itet),jspin)

               IF(ANY(eval.GE.9999.9)) CYCLE

               DO i = 1,4
                  weight(i) = 1.0
                  DO j = 1,4
                     IF(i.NE.j) THEN
                        weight(i) = weight(i) * (eval(j) - eval(i))
                     ENDIF
                  ENDDO
                  weight(i) = 6.0 * kpts%voltet(itet)/(weight(i)*kpts%ntet)
               ENDDO

               wgs = 0.0e0
               DO i = 1,4
                  ttt = efermi - eval(i)
                  IF(efermi.GT.ecmax(jspin,iBand)) ttt = ecmax(jspin,iBand) - eval(i)
                  IF( ttt.LT.0.0e0 )               ttt = 0.0e0
                  wgs = wgs + ttt**3*weight(i)
               ENDDO
               wgs = wgs / 24.0

               w(iBand,kpts%ntetra(:,itet),jspin) = w(iBand,kpts%ntetra(:,itet),jspin) + wgs

            ENDDO
         ENDDO
      ENDDO

!     DO jspin = 1,jspins
!        DO ikpt = 1,kpts%nkpt
!           DO iBand = 1,size(w,1)
!              w(iBand,ikpt,jspin) = xfac * w(iBand,ikpt,jspin)
!           ENDDO
!        ENDDO
!     ENDDO

   END SUBROUTINE tetra_ef
END MODULE m_tetraef


c	dtplanck es una funcion que calcula la derivada de la funcion
c	de planck con respecto a la temperatura

	real*4 function dtplanck(t,lambda)
	real*4 t,lambda,c1,c2,d4,b,ex,dplnck

	c1=1.1910627e-5		!1./(2*h*c**2) con lambda en cm
	c2=1.43879
	d4=lambda*lambda*lambda*lambda
	b=dplnck(t,lambda)
	ex=c2/(lambda*t)
	dtplanck=(c2*b*b*d4*exp(ex))/(c1*t*t)

	return
	end


! This module is a part oF SLEZAFORT library and is distributed under MIT license.
! See the project page for more details:  https://github.com/gronki/libslezafort
!
! Copyright (c) 2016 Dominik Gronkiewicz
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.

module slf_interpol

    use iso_fortran_env
    integer, parameter, private :: dp = real64

contains

    subroutine interpol(x_in, y_in, x_out, y_out)
        real(dp), intent(in) :: x_in(:)
        real(dp), intent(in) :: y_in(size(x_in))
        real(dp), intent(in) :: x_out
        real(dp), intent(out) :: y_out
        real(dp) :: x0,x1,y0,y1,t,control
        integer :: i, i_nearest, n

        n = size(y_in)

        t = abs(x_in(1)-x_in(n))

        ! find the nearest point
        control = x_in(2) - x_in(1)
        do i=1,n
            if (i .gt. 1) then
                if ( control * (x_in(i)-x_in(i-1)) .le. 0 ) then
                    write (0,*) 'interpol: x-axis points should be either in ascending or descending order'
                    return
                endif
            endif
            if ( (abs(x_in(i)-x_out) .lt. abs(t)) .or. (i .eq. 1) ) then
                i_nearest = i
                t = x_in(i)-x_out
            end if
        end do

        if ( t .eq. 0. ) then
            y_out = y_in(i_nearest)
            return
        else if (t .gt. 0) then
            if ( i_nearest .eq. 1 ) then
                y_out = y_in(1)
                return
            endif
            x1 = x_in(i_nearest)
            y1 = y_in(i_nearest)
            x0 = x_in(i_nearest-1)
            y0 = y_in(i_nearest-1)
        else
            if ( i_nearest .eq. n ) then
                y_out = y_in(n)
                return
            endif
            x0 = x_in(i_nearest)
            y0 = y_in(i_nearest)
            x1 = x_in(i_nearest+1)
            y1 = y_in(i_nearest+1)
        end if

        t = (x1 - x_out) / (x1-x0)
        y_out = t * y0 + (1.-t) * y1

    end subroutine

end module


      FUNCTION ADD(IA, IB)
          ADD = IA + IB
      END


      program power02

C     Check the interpretation of the power operator

      read *, n

      i = -n**2

      print *, i

      end


    type thefit
      sequence
      real(b8) val
      integer index,proc,to,buff
    end type thefit
module sort_mod
! recursive merge sort taken from pascal routine in
! moret & shapiro's book

  interface operator (.test.)
    module procedure thetest
  end interface

  interface operator (.lt.)
    module procedure theless
  end interface

  interface operator (.gt.)
    module procedure thegreat
  end interface

contains

    function theless(a,b)
    use galapagos
    type(thefit), intent (in) :: a,b
    logical theless
    if(a%val < b%val)then
        theless=.true.
    else
        theless=.false.
    endif
    return
  end function theless

    function thegreat(a,b)
    use galapagos
    type(thefit), intent (in) :: a,b
    logical thegreat
    if(a%val > b%val)then
        thegreat=.true.
    else
        thegreat=.false.
    endif
    return
  end function thegreat

function thetest(a,b)
    use galapagos
    type(thefit), intent (in) :: a,b
    logical thetest
    if(a%val >= b%val)then
        thetest=.true.
    else
        thetest=.false.
    endif
    return
  end function thetest

  subroutine Sort(Ain, n)
    use Merge_mod_types
    integer n
    type(thefit), target:: ain(n)
    allocate(work(n))
    nullify(a)
    a=>ain
    call RecMergeSort(1,n)
    deallocate(work)
    return
  end subroutine Sort

  recursive subroutine RecMergeSort(left, right)
    use Merge_mod_types
    integer,intent(in):: left,right
    integer  middle
    if (left < right) then
        middle = (left + right) / 2
        call RecMergeSort(left,middle)
        call RecMergeSort(middle+1,right)
        call Merge(left,middle-left+1,right-middle)
    endif
    return
  end subroutine RecMergeSort

  subroutine Merge(s, n, m)
    use Merge_mod_types
    integer s,n,m
    integer i,  j, k, t, u
    k = 1
    t = s + n
    u = t + m
    i = s
    j = t
    if ((i < t) .and. (j < u))then
        do while ((i < t) .and. (j < u))
            if (A(i) .test.  A(j))then
                work(k) = A(i)
                i = i + 1
                k = k + 1
            else
                work(k) = A(j)
                j = j + 1
                k = k + 1
            endif
         enddo
    endif
    if(i < t )then
        do while (i < t )
            work(k) = A(i)
            i = i + 1
            k = k + 1
        enddo
    endif
    if(j < u)then
        do while (j < u )
            work(k) = A(j)
            j = j + 1
            k = k + 1
        enddo
    endif
    i = s
! the next line is not in moret & shapiro's book
    k=k-1
    do j = 1 , k
        A(i) = work(j)
        i = i + 1
    enddo
    return
  end subroutine Merge
end module sort_mod


      subroutine dmaxvol(a, n, r, ind, nswp, tol)
      implicit none
      integer, intent(in) :: r
      integer, intent(in) :: n
      real(8), intent(in) :: a(n,r)
      integer, intent(out) :: ind(r)
      integer tmp_ind(r),p(n),ipiv(r)
      real(8) ::  ba(r,n),c(n,r), u(n), v(r)
      real(8), intent(in) :: tol
      logical not_converged
      integer, intent(in) ::  nswp
      integer info,i,j,swp, big_ind,i0,j0,tmp
      integer idamax
      external idamax
      !tol=5e-2
      !nswp=20
      !Generate initial approximation
      ba = transpose(a)
      call dcopy(n*r,a,1,c,1)
      do i = 1,n
      p(i) = i
      end do
      call dgetrf(n,r,c,n,ipiv,info)
      do i = 1,r
      j = ipiv(i)
      if ( j .ne. i ) then
          tmp = p(i)
          p(i) = p(j)
          p(j) = tmp
      end if
      end do
      ind(1:r) = p(1:r)
      if (info .ne. 0) then
          print *, 'Maxvol failed at dgetrf'
      end if
      do i = 1,r
      tmp_ind(i) = i
      end do
      call dgetrs('t',r,n,c,n,tmp_ind,ba,r,info)

      if (info .ne. 0) then
          print *,'Maxvol failed at dgetrs'
      end if
      not_converged = .true.
      swp = 1
      !Now start the main iteration
      do while (not_converged .and. swp <= nswp)
      big_ind = idamax(r*n,ba,1)
      j0 = mod(big_ind - 1,r) + 1 ! This value is from 1 to r
      i0 = (big_ind - j0)/ r + 1 ! This value seems OK: If it is smaller, it goes
      if ( i0 > n ) then
          print *,'aarrgh'
          print *,'big_ind=',big_ind, 'i0=',i0,'j0=',j0,'n=',n,'r=',r
      end if

      if ( dabs(ba(j0,i0)) <= 1 + tol ) then
          not_converged = .false.
      else

          u(1:n) = ba(j0,:)
          v(1:r) = ba(:,ind(j0)) - ba(:,i0)
          u(1:n) = u(1:n) / ba(j0,i0)
          call dger(r,n,1.d0,v,1,u,1,ba,r)
          swp = swp + 1
          ind(j0) = i0

      end if

      end do

      end subroutine dmaxvol

      subroutine zmaxvol(a, n, r, ind, nswp, tol)
      implicit none
      integer, intent(in) :: r
      integer, intent(in) :: n
      complex(8), intent(in) :: a(n,r)
      integer, intent(out) :: ind(r)
      integer tmp_ind(r),p(n),ipiv(r)
      complex(8) ::  ba(r,n),c(n,r), u(n), v(r)
      real(8), intent(in) :: tol
      logical not_converged
      integer, intent(in) ::  nswp
      integer info,i,j,swp, big_ind,i0,j0,tmp
      complex(8) :: ONE
      integer izamax
      external izamax
      !tol=5e-2
      !nswp=20
      !Generate initial approximation
      ONE = (1d0, 0d0)
      ba = transpose(a)
      call zcopy(n*r,a,1,c,1)
      do i = 1,n
      p(i) = i
      end do
      call zgetrf(n,r,c,n,ipiv,info)
      do i = 1,r
      j = ipiv(i)
      if ( j .ne. i ) then
          tmp = p(i)
          p(i) = p(j)
          p(j) = tmp
      end if
      end do
      ind(1:r) = p(1:r)
      if (info .ne. 0) then
          print *, 'Maxvol failed at zgetrf'
      end if
      do i = 1,r
      tmp_ind(i) = i
      end do
      call zgetrs('T',r,n,c,n,tmp_ind,ba,r,info)

      if (info .ne. 0) then
          print *,'Maxvol failed at zgetrs'
      end if
      not_converged = .true.
      swp = 1
      !Now start the main iteration
      do while (not_converged .and. swp <= nswp)
      big_ind = izamax(r*n,ba,1)
      j0 = mod(big_ind - 1,r) + 1 ! This value is from 1 to r
      i0 = (big_ind - j0)/ r + 1 ! This value seems OK: If it is smaller, it goes
      if ( i0 > n ) then
          print *,'aarrgh'
          print *,'big_ind=',big_ind, 'i0=',i0,'j0=',j0,'n=',n,'r=',r
      end if

      if ( zabs(ba(j0,i0)) <= 1 + tol ) then
          not_converged = .false.
      else

          u(1:n) = ba(j0,:)
          v(1:r) = ba(:,ind(j0)) - ba(:,i0)
          u(1:n) = u(1:n) / ba(j0,i0)
          call zgeru(r,n,ONE,v,1,u,1,ba,r)
          swp = swp + 1
          ind(j0) = i0

      end if

      end do

      end subroutine zmaxvol


      subroutine GSMCAMRPOP(
     &           phi
     &           ,iphilo0
     &           ,iphihi0
     &           ,rhs
     &           ,irhslo0
     &           ,irhshi0
     &           ,icoloredboxlo0
     &           ,icoloredboxhi0
     &           ,dx
     &           ,alpha
     &           ,beta
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer iphilo0
      integer iphihi0
      REAL*8 phi(
     &           iphilo0:iphihi0)
      integer irhslo0
      integer irhshi0
      REAL*8 rhs(
     &           irhslo0:irhshi0)
      integer icoloredboxlo0
      integer icoloredboxhi0
      REAL*8 dx
      REAL*8 alpha
      REAL*8 beta
      REAL*8 lambda, dxinv, sum_b, lphi
      integer i
      integer idir
      dxinv = (1.0d0)/(dx*dx)
      sum_b = 0.0
      do idir = 0, 1 -1
         sum_b = sum_b + (2.0d0)*dxinv
      enddo
      lambda = (1.0d0)/(alpha - beta*sum_b)
      do i = icoloredBoxlo0,icoloredBoxhi0,2
        lphi =
     &     (    phi(i+1)
     &     +    phi(i-1)
     $     -(2.0d0)*phi(i  ))
        lphi = lphi*dxinv
        phi(i) =
     $       phi(   i) +
     &       lambda*(   rhs(   i) - lphi)
      enddo
      return
      end
      subroutine GSRBHELMHOLTZ(
     &           phi
     &           ,iphilo0
     &           ,iphihi0
     &           ,nphicomp
     &           ,rhs
     &           ,irhslo0
     &           ,irhshi0
     &           ,nrhscomp
     &           ,iregionlo0
     &           ,iregionhi0
     &           ,dx
     &           ,alpha
     &           ,beta
     &           ,redBlack
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer nphicomp
      integer iphilo0
      integer iphihi0
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           0:nphicomp-1)
      integer nrhscomp
      integer irhslo0
      integer irhshi0
      REAL*8 rhs(
     &           irhslo0:irhshi0,
     &           0:nrhscomp-1)
      integer iregionlo0
      integer iregionhi0
      REAL*8 dx
      REAL*8 alpha
      REAL*8 beta
      integer redBlack
      REAL*8 lambda, dxinv, sum_b, lphi, helmop
      integer i
      integer n,ncomp,idir,indtot,imin,imax
      dxinv = (1.0d0)/(dx*dx)
      sum_b = 0.0
      do idir = 0, 1 -1
         sum_b = sum_b + (2.0d0)*dxinv
      enddo
      lambda = -(1.0d0)/(alpha - beta*sum_b)
      ncomp = nphicomp
      if (ncomp .ne. nrhscomp) then
         call MAYDAYERROR()
      endif
      do n = 0, ncomp - 1
            imin = iregionlo0
            indtot = imin
            imin = imin + abs(mod(indtot + redBlack, 2))
            imax = iregionhi0
            do i = imin, imax, 2
              lphi =   (phi(i+1,n)
     &             +    phi(i-1,n)
     &             -(2.0d0)*1*phi(i,n))*dxinv
              helmop = alpha*phi(i,n) + beta*lphi
              phi(i,n) = phi(i,n) +
     &             lambda*(helmop - rhs(i,n))
            enddo
      enddo
      return
      end
      subroutine GSRBLAPLACIAN(
     &           phi
     &           ,iphilo0
     &           ,iphihi0
     &           ,nphicomp
     &           ,rhs
     &           ,irhslo0
     &           ,irhshi0
     &           ,nrhscomp
     &           ,iregionlo0
     &           ,iregionhi0
     &           ,dx
     &           ,redBlack
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer nphicomp
      integer iphilo0
      integer iphihi0
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           0:nphicomp-1)
      integer nrhscomp
      integer irhslo0
      integer irhshi0
      REAL*8 rhs(
     &           irhslo0:irhshi0,
     &           0:nrhscomp-1)
      integer iregionlo0
      integer iregionhi0
      REAL*8 dx
      integer redBlack
      REAL*8 lambda, dxinv, sum_b, lphi, lap
      integer i
      integer n,ncomp,idir,indtot,imin,imax,counter
      dxinv = (1.0d0)/(dx*dx)
      sum_b = 0.0
      do idir = 0, 1 -1
         sum_b = sum_b + (2.0d0)*dxinv
      enddo
      lambda = -(1.0d0)/sum_b
      ncomp = nphicomp
      if (ncomp .ne. nrhscomp) then
         call MAYDAYERROR()
      endif
      do n = 0, ncomp - 1
            imin = iregionlo0
            indtot = imin
            imin = imin + abs(mod(indtot + redBlack, 2))
            imax = iregionhi0
            do i = imin, imax, 2
              lphi = (
     &                  phi(i+1,n)
     &             +    phi(i-1,n)
     &             ) * dxinv
              phi(i,n) = lambda*(rhs(i,n)-lphi)
            enddo
      enddo
      i=(iregionhi0- iregionlo0+1)
      ch_flops=ch_flops+ ncomp*i/2*(2*1 +3)
      return
      end
      subroutine GSRBLAZY(
     &           phi
     &           ,iphilo0
     &           ,iphihi0
     &           ,lphi
     &           ,ilphilo0
     &           ,ilphihi0
     &           ,rhs
     &           ,irhslo0
     &           ,irhshi0
     &           ,icoloredboxlo0
     &           ,icoloredboxhi0
     &           ,alpha
     &           ,beta
     &           ,dx
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer iphilo0
      integer iphihi0
      REAL*8 phi(
     &           iphilo0:iphihi0)
      integer ilphilo0
      integer ilphihi0
      REAL*8 lphi(
     &           ilphilo0:ilphihi0)
      integer irhslo0
      integer irhshi0
      REAL*8 rhs(
     &           irhslo0:irhshi0)
      integer icoloredboxlo0
      integer icoloredboxhi0
      REAL*8 alpha
      REAL*8 beta
      REAL*8 dx
      integer i, idir
      REAL*8 dxinv, sum_b, lambda
      dxinv = (1.0d0)/(dx*dx)
      sum_b = 0.0
      do idir = 0, 1 -1
         sum_b = sum_b + (2.0d0)*dxinv
      enddo
      lambda = -(1.0d0)/(alpha - beta*sum_b)
      do i = icoloredBoxlo0,icoloredBoxhi0,2
      phi(i) =
     $     phi(   i) -
     &     lambda*(
     $     rhs(   i) -
     $     lphi(  i))
      enddo
      return
      end
      subroutine AMRPMULTICOLOR(
     &           phi
     &           ,iphilo0
     &           ,iphihi0
     &           ,rhs
     &           ,irhslo0
     &           ,irhshi0
     &           ,weight
     &           ,alpha
     &           ,beta
     &           ,dx
     &           ,icoloredboxlo0
     &           ,icoloredboxhi0
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer iphilo0
      integer iphihi0
      REAL*8 phi(
     &           iphilo0:iphihi0)
      integer irhslo0
      integer irhshi0
      REAL*8 rhs(
     &           irhslo0:irhshi0)
      REAL*8 weight
      REAL*8 alpha
      REAL*8 beta
      REAL*8 dx(0:0)
      integer icoloredboxlo0
      integer icoloredboxhi0
      integer i
      REAL*8 laplphi, dx0
      dx0 = beta/(dx(0) * dx(0))
      do i = icoloredBoxlo0,icoloredBoxhi0,2
        laplphi =
     &     (    phi(i+1)
     &     +    phi(i-1)
     $     -(2.0d0)*phi(i  ))*dx0
        laplphi = laplphi + alpha * phi(i)
        phi(i) = phi(i) +
     &     weight*(rhs(i) - laplphi)
      enddo
      return
      end
      subroutine OPERATORLAP(
     &           lofphi
     &           ,ilofphilo0
     &           ,ilofphihi0
     &           ,nlofphicomp
     &           ,phi
     &           ,iphilo0
     &           ,iphihi0
     &           ,nphicomp
     &           ,iregionlo0
     &           ,iregionhi0
     &           ,dx
     &           ,alpha
     &           ,beta
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer nlofphicomp
      integer ilofphilo0
      integer ilofphihi0
      REAL*8 lofphi(
     &           ilofphilo0:ilofphihi0,
     &           0:nlofphicomp-1)
      integer nphicomp
      integer iphilo0
      integer iphihi0
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           0:nphicomp-1)
      integer iregionlo0
      integer iregionhi0
      REAL*8 dx
      REAL*8 alpha
      REAL*8 beta
      REAL*8 dxinv, lap
      integer n,ncomp
      integer i
      ncomp = nphicomp
      if (ncomp .ne. nlofphicomp) then
         call MAYDAYERROR()
      endif
      dxinv = (1.0d0)/(dx*dx)
      do n = 0, ncomp-1
      do i = iregionlo0,iregionhi0
          lap = (  phi(i+1,n)
     &                     + phi(i-1,n)
     &                     -(2*1)*phi(i,n) )
     &       * dxinv
          lofphi(i,n) = alpha*phi(i,n)+beta*lap
      enddo
      enddo
      i=(iregionhi0- iregionlo0+1)
      ch_flops=ch_flops+ ncomp*i*(2*1 +5)
      return
      end
      subroutine OPERATORLAPRES(
     &           r
     &           ,irlo0
     &           ,irhi0
     &           ,nrcomp
     &           ,phi
     &           ,iphilo0
     &           ,iphihi0
     &           ,nphicomp
     &           ,rhs
     &           ,irhslo0
     &           ,irhshi0
     &           ,nrhscomp
     &           ,iregionlo0
     &           ,iregionhi0
     &           ,dx
     &           ,alpha
     &           ,beta
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer nrcomp
      integer irlo0
      integer irhi0
      REAL*8 r(
     &           irlo0:irhi0,
     &           0:nrcomp-1)
      integer nphicomp
      integer iphilo0
      integer iphihi0
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           0:nphicomp-1)
      integer nrhscomp
      integer irhslo0
      integer irhshi0
      REAL*8 rhs(
     &           irhslo0:irhshi0,
     &           0:nrhscomp-1)
      integer iregionlo0
      integer iregionhi0
      REAL*8 dx
      REAL*8 alpha
      REAL*8 beta
      REAL*8 dxinv, lap
      integer n,ncomp
      integer i
      ncomp = nphicomp
      dxinv = (1.0d0)/(dx*dx)
      do n = 0, ncomp-1
      do i = iregionlo0,iregionhi0
          lap = (  phi(i+1,n)
     &                     + phi(i-1,n)
     &                     -(2*1)*phi(i,n) )
     &       * dxinv
         r(i,n) = -alpha*phi(i,n) -beta*lap +
     &       rhs(i,n)
      enddo
      enddo
      ch_flops=ch_flops+(iregionhi0- iregionlo0+1)*ncomp*(2*1 +6)
      return
      end
      subroutine RESTRICTRES(
     &           res
     &           ,ireslo0
     &           ,ireshi0
     &           ,nrescomp
     &           ,phi
     &           ,iphilo0
     &           ,iphihi0
     &           ,nphicomp
     &           ,rhs
     &           ,irhslo0
     &           ,irhshi0
     &           ,nrhscomp
     &           ,alpha
     &           ,beta
     &           ,iregionlo0
     &           ,iregionhi0
     &           ,dx
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer nrescomp
      integer ireslo0
      integer ireshi0
      REAL*8 res(
     &           ireslo0:ireshi0,
     &           0:nrescomp-1)
      integer nphicomp
      integer iphilo0
      integer iphihi0
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           0:nphicomp-1)
      integer nrhscomp
      integer irhslo0
      integer irhshi0
      REAL*8 rhs(
     &           irhslo0:irhshi0,
     &           0:nrhscomp-1)
      REAL*8 alpha
      REAL*8 beta
      integer iregionlo0
      integer iregionhi0
      REAL*8 dx
      REAL*8 denom,dxinv,lofphi
      integer n,ncomp
      integer i
      integer ii
      ncomp = nphicomp
      dxinv = (1.0d0) / (dx*dx)
      denom = 2
      do n = 0, ncomp-1
      do i = iregionlo0,iregionhi0
          ii = i/2
          lofphi = alpha * phi(i,n)
     &           + beta  *
     &              ( phi(i+1,n)
     &                        + phi(i-1,n)
     &                        - phi(i  ,n) * 2 * 1
     &              ) * dxinv
          res(ii,n) = res(ii,n)
     &                            + (rhs(i,n) - lofphi) / denom
      enddo
      enddo
      ch_flops=ch_flops+(iregionhi0- iregionlo0+1)*ncomp*(2*1 +6)
      return
      end
      subroutine PROLONG(
     &           phi
     &           ,iphilo0
     &           ,iphihi0
     &           ,nphicomp
     &           ,coarse
     &           ,icoarselo0
     &           ,icoarsehi0
     &           ,ncoarsecomp
     &           ,iregionlo0
     &           ,iregionhi0
     &           ,m
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer nphicomp
      integer iphilo0
      integer iphihi0
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           0:nphicomp-1)
      integer ncoarsecomp
      integer icoarselo0
      integer icoarsehi0
      REAL*8 coarse(
     &           icoarselo0:icoarsehi0,
     &           0:ncoarsecomp-1)
      integer iregionlo0
      integer iregionhi0
      integer m
      INTEGER ncomp, n
      integer i
      integer ii
      ncomp = nphicomp
      do n = 0, ncomp-1
      do i = iregionlo0,iregionhi0
          ii = i/m
          phi(i,n) =  phi(i,n) +
     &        coarse(ii,n)
      enddo
      enddo
      ch_flops=ch_flops+(iregionhi0- iregionlo0+1)
      return
      end
      subroutine PROLONG_2(
     &           phi
     &           ,iphilo0
     &           ,iphihi0
     &           ,nphicomp
     &           ,coarse
     &           ,icoarselo0
     &           ,icoarsehi0
     &           ,ncoarsecomp
     &           ,iregionlo0
     &           ,iregionhi0
     &           ,m
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer nphicomp
      integer iphilo0
      integer iphihi0
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           0:nphicomp-1)
      integer ncoarsecomp
      integer icoarselo0
      integer icoarsehi0
      REAL*8 coarse(
     &           icoarselo0:icoarsehi0,
     &           0:ncoarsecomp-1)
      integer iregionlo0
      integer iregionhi0
      integer m
      INTEGER ncomp, n
      integer i
      integer offs(1)
      integer ic
      REAL*8 f0, den, fx(1)
      den = (1.0d0)/(4**1)
      fx(1) = (3.0d0)*den
      f0 = (1.0d0)*den
      ncomp = nphicomp
      do i = iregionlo0,iregionhi0
        ic = i/m
        offs(1) = 2*mod(i,2) - 1
        do n = 0, ncomp-1
          phi(i,n) = phi(i,n)
     $      + fx(1)*
     $        coarse(ic,n)
     $      + f0*coarse(ic+offs(1),n)
        enddo
      enddo
      return
      end
      subroutine NEWGETFLUX(
     &           flux
     &           ,ifluxlo0
     &           ,ifluxhi0
     &           ,nfluxcomp
     &           ,phi
     &           ,iphilo0
     &           ,iphihi0
     &           ,nphicomp
     &           ,iboxlo0
     &           ,iboxhi0
     &           ,beta_dx
     &           ,a_idir
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer CHF_ID(0:5,0:5)
      data CHF_ID/ 1,0,0,0,0,0 ,0,1,0,0,0,0 ,0,0,1,0,0,0 ,0,0,0,1,0,0 ,0
     &,0,0,0,1,0 ,0,0,0,0,0,1 /
      integer nfluxcomp
      integer ifluxlo0
      integer ifluxhi0
      REAL*8 flux(
     &           ifluxlo0:ifluxhi0,
     &           0:nfluxcomp-1)
      integer nphicomp
      integer iphilo0
      integer iphihi0
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           0:nphicomp-1)
      integer iboxlo0
      integer iboxhi0
      REAL*8 beta_dx
      integer a_idir
      INTEGER ncomp,n
      integer ii
      integer i
      ncomp = nphicomp
      ii = CHF_ID(a_idir, 0)
      do n = 0, ncomp-1
      do i = iboxlo0,iboxhi0
          flux(i,n) =
     &        (phi(i,n)-
     &         phi(i-ii,n))*beta_dx
      enddo
      enddo
      return
      end


*deck dsmit
      subroutine dsmit(n1,c,s,v,y)
c
c  return an n1 by n1 triangular matrix c such that
c  c(t)sc=i, where i is an n1 by n1 identity matrix.
c
*mdc*if real16 vax ibm cray
*      implicit real*16 (a-h,o-z)
*mdc*else
      implicit real*8 (a-h,o-z)
*mdc*endif
*mdc*if real16q ibm vax
*c *** this mdc block is not necessary since the constants will be ***
*c *** correctly converted at compile time.  should it be removed? ***
*      parameter (a0=0.0q0, a1=1.0q0)
*mdc*else
      parameter (a0=0.0d0, a1=1.0d0)
*mdc*endif
c     common /ffm/ x,nn,n1,k1
      dimension c(n1,*), s(n1,*), v(*), y(*)
c
      do 20 i=1,n1
        do 10 j=1,i
          c(i,j)=a0
   10   continue
   20 continue
      do 80 j=1,n1
        kmax=j-1
        fac=s(j,j)
        do 30 k=1,kmax
          v(k)=a0
          y(k)=s(k,j)
   30   continue
        do 60 k=1,kmax
          dot=a0
          do 40 i=1,k
            dot=c(i,k)*y(i)+dot
   40     continue
          do 50 i=1,k
            v(i)=v(i)-dot*c(i,k)
   50     continue
          fac = fac - dot * dot
   60   continue
        fac=a1/sqrt(fac)
        c(j,j)=fac
        do 70 k=1,kmax
          c(k,j)=fac*v(k)
   70   continue
   80 continue
      return
      end


      PROGRAM HTEST
      PARAMETER (NWPAWC=20000)
      COMMON/PAWC/H(NWPAWC)
      EXTERNAL HTFUN1,HTFUN2
*.------------------------------------------------------------
      CALL HLIMIT(NWPAWC)
*             Book histograms and declare functions
      CALL HBFUN1(100,'Test of HRNDM1',100,0.,1.,HTFUN1)
      CALL HBOOK1(110,'Filled according to HTFUN1',100,0.,1.,1000.)
      CALL HBFUN2(200,'Test of HRNDM2',100,0.,1.,40,0.,1.,HTFUN2)
      CALL HSCALE(200,0.)
      CALL HBOOK2(210,'Filled according to HTFUN2',
     X            100,0.,1.,40,0.,1.,30.)
*             Fill histograms
      DO 10 I=1,10000
         X=HRNDM1(100)
         CALL HFILL(110,X,0.,1.)
         CALL HRNDM2(200,X,Y)
         CALL HFILL(210,X,Y,1.)
  10  CONTINUE
*             Save all histograms on file HTEST.DAT
      CALL HRPUT(0,'HTEST.DAT','N')
      CALL HDELET(100)
      CALL HDELET(200)
      CALL HPRINT(0)
      END
      FUNCTION HTFUN2(X,Y)
*             Two-dimensional gaussian
      HTFUN2=HTFUN1(X)*HTFUN1(Y)
      RETURN
      END

      FUNCTION HTFUN1(X)
*             Constants for gaussians
      DATA C1,C2/1.,0.5/
      DATA XM1,XM2/0.3,0.7/
      DATA XS1,XS2/0.07,0.12/
*             Calculate the gaussians
      A1=-0.5*((X-XM1)/XS1)**2
      A2=-0.5*((X-XM2)/XS2)**2
      X1=C1
      X2=C2
      IF(ABS(A1).GT.0.0001)X1=C1*EXP(A1)
      IF(ABS(A2).GT.0.0001)X2=C2*EXP(A2)
*             Return function value
      HTFUN1=X1+X2
      RETURN
      END


      recursive subroutine fpbisp(tx,nx,ty,ny,c,kx,ky,x,mx,y,my,
     *     z,wx,wy,lx,ly)
      implicit none
c  ..scalar arguments..
      integer nx,ny,kx,ky,mx,my
c  ..array arguments..
      integer lx(mx),ly(my)
      real*8 tx(nx),ty(ny),c((nx-kx-1)*(ny-ky-1)),x(mx),y(my),z(mx*my),
     * wx(mx,kx+1),wy(my,ky+1)
c  ..local scalars..
      integer kx1,ky1,l,l1,l2,m,nkx1,nky1, i, i1, j, j1
      real*8 arg,sp,tb,te
c  ..local arrays..
      real*8 h(6)
c  ..subroutine references..
c    fpbspl
c  ..
      kx1 = kx+1
      nkx1 = nx-kx1
      tb = tx(kx1)
      te = tx(nkx1+1)
      l = kx1
      l1 = l+1
      do 40 i=1,mx
        arg = x(i)
        if(arg.lt.tb) arg = tb
        if(arg.gt.te) arg = te
  10    if(arg.lt.tx(l1) .or. l.eq.nkx1) go to 20
        l = l1
        l1 = l+1
        go to 10
  20    call fpbspl(tx,nx,kx,arg,l,h)
        lx(i) = l-kx1
        do 30 j=1,kx1
          wx(i,j) = h(j)
  30    continue
  40  continue
      ky1 = ky+1
      nky1 = ny-ky1
      tb = ty(ky1)
      te = ty(nky1+1)
      l = ky1
      l1 = l+1
      do 80 i=1,my
        arg = y(i)
        if(arg.lt.tb) arg = tb
        if(arg.gt.te) arg = te
  50    if(arg.lt.ty(l1) .or. l.eq.nky1) go to 60
        l = l1
        l1 = l+1
        go to 50
  60    call fpbspl(ty,ny,ky,arg,l,h)
        ly(i) = l-ky1
        do 70 j=1,ky1
          wy(i,j) = h(j)
  70    continue
  80  continue
      m = 0
      do 130 i=1,mx
        l = lx(i)*nky1
        do 90 i1=1,kx1
          h(i1) = wx(i,i1)
  90    continue
        do 120 j=1,my
          l1 = l+ly(j)
          sp = 0.
          do 110 i1=1,kx1
            l2 = l1
            do 100 j1=1,ky1
              l2 = l2+1
              sp = sp+c(l2)*h(i1)*wy(j,j1)
 100        continue
            l1 = l1+nky1
 110      continue
          m = m+1
          z(m) = sp
 120    continue
 130  continue
      return
      end


module schmidTensor

USE IntrinsicTypesModule, RK=>REAL_KIND
USE ConstantsModule
USE matrixMath

IMPLICIT NONE

PUBLIC :: schmid, pschmid, qschmid

REAL(RK), ALLOCATABLE :: schmid(:, :, :)

REAL(RK), ALLOCATABLE :: pschmid(:, :, :)
REAL(RK), ALLOCATABLE :: qschmid(:, :, :)

CONTAINS

SUBROUTINE setSchmidTensor()

    IMPLICIT NONE

    REAL(RK), PARAMETER :: Z  =  RK_ZERO
    REAL(RK), PARAMETER :: P2 =  RK_ONE/RK_ROOT_2, P3 = RK_ONE/RK_ROOT_3
    REAL(RK), PARAMETER :: M2 = -P2, M3 = -P3

    !
    !  SLIP NORMAL AND DIRECTIONS.
    !
    REAL(RK), PARAMETER, DIMENSION(36) :: cub_111_dat = (/&
        &   P3, P3, P3,     P3, P3, P3,    P3, P3, P3,&
        &   P3, P3, M3,     P3, P3, M3,    P3, P3, M3,&
        &   P3, M3, P3,     P3, M3, P3,    P3, M3, P3,&
        &   P3, M3, M3,     P3, M3, M3,    P3, M3, M3 &
        &  /)
    REAL(RK), PARAMETER, DIMENSION(3, 12) :: &
        &   cub_111 = RESHAPE(SOURCE=cub_111_dat, SHAPE=(/3, 12/))
    !
    REAL(RK), PARAMETER, DIMENSION(36) :: cub_110_dat = (/&
        &  Z, P2, M2,    P2, Z, M2,    P2, M2, Z,&
        &  Z, P2, P2,    P2, Z, P2,    P2, M2, Z,&
        &  Z, P2, P2,    P2, Z, M2,    P2, P2, Z,&
        &  Z, P2, M2,    P2, Z, P2,    P2, P2, Z &
        &  /)
    REAL(RK), PARAMETER, DIMENSION(3, 12) :: &
        &   cub_110 = RESHAPE(SOURCE=cub_110_dat, SHAPE=(/3, 12/))

    !FCC Crystal only
    ALLOCATE(SCHMID(0:11, 0:2, 0:2),PSCHMID(0:11, 0:2, 0:2),QSCHMID(0:11, 0:2, 0:2))
    !
    schmid(:, 0, 0) = cub_110(1, :)*cub_111(1, :)
    schmid(:, 1, 0) = cub_110(2, :)*cub_111(1, :)
    schmid(:, 2, 0) = cub_110(3, :)*cub_111(1, :)

    schmid(:, 0, 1) = cub_110(1, :)*cub_111(2, :)
    schmid(:, 1, 1) = cub_110(2, :)*cub_111(2, :)
    schmid(:, 2, 1) = cub_110(3, :)*cub_111(2, :)

    schmid(:, 0, 2) = cub_110(1, :)*cub_111(3, :)
    schmid(:, 1, 2) = cub_110(2, :)*cub_111(3, :)
    schmid(:, 2, 2) = cub_110(3, :)*cub_111(3, :)

    call getSymMat(schmid, pschmid, 11)

    call getskewMat(schmid, qschmid, 11)

END SUBROUTINE setSchmidTensor

SUBROUTINE deallocate_schmid()

    IMPLICIT NONE

    DEALLOCATE(schmid, pschmid, qschmid)

END SUBROUTINE deallocate_schmid

end module schmidTensor


      SUBROUTINE Q4SHPS (XI,ETA, SHP, SSHP)
C     &    ENTRY Q4SHPD (DI,ETD,DSHP,DSSHP)
C
C*****
C     COMPUTES SHAPE FUNCTIONS AND THEIR DERIVATIVES
C     FOR THE QUAD4 ELEMENT
C*****
C
      REAL             XI,ETA, SHP(4), SSHP(8),CLC(2,4)
      DOUBLE PRECISION DI,ETD,DSHP(4),DSSHP(8),DLD(2,4)
      DATA   CLC /-1.0  ,-1.0  ,1.0  ,-1.0  ,1.0  ,1.0  ,-1.0  ,1.0  /
      DATA   DLD /-1.0D0,-1.0D0,1.0D0,-1.0D0,1.0D0,1.0D0,-1.0D0,1.0D0/
C
C     SINGLE PRECISION -
C
      DO 10 I=1,4
      SHP (I  ) = 0.25 * (1.0+XI *CLC(1,I)) * (1.0+ETA*CLC(2,I))
      SSHP(I  ) = 0.25 * (1.0+ETA*CLC(2,I)) * CLC(1,I)
      SSHP(I+4) = 0.25 * (1.0+XI *CLC(1,I)) * CLC(2,I)
   10 CONTINUE
      RETURN
C
      ENTRY Q4SHPD (DI,ETD,DSHP,DSSHP)
C     ================================
C
C     DOUBLE PRECISION -
C
      DO 20 I=1,4
      DSHP (I  ) = .25D0 * (1.D0+DI *DLD(1,I)) * (1.D0+ETD*DLD(2,I))
      DSSHP(I  ) = .25D0 * (1.D0+ETD*DLD(2,I)) * DLD(1,I)
      DSSHP(I+4) = .25D0 * (1.D0+DI *DLD(1,I)) * DLD(2,I)
   20 CONTINUE
      RETURN
      END


!##############################################################################
!# Tutorial 022d: Calculate an L2 and H1 error, standard integration, subdomain
!##############################################################################

module tutorial022d

  ! Include basic Feat-2 modules
  use fsystem
  use storage
  use genoutput

  use triangulation
  use meshgeneration

  use element
  use cubature
  use spatialdiscretisation
  use linearsystemscalar
  use linearsystemblock
  use bilinearformevaluation
  use derivatives
  use collection

  use derivatives
  use domainintegration
  use collection
  use pprocerror

  implicit none
  private

  public :: start_tutorial022d

contains

!****************************************************************************

!<subroutine>

  subroutine fcalc_reffunction (cderivative, rdiscretisation, &
      nelements, npointsPerElement, Dpoints, IdofsTest, rdomainIntSubset, &
      Dvalues, rcollection)

!<description>
  ! Calculates the values of the reference function in the cubature points.
!</description>

!<input>
  ! This is a DER_xxxx derivative identifier (from derivative.f90) that
  ! specifies what to compute: DER_FUNC=function value, DER_DERIV_X=x-derivative,...
  ! The result must be written to the Dvalue-array below.
  integer, intent(in) :: cderivative

  ! The discretisation structure that defines the basic shape of the
  ! triangulation with references to the underlying triangulation,
  ! analytic boundary boundary description etc.
  type(t_spatialDiscretisation), intent(in) :: rdiscretisation

  ! Number of elements, where the coefficients must be computed.
  integer, intent(in) :: nelements

  ! Number of points per element, where the coefficients must be computed
  integer, intent(in) :: npointsPerElement

  ! This is an array of all points on all the elements where coefficients
  ! are needed.
  ! DIMENSION(NDIM2D,npointsPerElement,nelements)
  ! Remark: This usually coincides with rdomainSubset%p_DcubPtsReal.
  real(DP), dimension(:,:,:), intent(in) :: Dpoints

  ! An array accepting the DOF`s on all elements trial in the trial space.
  ! DIMENSION(\#local DOF`s in trial space,Number of elements)
  integer, dimension(:,:), intent(in) :: IdofsTest

  ! This is a t_domainIntSubset structure specifying more detailed information
  ! about the element set that is currently being integrated.
  ! It is usually used in more complex situations (e.g. nonlinear matrices).
  type(t_domainIntSubset), intent(in) :: rdomainIntSubset

  ! Optional: A collection structure to provide additional
  ! information to the coefficient routine.
  type(t_collection), intent(inout), optional :: rcollection

!</input>

!<output>
  ! This array has to receive the values of the (analytical) function
  ! in all the points specified in Dpoints, or the appropriate derivative
  ! of the function, respectively, according to cderivative.
  !   DIMENSION(npointsPerElement,nelements)
  real(DP), dimension(:,:), intent(out) :: Dvalues
!</output>

!</subroutine>

    ! local variables
    integer :: ipt, iel
    real(DP) :: dx, dy

    ! What do we have to calculate? Function values? Derivatives?
    select case (cderivative)
    case (DER_FUNC)
      ! Function value
      !
      ! Loop over all elements and points on the elements
      do iel = 1,nelements
        do ipt = 1,npointsPerElement

          ! Coordinate of the point
          dx = Dpoints(1,ipt,iel)
          dy = Dpoints(2,ipt,iel)

          ! Calculate the value in the point
          Dvalues(ipt,iel) = 1.0_DP/exp(dx)

        end do
      end do

    case (DER_DERIV2D_X)
      ! X-derivative
      !
      ! Loop over all elements and points on the elements
      do iel = 1,nelements
        do ipt = 1,npointsPerElement

          ! Coordinate of the point
          dx = Dpoints(1,ipt,iel)
          dy = Dpoints(2,ipt,iel)

          ! Calculate the value in the point
          Dvalues(ipt,iel) = -1.0_DP/exp(dx)

        end do
      end do

    case (DER_DERIV2D_Y)
      ! Y-derivative
      !
      ! Loop over all elements and points on the elements
      do iel = 1,nelements
        do ipt = 1,npointsPerElement

          ! Coordinate of the point
          dx = Dpoints(1,ipt,iel)
          dy = Dpoints(2,ipt,iel)

          ! Calculate the value in the point
          Dvalues(ipt,iel) = 0.0_DP

        end do
      end do

    end select

  end subroutine

  !****************************************************************************

!<subroutine>

  subroutine fcharFunctionSubdomain (rdiscretisation, nelements,&
      npointsPerElement, Dpoints, IdofsTest, rdomainIntSubset,  Dvalues, rcollection)

!<description>
  ! Defines the characteristic function of the domain where to calculate.
  ! This is multiplied to the error/norm in the cubature point.
!</description>

!<input>
  ! The discretisation structure that defines the basic shape of the
  ! triangulation with references to the underlying triangulation,
  ! analytic boundary boundary description etc.
  type(t_spatialDiscretisation), intent(in) :: rdiscretisation

  ! Number of elements, where the coefficients must be computed.
  integer, intent(in) :: nelements

  ! Number of points per element, where the coefficients must be computed
  integer, intent(in) :: npointsPerElement

  ! This is an array of all points on all the elements where coefficients
  ! are needed.
  ! DIMENSION(NDIM2D,npointsPerElement,nelements)
  ! Remark: This usually coincides with rdomainSubset%p_DcubPtsReal.
  real(DP), dimension(:,:,:), intent(in) :: Dpoints

  ! An array accepting the DOF`s on all elements trial in the trial space.
  ! DIMENSION(\#local DOF`s in trial space,Number of elements)
  integer, dimension(:,:), intent(in) :: IdofsTest

  ! This is a t_domainIntSubset structure specifying more detailed information
  ! about the element set that is currently being integrated.
  ! It is usually used in more complex situations (e.g. nonlinear matrices).
  type(t_domainIntSubset), intent(in) :: rdomainIntSubset

  ! Optional: A collection structure to provide additional
  ! information to the coefficient routine.
  type(t_collection), intent(inout), optional :: rcollection

!</input>

!<output>
  ! This array has to receive the values of the weights in all the
  ! points specified in Dpoints, or the appropriate derivative of
  ! the function, respectively, according to cderivative.
  ! DIMENSION(npointsPerElement,nelements)
  real(DP), dimension(:,:), intent(out) :: Dvalues
!</output>

!</subroutine>

    ! local variables
    integer :: iel,ipt
    real(DP) :: dx,dy

    ! Loop over the elements in the current set.
    do iel = 1,nelements

      ! Loop over all cubature points on the current element
      do ipt = 1,npointsPerElement

        ! Get the coordinates of the point
        dx = Dpoints(1,ipt,iel)
        dy = Dpoints(2,ipt,iel)

        ! Characteristic function of a part of the domain.
        if (dx .le. 0.25_DP) then
          Dvalues(ipt,iel) = 1.0_DP
        else
          Dvalues(ipt,iel) = 0.0_DP
        end if

      end do ! icubp

    end do ! iel

  end subroutine

  ! ***************************************************************************

  subroutine start_tutorial022d

    ! Declare some variables.
    type(t_triangulation) :: rtriangulation
    type(t_spatialDiscretisation) :: rspatialDiscr
    type(t_blockDiscretisation) :: rblockDiscr
    type(t_scalarCubatureInfo), target :: rcubatureInfo
    type(t_vectorBlock) :: rx

    integer :: ivt
    real(DP) :: dx, dintvalue
    real(DP), dimension(:,:), pointer :: p_DvertexCoords
    real(DP), dimension(:), pointer :: p_Ddata

    ! Print a message
    call output_lbrk()
    call output_separator (OU_SEP_STAR)
    call output_line ("This is FEAT-2. Tutorial 022d")
    call output_separator (OU_SEP_MINUS)

    ! =================================
    ! Create a brick mesh
    ! =================================

    ! The mesh must always be in "standard" format.
    ! First create a 9x9-mesh on [0,1]x[0,1], then convert to standard.
    call meshgen_rectangular2DQuadMesh (rtriangulation, 0.0_DP, 1.0_DP, 0.0_DP, 1.0_DP, 8, 8)
    call tria_initStandardMeshFromRaw (rtriangulation)

    ! =================================
    ! Discretise with Q1.
    !
    ! Create a structure rspatialDiscr
    ! which describes the discretisation.
    ! We generate a 1x1 system with Q1.
    ! =================================

    ! Create a spatial discretisation with Q1
    call spdiscr_initDiscr_simple (rspatialDiscr,EL_Q1_2D,rtriangulation)

    ! Create a block discretisation with 1 block Q1.
    call spdiscr_initBlockDiscr (rblockDiscr,rtriangulation)
    call spdiscr_appendBlockComponent (rblockDiscr,rspatialDiscr)
    call spdiscr_commitBlockDiscr (rblockDiscr)

    ! =================================
    ! Create a scalar vector.
    ! =================================

    ! Create a vector.
    call lsysbl_createVector (rblockDiscr,rx)

    ! =================================
    ! Fill the vector with data.
    ! =================================

    ! Get a pointer to the data.
    call lsyssc_getbase_double (rx%RvectorBlock(1),p_Ddata)

    ! Get a pointer to the point coordinates.
    call storage_getbase_double2d (rtriangulation%h_DvertexCoords,p_DvertexCoords)

    ! Set the entries of the vector according to the function
    !    u(x,y) = 1/exp(x)
    do ivt=1,rx%NEQ
      dx = p_DvertexCoords(1,ivt)
      p_Ddata(ivt) = 1.0_DP / exp(dx)
    end do

    ! =================================
    ! Define cubature formula
    ! =================================

    ! Use a Gauss 3x3 formula for the discretisation.
    call spdiscr_createDefCubStructure (rspatialDiscr,rcubatureInfo,CUB_GEN_AUTO_G3)

    ! =================================
    ! Calculate the L2-error of u
    ! =================================

    ! Calculate the error.
    call pperr_scalar (PPERR_L2ERROR, dintvalue, rx%RvectorBlock(1), &
        fcalc_reffunction,ffunctionWeight=fcharFunctionSubdomain, &
        rcubatureInfo=rcubatureInfo)

    call output_line ("L2-error = "//trim(sys_sdEL(dintvalue,10)))

    ! =================================
    ! Calculate the H1-(semi)error of u
    ! =================================

    ! Calculate the error.
    call pperr_scalar (PPERR_H1ERROR, dintvalue, rx%RvectorBlock(1), &
        fcalc_reffunction,ffunctionWeight=fcharFunctionSubdomain, &
        rcubatureInfo=rcubatureInfo)

    call output_line ("H1-error = "//trim(sys_sdEL(dintvalue,10)))

    ! =================================
    ! Cleanup
    ! =================================

    ! Release the vector
    call lsysbl_releaseVector (rx)

    ! Cubature done.
    call spdiscr_releaseCubStructure (rcubatureInfo)

    ! Release the discretisation
    call spdiscr_releaseBlockDiscr (rblockDiscr)
    call spdiscr_releaseDiscr (rspatialDiscr)

    ! Release the triangulation
    call tria_done (rtriangulation)

  end subroutine

end module


      PROGRAM EI2RSI
C
C	THIS ROUTINE PLOTS OR PRINTS THE DISPERSION RELATION FOR
C	THE ELECTRON-ION TWO-ROTATING-STREAM INSTABILITY, DAVIDSON
C	TNNP SECT 2.9.3, EQN. 2.9.13  (LHS-RHS) WITH KZ = 0, L = 1.
C	FREQUENCIES ARE RATIOS TO ION PLASMA FREQUENCY.
C
C	LINK WITH PLTLIB,FLILO, OR FAKEPL IF DESIRED
C
	LOGICAL*1 TIM(8),DAT(9)
	LOGICAL ITITL(8)
	COMPLEX W,DEQ,DEN1,DEN2
	BYTE STRING(132)
      COMMON /POLEBK/ WPOLE(20),WP2(10),XD(80)
      DIMENSION XNUA2(10),WALF(10),WC(10),WP(10)
      DIMENSION RME(10),DENS(10),SWALF(10),BETAZ(10),WCS(20)
	DIMENSION NDEQP(4),IPL(2),ROOTJ(5)
	EQUIVALENCE (XD(1),XKZ),(XD(2),WCE),(XD(3),RP),(XD(4),RC)
	EQUIVALENCE (XD(5),WR),(XD(6),WI),(XD(7),RWR)
	EQUIVALENCE (XD(8),AZL),(XD(9),XNC)
	EQUIVALENCE (XD(11),RME(1)),(XD(21),DENS(1)),(XD(31),BETAZ(1))
	EQUIVALENCE (XD(41),SWALF(1))
     	EQUIVALENCE (XD(54),BBX),(XD(55),BBY),(XD(56),XSOLV)
        EQUIVALENCE (XD(64),WTR),(XD(65),WTI)
      DATA ITITL /'MISC','MASS','DENS',' VZ ','SIGN',2*'MISC','ROOT'/
      DATA NC /2/
      DATA AZL /1./
      DATA XKZ /0./
      DATA RP,RC /.0084,.336/
      DATA WR,WI /3.1,0./
      DATA RWR /1.1/
      DATA WCE /2./
      DATA RME /-1.,51400.,8*1. /
      DATA DENS /1.,1.,8*1. /
      DATA SWALF /-1.,1.,-1.,1.,6*1./
      DATA BETAZ /3*0.,.0,6*0./
      DATA BBX,BBY /.0001,1./
      DATA XD(52), XD(53) /-500., 500./
      DATA XD(57) /6./
C     XD(58) IS NPP = NO. OF POINTS TO BE PLOTTED
      DATA XD(58) /365./
      DATA XSOLV /3./
      DATA TWOPI /6.2831859/
      DATA NDEQP/4*512/
      DATA IPL/2*115/
      DATA ROOTJ /2.404826,3.831706,5.135,6.380,7.588/
C	XD(67)=0. IS CRT,  = 1. IS PAPER PLOT
      DATA XD(67) /1./
      DATA XD(68) /1./
      DATA DEQS,DEQSS /1.,1./
C
  201	CONTINUE
	DO 203 I = 1,24
  203	WRITE(7,1013)
 1013	FORMAT(' -')
      CALL SCOPE
  202	IF(XD(67).LT..5) CALL SCOPST('F','S',2,0,'P','P',IER)
	CALL DATE(DAT)
	CALL TIME(TIM)
	ENCODE(132,104,STRING) DAT,TIM
	IF(XD(67).GT..5) CALL PLTPRT(STRING)
  104   FORMAT('0 PROGRAM EI2RES',5X,9A1,5X,8A1)
C	OPEN(UNIT=3,NAME='EI2RES.DAT',TYPE='NEW')
	XNC = NC
C
 200	CONTINUE
C	WRITE (6,701)
 701	FORMAT(' STEP 1, MANUAL CHOICE OF INITIAL PARAMETERS')
 101	WRITE (6,702)
 702	FORMAT(' TYPE NO. ,NEW VALUE OF VARIABLE TO BE CHANGED, 0 FOR NO
     1 CHANGE '$)
	READ (5,501) ND,XTT
 501	FORMAT(I5,F15.5)
	IF(ND.EQ.0) GO TO 102
	WRITE(6,502) ND,XD(ND),XTT
	ENCODE(132,502,STRING) ND,XD(ND),XTT
	IF(XD(67).GT..5) CALL PLTPRT(STRING)
 502	FORMAT(' CHANGE VARIABLE NO.',I3,' FROM',F15.5' TO',F15.5)
	XD(ND) = XTT
	IF(XD(56).GT.4.5) STOP
	GO TO 101
 102	NC = XNC + .5
	WS = XD(52)
C
        ENCODE(132,105,STRING)
  105   FORMAT(' INPUT VARIABLES')
	IF(XD(67).GT..5) CALL PLTPRT(STRING)
	DO 73 JJ = 1,7
	KK = 10*JJ-9
        ENCODE(132,1016,STRING) KK,ITITL(JJ),(XD(KK+N),N=0,9)
	IF(XD(67).GT..5) CALL PLTPRT(STRING)
   73   CONTINUE
 1016   FORMAT(I5,2X,A4,10E12.4)
C
C     CALCULATE PLASMA AND CYCLOTRON FREQS.
      ENCODE(132,1003,STRING)
	IF(XD(67).GT..5) CALL PLTPRT(STRING)
 1003 FORMAT(3X,'NO.',5X,'DENS',7X,'BETAZ',9X,
     1  'WP',10X,'WC',7X,'W ALPHA',6X,'W A/WC')
	RTRM = SQRT(ABS(RME(2)/RME(1)))
      DO 10 N = 1,NC
      WC(N) = WCE*RTRM/RME(N)
      WP2(N) = DENS(N)*RME(2)/ABS(RME(N))
      WP(N) = SQRT(ABS(WP2(N)))
   10 CONTINUE
C
C     CALCULATE WALF (TNP EQ. 2.7.3) AND POLES
C
      DO 20 N = 1,NC
      ST = 0.
      DO 21 M = 1,NC
      ST = ST + SIGN(1.,RME(M))*DENS(M)/WC(N)**2/RME(N)
   21 CONTINUE
C	PRINT 1002,N,ST
      STT = SQRT(1. - 2.*ST)
      WALF(N) = -.5*WC(N)*(1. + SIGN(STT,SWALF(N)))
      WAWC = WALF(N)/WC(N)
      NN = N
      ENCODE(132,1002,STRING) NN,DENS(N),BETAZ(N),WP(N),WC(N),WALF(N)
     1 ,WAWC
	IF(XD(67).GT..5) CALL PLTPRT(STRING)
      WPOLE(2*N-1) = XKZ*BETAZ(N) + AZL*WALF(N)
      WCS(2*N-1) = ABS(WC(N))
      WPOLE(2*N) = WPOLE(2*N-1) - WC(N) - 2.*WALF(N)
      WCS(2*N) = ABS(WC(N))
   20 CONTINUE
 1002 FORMAT(I5,6E12.4)
	F = DENS(2)/DENS(1)
	ENCODE(132,1018,STRING) F,WCE
 1018	FORMAT(' f = ',F7.3,',   Wce/Wpe =',F7.3)
	CALL PLTPRT(STRING)
	FR2I = 2.*RME(2)/WCE**2
	FR2E = 2./WCE**2
	WEP = .5*WCE*RTRM*(1.+SQRT(1.- FR2E*(1.-F)))
	WEN = .5*WCE*RTRM*(1.-SQRT(1.- FR2E*(1.-F)))
	WIP = -.5*WCE*(1.+SQRT(1.+ FR2I*(1.-F)))/RTRM
	WIN = -.5*WCE*(1.-SQRT(1.+ FR2I*(1.-F)))/RTRM
	WPOLE(1) = WEP
	WPOLE(2) = WEN
	WPOLE(3) = WIP
	WPOLE(4) = WIN
	ENCODE(132,1017,STRING) WEP,WEN,WIP,WIN
 1017   FORMAT(' POLES',4E13.4)
	CALL PLTPRT(STRING)
      NW10S = 10.*XD(52) - .0001
      NWS = XD(52) - .0001
      WEV2 = (WALF(1)-WALF(2))**2
C	THE FOLLOWING ASSUMES M = LOWEST VALUE
      L = AZL + .5
      LL = MIN0(L+1,5)
      PLM = ROOTJ(LL)
      IF(LL.GT.5) PLM = AZL + 1.85575*AZL**(1./3.)
      XKPER = PLM/RP
      XK2 = XKZ**2 + XKPER**2
      RKPAR2 = XKZ**2/XK2
      RKPER2 = XKPER**2/XK2
      ENCODE(132,1012,STRING) XKZ,XKPER
	IF(XD(67).GT..5) CALL PLTPRT(STRING)
 1012 FORMAT('  KZ*C/WP =',E13.5,' KX*C/WP =',E13.5)
	IF(XD(67).GT..5) CALL PLTFST('L',4,0,'ELECTRON-ION TWO-ROTATING
     1-STREAM DISPERSION RELATION',IER,' -1  0   1')
      NPT = XD(58) + .5
      IF(XD(67).LT..5) NPT = 512
      DO 32 I = 0,NPT
      WT = XD(52) + I*(XD(53)-XD(52))/MAX0(NPT,1)
      W = CMPLX(WT,WI)
      DEQ = 1./(1.-(RP/RC)**2)
      DEN1 = 2.*(W-WEP)*(W-WEN)
C      IF(DEN1.NE.0.) DEQ = DEQ - WP2(1)/DEN1
      DEQ = DEQ - WP2(1)/DEN1
      DEN2 = 2.*(W-WIP)*(W-WIN)
C      IF(DEN2.NE.0.) DEQ = DEQ - WP2(2)/DEN2
      DEQ = DEQ - WP2(2)/DEN2
C	IF(DEN1.EQ.0.OR.DEN2.EQ.0.) DEQ = 0.
 	NDEQP(1) = 32.*FLILO(DEQ,BBY) + 512.5
	IPL(1) = 16.*FLILO(DEQ,BBY) + 115.5
	IPL(1) = MAX0(IPL(1),0)
	IPL(1) = MIN0(IPL(1),230)
C     PRINT ROOTS ON SCREEN IF XD(68).EQ.1.
	DEQT = DEQ
	IF(DEQT*DEQS.GT.0.) GO TO 33
	IF((DEQSS-DEQS)*(DEQS-DEQT).LE.0.) GO TO 33
	IF(XD(68).GT..5) WRITE(7,1014) W,WS
 1014 FORMAT(' ROOT BETWEEN '2E13.5)
   33 CONTINUE
      WS = W
      DEQSS = DEQS
      DEQS = DEQ
C     PUT TIC MARKS AT INTEGRAL PLASMA FREQ. AND TENTHS
      ITIC = 1
      NW10 = 10.*W
      IF(NW10.NE.(NW10S)) ITIC = 8
      NW10S = NW10
      NW = W
      IF(NW.NE.NWS) ITIC = 0
      NWS = NW
	IF(XD(67).GT..5) CALL PLOTF(NDEQP,ITIC,IERR)
	IF(XD(67).LT..5) CALL SCOPLT(IPL)
   32 CONTINUE
	IF(XD(67).GT..5) CALL CLOSEF(1)
C      CLOSE(UNIT=3)
      GO TO 201
   80 STOP
      END
      SUBROUTINE BEAMWK(W,DEQ,DMAG)
C
	COMPLEX W,DEQ,DEN1,DEN2
      COMMON /POLEBK/ WPOLE(20),WP2(10),XD(80)
	EQUIVALENCE (XD(1),XKZ),(XD(2),WCE),(XD(3),RP),(XD(4),RC)
	EQUIVALENCE (WPOLE(1),WEP),(WPOLE(2),WEN)
	EQUIVALENCE (WPOLE(3),WIP),(WPOLE(4),WIN)
C
      DEQ = 1./(1.-(RP/RC)**2)
      DEN1 = 2.*(W-WEP)*(W-WEN)
C      IF(DEN1.NE.0.) DEQ = DEQ - WP2(1)/DEN1
      DEQ = DEQ - WP2(1)/DEN1
      DEN2 = 2.*(W-WIP)*(W-WIN)
C      IF(DEN2.NE.0.) DEQ = DEQ - WP2(2)/DEN2
      DEQ = DEQ - WP2(2)/DEN2
	RETURN
	END
      SUBROUTINE POLY(W,DEQ,DMAG)
C
C     THIS ROUTINE REMOVES THE POLES FROM DEQ
C
      COMMON /POLEBK/ WPOLE(20),NPOLE
      COMPLEX W,DEQ,DEQS
      DATA IR,JR /0,0/
      CALL BEAMWK(W,DEQ,DMAG)
      DEQS = DEQ
      IF(CABS(W).GT.50.) W=.001*CMPLX(RAN(IR,JR),RAN(IR,JR))
      DO 10 N = 1,NPOLE
      DEQ = DEQ*(W-WPOLE(N))
      DMAG = DMAG*CABS(W-WPOLE(N))
  10  CONTINUE
C      PRINT 100,W,DEQ,DEQS,DMAG
 100  FORMAT(' POLY W=',2E12.4,' DEQ,DEQS=',4E12.4,' DMAG=',E12.4)
      RETURN
      END


! THIS VERSION: GALAHAD 2.1 - 22/03/2007 AT 09:00 GMT.
   PROGRAM GALAHAD_LSQP_EXAMPLE
   USE GALAHAD_LSQP_double                       ! double precision version
   IMPLICIT NONE
   INTEGER, PARAMETER :: wp = KIND( 1.0D+0 ) ! set precision
   REAL ( KIND = wp ), PARAMETER :: infinity = 10.0_wp ** 20
   TYPE ( QPT_problem_type ) :: p
   TYPE ( LSQP_data_type ) :: data
   TYPE ( LSQP_control_type ) :: control
   TYPE ( LSQP_inform_type ) :: info
   INTEGER, PARAMETER :: n = 16, m = 8, a_ne = 53
   INTEGER :: i, s

! start problem data
   ALLOCATE( p%X_l( n ), p%X_u( n ), p%G( n ), p%WEIGHT( n )  )
   ALLOCATE( p%C( m ), p%C_l( m ), p%C_u( m ) )
   ALLOCATE( p%X( n ), p%Y( m ), p%Z( n ) )
   ALLOCATE( p%A%val( a_ne ), p%A%row( a_ne ), p%A%col( a_ne ) )
   p%new_problem_structure = .TRUE.           ! new structure
!  p%gradient_kind = 2
!  p%Hessian_kind = 2
   p%gradient_kind = 2
   p%Hessian_kind = 2
   p%n = n ; p%m = m ; p%f = 0.0_wp           ! dimensions & objective constant
   CALL SMT_put( p%A%type, 'COORDINATE', s )  ! storage for H and A
   p%A%ne = a_ne
   READ( 5, "( ( 5ES12.4 ) )" ) p%G( : p%n )
!  p%G = 0.01 * p%G
   READ( 5, "( ( 5ES12.4 ) )" ) p%WEIGHT( : p%n )
   p%WEIGHT = SQRT( p%WEIGHT ) ;
   READ( 5, "( ( 5ES12.4 ) )" ) p%X_l( : p%n )
   READ( 5, "( ( 5ES12.4 ) )" ) p%X_u( : p%n )
   READ( 5, "( ( 2( 2I8, ES12.4 ) ) )" )                      &
     ( p%A%row( i ), p%A%col( i ), p%A%val( i ), i = 1, p%A%ne )
   READ( 5, "( 5ES12.4 ) )" ) p%C_l( : p%m )
   READ( 5, "( 5ES12.4 ) )" ) p%C_u( : p%m )

! integer components complete
   CALL LSQP_initialize( data, control )      ! Initialize control parameters
   control%infinity = infinity                ! Set infinity
   control%restore_problem = 1                ! Restore vector data on exit
   control%print_level = 1
   control%maxit = 1000
!  control%muzero = 0.0001
   p%X = 0.0_wp
   p%Y = 0.0_wp ; p%Z = 1000.0_wp                   ! start multipliers from zero
! sparse co-ordinate storage format: real components
! real components complete
     ALLOCATE( p%X0( n ) ) ; p%X0 = 0.0
     CALL LSQP_solve( p, data, control, info )     ! Solve problem
     IF ( info%status == 0 ) THEN                  ! Successful return
         WRITE( 6, "( ' Eg ', I6, ' iterations. Optimal objective value =',&
        &       ES12.4, /, ' Optimal solution = ', ( 5ES12.4 ) )" )            &
         info%iter, info%obj, p%X
     ELSE                                          !  Error returns
       WRITE( 6, "( ' LSQP_solve exit status = ', I6 ) " ) info%status
     END IF
   CALL LSQP_terminate( data, control, info )      !  delete internal workspace
   END PROGRAM GALAHAD_LSQP_EXAMPLE