      SUBROUTINE FA1PKE (KHH,BHH,MHH,BXHH,FSAVE,NLOOP,BREF,RREF,NEIW,
     1                   EPS)
C
C     FA1PKE COMPUTES THE EIGENVALUES FOR THE PK METHOD
C
C     LAST REVISED  2/91, BY J.PETKAS/LOCKHEED
C     ELEMENTS OF INTERPOLATION MATRIX IN D.P. AND LEAST SQUARE FIT
C
      LOGICAL          EIGV
      INTEGER          BHH,BXHH,SYSBUF,NAME(2),TRL(7),BUF1,FLOOP,FSAVE
      REAL             KINT
      DOUBLE PRECISION DX1,DX2,DSUM,DZ(1)
      CHARACTER        UFM*23,UWM*25,UIM*29,SFM*25
      COMMON /XMSSG /  UFM,UWM,UIM,SFM
      COMMON /SYSTEM/  SYSBUF,NOUT
      COMMON /UNPAKX/  IOUT,INN,NNN,INCR1
      COMMON /ZZZZZZ/  Z(1)
      COMMON /FA1PKC/  NCORE,NK,IMVR,IK,IA,IQ,ICP,IFLAG
      COMMON /BLANK /  FLOOP
      COMMON /CONDAS/  PI,TWOPI
      EQUIVALENCE      (Z(1),DZ(1))
      DATA    NAME  /  4HFA1P,4HKE  /
      DATA    ISTART/  0 /
C
C     REINITIALIZE EVERY TIME MACH CHANGES
C
      IF (IFLAG .EQ. 0) GO TO 100
      CALL SSWTCH (39,L39)
      TRL(1) = KHH
      CALL RDTRL (TRL)
      NROW  = TRL(2)
      NEIW  = MIN0(NEIW,NROW)
      NEIGN = NROW*2
      IOUT  = 1
      INN   = 1
      INCR1 = 1
      NNN   = NROW
      IEIGNS= NCORE  - NROW*5 - 1
      BUF1  = IEIGNS - SYSBUF
      NN    = NROW*NROW
      NN2   = NN*2
      IMH   = ICP
      IBH   = IMH + NN
      IKH   = IBH + NN
      IV    = IKH + NN
      IB    = IV  + NN
      IMA   = IB  + NN
      IF (MOD(IMA,2) .EQ. 0) IMA = IMA + 1
      IOP   = IMA + NN2*4
C
C     CORE CHECK
C
      IF (IOP+SYSBUF .GT. IEIGNS) CALL MESAGE (-8,0,NAME)
C
C     PUT K B M IN CORE
C
      IFL = KHH
      JI  = IKH
   10 CALL GOPEN (IFL,Z(BUF1),0)
      DO 20 I = 1,NROW
      CALL UNPACK (*15,IFL,Z(JI))
      GO TO 20
   15 CALL ZEROC (Z(JI),NROW)
   20 JI = JI + NROW
      CALL CLOSE (IFL,1)
      IF (IFL .EQ. MHH) GO TO 40
      IF (IFL .EQ. BHH) GO TO 30
      IFL = BHH
      JI  = IBH
      TRL(1) = BHH
      CALL RDTRL (TRL)
      IF (TRL(1) .GT. 0) GO TO 10
      CALL ZEROC (Z(JI),NN)
   30 IFL = MHH
      JI  = IMH
      GO TO 10
   40 CONTINUE
C
C     MODIFICATION FOR LEVEL 17.7 UPDATE
C     REPLACE CALLS TO INVAER WITH CALLS TO INVERS.
C     NO NEED TO COMPUTE DETERMINANT SINCE IT IS NOT USED SUBSEQUENTLY.
C
      ISING = -1
      CALL INVERS (NROW,Z(IMH),NROW,0,0,DET,ISING,Z(IOP))
      IF (ISING .EQ. 2) CALL MESAGE (-7,0,NAME)
C
C     START OF LARGE LOOP WITH K = 0.0
C
  100 KINT = 0.0
      IF (EPS .LE. 0.0) EPS = .001
      KN1 = NK + 1
      IQ0 = IEIGNS - (NN2+1)
      IC0 = IQ0 - KN1*2 - 2
      IF (MOD(IC0,2) .EQ. 0) IC0 = IC0 - 1
      IP0 = IC0 - KN1*2 - 2
      IF (MOD(IP0,2) .EQ. 0) IP0 = IP0 - 1
C
      I   = (FLOOP-1)*3
      EIGV= .FALSE.
      IF (Z(IMVR+I+1) .LT. 0.0) EIGV = .TRUE.
      VEL = ABS(Z(IMVR+I+1))
      VELS= VEL*VEL
      RHO = (RREF*Z(IMVR+I+2))/2.0
      IF (L39 .NE. 0) WRITE (NOUT,105) FLOOP,Z(IMVR+I),Z(IMVR+I+1),
     1                                 Z(IMVR+I+2)
  105 FORMAT ('0 TRACE FOR PK METHOD LOOP',I5,6X,4HMACH,8X,
     1        8HVELOCITY,8X,7HDENSITY,/,30X,1P,E15.5,1P,E15.5,1P,E15.5)
      NIT   = 0
      NROOT = 0
C
C     INITIALIZE LEAST SQUARE COEFFCIENTS
C
      XAV   = 0.
      YAV1  = 0.
      X10   = 0.
      X11   = 0.
      X12   = 0.
      Y10   = 0.
      Y11   = 0.
C
C     BUILD P
C
  110 CONTINUE
      NIT = NIT + 1
C
C     SUM LEAST SQUARE COEFFICIENTS ASSOCIATED WITH INDEPENDENT
C     VARIABLE STARTING WITH SECOND TRIAL
C
      IF (NIT .EQ. 1) GO TO 115
      XAV = XAV + KINT
      X10 = X10 + 1.
      X11 = X11 + KINT
      X12 = X12 + KINT**2
C
  115 IP0D = IP0/2 + 1
      DX1  = KINT
      DO 120 I = 1,NK
      DX2 = Z(IK+I-1)
      DZ(IP0D+I) = DABS((DX1-DX2)**3) + (DX1+DX2)**3
  120 CONTINUE
      DZ(IP0D+KN1) = 1.D0
C
C     FIND C = A-1  P
C
      IAD  = IA/2  + 1
      IC0D = IC0/2 + 1
      L = IAD
      DO 135 I = 1,KN1
      DSUM = 0.D+0
      DO 130 J = 1,KN1
      DSUM = DSUM + DZ(L)*DZ(IP0D+J)
      L = L + 1
  130 CONTINUE
      DZ(IC0D+I) = DSUM
  135 CONTINUE
C
C     FIND QR AND QI = Q  C  Q IS COLUMN STORED
C
      L = IQ
      DO 145 I = 1,NN2
      DSUM = 0.D+0
      DO 140 J = 1,NK
      K = L + (J-1)*NN2
      DSUM = DSUM + Z(K)*DZ(IC0D+J)
  140 CONTINUE
      L = L + 1
      Z(IQ0+I) = DSUM
  145 CONTINUE
C
C     COLUMN STORED M-1  BHH  KNH  QR (Z(IQ0+1)   QI (Z(IQ3+NN+1)
C
C     B  =  -BHH  + RHO*BREF*VEL  QHHI
C
C     K  =  -KHH  + RHO*VELS      QHHR
C
C     BUILD  A
C                  0         I
C
C                   -1       -1
C                 -M K     -M B
C
      NREM = IQ0 - IOP
      IF (NREM-NN .LE. 0) CALL MESAGE (-8,0,NAME)
      IT = IOP
      IF (MOD(IT,2) .EQ. 0) IT = IT + 1
      IF (EIGV .AND. IT+NN.GT.BUF1) CALL MESAGE (-8,0,NAME)
      BOV = BREF/VEL
      RBV = RHO*BREF*VEL
      IQR = IQ0
      IQI = IQ0 + NN
      RVS = RHO*VELS
C
C     BUILD M-1K IN IB AND M-1B IN IT  THEN GMMATS INTO IV AND IB
C
      DO 150 I = 1,NN
      Z(IT+I-1) = -Z(IBH+I-1) + RBV*Z(IQI+I)
      Z(IB+I-1) = -Z(IKH+I-1) + RVS*Z(IQR+I)
  150 CONTINUE
      CALL GMMATS (Z(IB),NROW,NROW,0,Z(IMH),NROW,NROW,0,Z(IV))
      CALL GMMATS (Z(IT),NROW,NROW,0,Z(IMH),NROW,NROW,0,Z(IB))
C
C     CALL FA1PKA TO MAKE A MATRIX AND GET EIGENVALUES
C
      CALL FA1PKA (Z(IMA),Z(IV),Z(IB),Z(IT),IEIGNS-IT,NROW)
C
C     SORT EIGENVALUES
C
      J = NEIGN*2
      CALL RSORT (2,1,Z(IT),J)
      CALL RSORT (2,2,Z(IT),J)
      IF (KINT .NE. 0.0) GO TO 180
      NLFT = NEIGN
      DO 160 I = 1,J,2
      IF (Z(IT+I) .GE. 0.0) GO TO 170
      NLFT = NLFT - 1
  160 CONTINUE
  170 NL = IT + (NEIGN-NLFT)*2
      NR = 0
      DO 175 I = 1,J,2
      IF (Z(IT+I) .NE. 0.0) GO TO 175
      NR = NR + 1
      IF (EIGV) CALL FA1PKV (Z(IMA),Z(IV),Z(IB),NROW,Z(IT+I-1),Z(IMA),
     1                       BREF,PI,VEL,Z(BUF1))
  175 CONTINUE
      NRS = NR + 1
      NR  = NR/2
      NRA = 0
  180 CONTINUE
      IF (L39 .EQ. 0) GO TO 200
      WRITE  (NOUT,182) KINT
  182 FORMAT (1H0,29H ESTIMATED REDUCED FREQUENCY ,1P,E15.5, /10X,
     1        11HEIGENVALUES,10X,18H REDUCED FREQUENCY,4X,9HFREQUENCY,
     2        6X,8H DAMPING,/,7X,4HREAL,10X,4HIMAG)
      DO 190 I = 1,J,2
      ER = Z(IT+I-1)
      EI = Z(IT+I  )
      IF (EI .EQ. 0.0) GO TO 183
      RK = BOV*EI
      RF = (1.0/TWOPI)*EI
      RG = (2.0*ER)/EI
      GO TO 185
  183 RK = 0.0
      RF = 0.0
      RG = (BREF/(PI*VEL))*ER
  185 WRITE  (NOUT,186) ER,EI,RK,RF,RG
  186 FORMAT (1H ,1P,E15.5,1P,E15.5,3X,1P,E15.5,1P,E15.5,1P,E15.5)
  190 CONTINUE
C
C     ROOT ACCEPTANCE AND SAVING
C
  200 J = NLFT*2
      L = NROOT*2 + 1 + NRA*2
      IMHERE = 200
      IF (L .GT. J) GO TO 360
C
      DO 270 I = L,J,2
      K = (NROOT*5) + 1 + IEIGNS
      IF (Z(NL+I) .NE. 0.0) GO TO 220
      IF (KINT    .NE. 0.0) GO TO 220
      IF (NRS .NE. NR) NRS = NRS - 1
      IF (NRS .NE. NR) GO TO 270
      NRA = NRA + 1
      Z(K  ) = Z(NL+I-1)
      Z(K+1) = Z(NL+I  )
      Z(K+2) = 0.0
      Z(K+3) = 0.0
      Z(K+4) = (BREF/(.34657*VEL))*Z(NL+I-1)
  210 NROOT  = NROOT + 1
C
C     PRINT EIGENVECTORS IF ASKED FOR
C
      NIT = 0
C
C     NO. OF ITERATIONS RESET TO ZERO. RE-INITIALIZE LEASE SQUARE COEFF.
C
      XAV = 0.
      YAV1= 0.
      X10 = 0.
      X11 = 0.
      X12 = 0.
      Y10 = 0.
      Y11 = 0.
      IF (NROOT .GE. NEIW) GO TO 300
      GO TO 270
  220 RKTST = BOV*Z(NL+I)
      IF (ABS(RKTST-KINT) .LT. EPS) GO TO 230
      IF (RKTST .EQ. 0.0) GO TO 230
C
C     SUM LEAST SQUARE COEFFICIENTS ASSOCIATED WITH DEPENDENT VARIABLE
C     STARTING WITH RESULT OF SECOND TIRAL
C
      IF (NIT .EQ. 1) GO TO 225
      YAV1 = YAV1 + RKTST
      Y10  = Y10  + RKTST
      Y11  = Y11  + RKTST*KINT
  225 KINT = RKTST
      IF (NIT .EQ. 10) GO TO 240
      GO TO 110
C
C     START LOOP OVER
C
  230 Z(K  ) = Z(NL+I-1)
      Z(K+1) = Z(NL+I  )
      Z(K+2) = RKTST
      Z(K+3) = (1.0/TWOPI)*Z(NL+I)
      IF (Z(NL+I) .NE. 0.0) Z(K+4) = (2.0*Z(NL+I-1))/Z(NL+I)
      IF (Z(NL+I) .EQ. 0.0) Z(K+4) = (BREF/(.34657*VEL))*Z(NL+I-1)
      IF (EIGV) CALL FA1PKV (Z(IMA),Z(IV),Z(IB),NROW,Z(K),Z(IMA),
     1                       BREF,PI,VEL,Z(BUF1))
      GO TO 210
C
C     FAILURE TO CONVERGE. REPLACE LOOP END WITH LEAST SQUARES FIT
C
  240 NIT  = NIT + 1
      XAV1 = XAV/(NIT-2)
      XAV  = (XAV + RKTST)/(NIT-1)
      YAV1 = YAV1/(NIT-2)
      D1   = X12*X10  - X11*X11
      A11  = (X10*Y11 - X11*Y10)/D1
      A10  = (X12*Y10 - X11*Y11)/D1
      RKTST= -A10/(A11-1.)
      WRITE  (NOUT,250) UWM,NIT,FLOOP,NROOT,NEIW
  250 FORMAT (A25,', PK METHOD FIALED TO CONVERGE', /1X,I4,
     1       ' ITERATIONS ON LOOP',I5,',  FOUND',I5,',  ROOTS WANTED',
     2       I5, /5X,'LEAST SQUARES FIT APPROXIMATION IMPLEMENTED.')
      IF (L39 .EQ. 1) WRITE (NOUT,260) XAV1,YAV1,XAV, A11,A10,RKTST
  260 FORMAT (/5X,'AVG. TRIAL = ',1P,E12.5,',  AGV. RESLT. = ',1P,E12.5,
     4   ',  NET AVG. = ',1P,E12.5,  //9X,'SLOPE = ',1P,E12.5,
     5   ',    INTERCEPT = ',1P,E12.5,',  VALUE    = ',1P,E12.5)
      GO TO 230
C
  270 CONTINUE
C
C     LOGIC ERROR
C
      IMHERE = 270
      GO TO 360
C
C     SAVE EIGENVALUES ON BXHH
C
  300 IF (ISTART .NE. 0) GO TO 310
      ISTART = 1
      CALL GOPEN (BXHH,Z(BUF1),1)
      CALL CLOSE (BXHH,2)
  310 CALL GOPEN (BXHH,Z(BUF1),3)
      CALL WRITE (BXHH,Z(IEIGNS+1),NROOT*5,1)
      IF (FLOOP .GE. NLOOP) GO TO 320
      CALL CLOSE (BXHH,3)
      RETURN
C
C     LAST LOOP BUILD FSAVE
C
  320 CALL CLOSE (BXHH,1)
      IBUF2 = BUF1 - SYSBUF
      CALL GOPEN (BXHH,Z(BUF1),0)
      CALL GOPEN (FSAVE,Z(IBUF2),0)
      CALL SKPREC (FSAVE,3)
      CALL CLOSE (FSAVE,2)
      CALL GOPEN (FSAVE,Z(IBUF2),3)
  330 CALL READ  (*350,*340,BXHH,Z(1),IBUF2,1,NWR)
  340 CALL WRITE (FSAVE,Z(1),NWR,1)
      GO TO 330
  350 CALL CLOSE (BXHH,1)
      CALL CLOSE (FSAVE,1)
      TRL(1) = FSAVE
      TRL(2) = NLOOP
      TRL(7) = NEIW
      CALL WRTTRL (TRL)
      GO TO 400
C
  360 WRITE  (NOUT,370) SFM,IMHERE,L,J
  370 FORMAT (A25,'. ERROR IN FA1PKE/@',I3,'  L,J=',2I7)
      CALL MESAGE (-61,0,0)
C
  400 RETURN
      END


SUBROUTINE DPTSVX_F95(D, E, B, X, DF, EF, FACT, FERR, BERR, RCOND, INFO)
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS ..
   USE LA_PRECISION, ONLY: WP => DP
   USE LA_AUXMOD, ONLY: LSAME, ERINFO
   USE F77_LAPACK, ONLY: PTSVX_F77 => LA_PTSVX
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
!  .. SCALAR ARGUMENTS ..
   CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: FACT
   INTEGER, INTENT(OUT), OPTIONAL :: INFO
   REAL(WP), INTENT(OUT), OPTIONAL :: RCOND
!  .. ARRAY ARGUMENTS ..
   REAL(WP), INTENT(IN) :: D(:)
   REAL(WP), INTENT(IN) :: E(:), B(:,:)
   REAL(WP), INTENT(OUT) :: X(:,:)
   REAL(WP), INTENT(INOUT), OPTIONAL, TARGET :: DF(:)
   REAL(WP), INTENT(INOUT), OPTIONAL, TARGET :: EF(:)
   REAL(WP), INTENT(OUT), OPTIONAL, TARGET :: FERR(:), BERR(:)
!----------------------------------------------------------------------
!
! Purpose
! =======
!
!    LA_PTSVX computes the solution to a linear system of equations
! A*X = B, where A has tridiagonal form and is real symmetric or complex
! Hermitian and, in either case, positive definite, and where X and B are
! rectangular matrices or vectors.
!    LA_PTSVX can also optionally estimate the condition number of A and
! compute error bounds.
!
! =========
!
!     SUBROUTINE LA_PTSVX( D, E, B, X, DF=df, EF=ef, FACT=fact, &
!                  FERR=ferr, BERR=berr, RCOND=rcond, INFO=info )
!          REAL(<wp>), INTENT(IN) :: D(:)
!          <type>(<wp>), INTENT(IN) :: E(:), <rhs>
!          <type>(<wp>), INTENT(OUT) :: <sol>
!          REAL(<wp>), INTENT(INOUT), OPTIONAL :: DF(:)
!          <type>(<wp>), INTENT(INOUT), OPTIONAL :: EF(:)
!          CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: FACT
!          REAL(<wp>), INTENT(OUT), OPTIONAL :: <err>, RCOND
!          INTEGER, INTENT(OUT), OPTIONAL :: INFO
!     where
!          <type> ::= REAL | COMPLEX
!          <wp>   ::= KIND(1.0) | KIND(1.0D0)
!          <rhs>  ::= B(:,:) | B(:)
!          <sol>  ::= X(:,:) | X(:)
!          <err>  ::= FERR(:), BERR(:) | FERR, BERR
!
! Arguments
! =========
!
! D       (input) REAL array, shape (:) with size(D) = n, where n is the
!         order of A.
!         The diagonal of A.
! E       (input) REAL or COMPLEX array, shape (:) with size(E) = n-1.
!         The subdiagonal of A.
! B       (input) REAL or COMPLEX array, shape (:,:) with size(B,1) = n
!         or shape (:) with size(B) = n.
!         The matrix B.
! X       (output) REAL or COMPLEX array, shape (:,:) with size(X,1) = n
!         and size(X,2) = size(B,2), or shape (:) with size(X) = n.
!         The solution matrix X .
! DF      Optional (input or output) REAL array, shape (:) with the same
!         size as D.
!         If FACT = 'F', then DF is an input argument that contains the
!         diagonal of D from the L*D*L^H factorization of A.
!         If FACT = 'N', then DF is an output argument that contains the
!         diagonal of D from the L*D*L^H factorization of A.
! EF      Optional (input or output) REAL or COMPLEX array, shape (:) with
!         the same size as E.
!         If FACT = 'F', then EF is an input argument that contains the
!         subdiagonal of L from the L*D*L^H factorization of A.
!         If FACT = 'N', then EF is an output argument that contains the
!         subdiagonal of L from the L*D*L^H factorization of A.
! FACT    Optional (input) CHARACTER(LEN=1).
!         Specifies whether the factored form of A has been supplied on
! 	  entry.
!           = 'N': The matrix A will be copied to DF and EF and factored.
!           = 'F': DF and EF contain the factored form of A.
!         Default value: 'N'.
! FERR    Optional (output) REAL array of shape (:), with
!         size(FERR) = size(X,2), or REAL scalar.
!         The estimated forward error bound for each solution vector X(j)
! 	  (the j-th column of the solution matrix X). If XTRUE is the
! 	  true solution corresponding to X(j), FERR(j) is an estimated
!         upper bound for the magnitude of the largest element in
! 	  (X(j)-XTRUE) divided by the magnitude of the largest element in
! 	  X(j).
! BERR    Optional (output) REAL array of shape (:), with size(BERR) =
!         size(X,2), or REAL scalar.
!         The componentwise relative backward error of each solution
!         vector X(j) (i.e., the smallest relative change in any element
!         of A or B that makes X(j) an exact solution).
! RCOND   Optional (output) REAL.
!         The estimate of the reciprocal condition number of the matrix
!         A. If RCOND is less than the machine precision, the matrix is
!         singular to working precision. This condition is indicated by
!         a return code of INFO > 0.
! INFO    Optional (output) INTEGER
!         = 0: successful exit.
!         < 0: if INFO = -i, the i-th argument had an illegal value.
!         > 0: if INFO = i, and i is
!             <= n: the leading minor of order i of A is not positive
! 	         definite, so the factorization could not be completed
! 		 unless i = n, and the solution and error bounds could
! 		 not be computed. RCOND = 0 is returned.
!             = n+1: L is nonsingular, but RCOND is less than machine
! 	         precision, so the matrix is singular to working
! 		 precision. Nevertheless, the solution and error
!                  bounds are computed because the computed solution can
!                  be more accurate than the value of RCOND would suggest.
!         If INFO is not present and an error occurs, then the program is
! 	  terminated with an error message.
!-----------------------------------------------------------------------
!  .. PARAMETERS ..
   CHARACTER(LEN=8), PARAMETER :: SRNAME = 'LA_PTSVX'
!  .. LOCAL SCALARS ..
   CHARACTER(LEN=1) :: LFACT
   INTEGER :: LINFO, NRHS, N, ISTAT, ISTAT1, SDF, SEF, SFERR, SBERR
   REAL(WP) :: LRCOND
!  .. LOCAL POINTERS ..
   REAL(WP),  POINTER :: LDF(:), LFERR(:), LBERR(:)
   REAL(WP),  POINTER :: WORK(:), LEF(:)
!  .. INTRINSIC FUNCTIONS ..
   INTRINSIC PRESENT, SIZE
!  .. EXECUTABLE STATEMENTS ..
   LINFO = 0; ISTAT = 0
   N = SIZE(D); NRHS = SIZE(B,2)
   IF( PRESENT(RCOND) ) RCOND = 1.0_WP
   IF( PRESENT(FACT) )THEN; LFACT = FACT; ELSE; LFACT='N'; END IF
   IF( PRESENT(DF) )THEN; SDF = SIZE(DF); ELSE; SDF = N; END IF
   IF( PRESENT(EF) )THEN; SEF = SIZE(EF); ELSE; SEF = N-1; END IF
   IF( PRESENT(FERR) )THEN; SFERR = SIZE(FERR); ELSE; SFERR = NRHS; END IF
   IF( PRESENT(BERR) )THEN; SBERR = SIZE(BERR); ELSE; SBERR = NRHS; END IF
!  .. TEST THE ARGUMENTS
   IF( N < 0 ) THEN; LINFO = -1
   ELSE IF( SIZE( E ) /= N-1 .AND. N /= 0 ) THEN; LINFO = -2
   ELSE IF( SIZE(B, 1) /= N .OR. NRHS < 0 )THEN; LINFO = -3
   ELSE IF( SIZE(X, 1) /= N .OR. SIZE(X, 2) /= NRHS )THEN; LINFO = -4
   ELSE IF( SDF /= N ) THEN; LINFO = -5
   ELSE IF( .NOT.( PRESENT(DF).AND.PRESENT(EF) ) &
       .AND.( PRESENT(DF).OR.PRESENT(EF) ) )THEN; LINFO = -5
   ELSE IF( SEF /= N-1 .AND. N>0 ) THEN; LINFO = -6
   ELSE IF( ( .NOT.LSAME(LFACT,'F') .AND. .NOT.LSAME(LFACT,'N') ) .OR. &
            ( LSAME(LFACT,'F') .AND. .NOT.PRESENT(DF) ) )THEN; LINFO = -7
   ELSE IF( SFERR /= NRHS )THEN; LINFO = -8
   ELSE IF( SBERR /= NRHS )THEN; LINFO = -9
   ELSE IF ( N > 0 )THEN
      IF( .NOT.PRESENT(DF) ) THEN; ALLOCATE( LDF(N), LEF(N-1), STAT=ISTAT )
      ELSE; LDF => DF; LEF => EF; END IF
      IF( ISTAT == 0 )THEN
         IF( .NOT.PRESENT(FERR) )THEN; ALLOCATE( LFERR(NRHS), STAT=ISTAT )
         ELSE; LFERR => FERR; END IF
      END IF
      IF( ISTAT == 0 )THEN
         IF( .NOT.PRESENT(BERR) )THEN; ALLOCATE( LBERR(NRHS), STAT=ISTAT )
         ELSE; LBERR => BERR; END IF
      END IF
      IF( ISTAT == 0 ) ALLOCATE(WORK(2*N), STAT=ISTAT )
      IF( ISTAT == 0 )THEN
         CALL PTSVX_F77( LFACT, N, NRHS, D, E, LDF, LEF, B, N, X, N, LRCOND, &
                         LFERR, LBERR, WORK, LINFO )
      ELSE; LINFO = -100; END IF
      IF( .NOT.PRESENT(DF) ) DEALLOCATE( LDF, LEF, STAT=ISTAT1 )
      IF( .NOT.PRESENT(FERR) ) DEALLOCATE( LFERR, STAT=ISTAT1 )
      IF( .NOT.PRESENT(BERR) ) DEALLOCATE( LBERR, STAT=ISTAT1 )
      IF( PRESENT(RCOND) ) RCOND=LRCOND
      DEALLOCATE( WORK, STAT=ISTAT1 )
   END IF
   CALL ERINFO( LINFO, SRNAME, INFO, ISTAT )
END SUBROUTINE DPTSVX_F95


      real(8) function xfac(n)
*
* n !  as double precision real
*
      implicit none

      include 'stdunit.h'

      integer, intent(in) ::
     &     n

      integer ::
     &     k

      if( n .lt. 0 ) then
        xfac = 0d0
        write(lulog,*)
     &       ' warning faculty of negative number set to zero '
      else
c
        xfac = 1.0d0
        do k = 2,n
          xfac = xfac * dble(k)
        end do
      end if
c
      return
      end


C
C*************************** FCINDE ************************************
C
C  calculate void ratio index using Camporese
C  adaptation of Pyatt and John relation for peat volume changes
C
C***********************************************************************
C
      DOUBLE PRECISION FUNCTION FCINDE(INDE,SW,D,PSI,PNODI,SNODI,PORE)
C
      IMPLICIT NONE
      INCLUDE 'CATHY.H'
      REAL*8   INDE,SW,D,PSI,PNODI,SNODI,PORE
      REAL*8   CBETA,THETA0
      REAL*8   UNO
      PARAMETER (UNO=1.0D0)
      INCLUDE 'SOILCHAR.H'
C
      IF (SW .LT. UNO) THEN
         CBETA=CBETA0+CANG*D
         THETA0=PNODI/(UNO-PNODI)
         IF (CBETA .GT. UNO) THEN
            CBETA=UNO
         END IF
         FCINDE=ABS(THETA0+UNO)**(UNO-CBETA)*ABS(INDE*SW+UNO)**CBETA
     1          -UNO
      ELSE
         PORE=UNO-(UNO-PNODI)*EXP(-SNODI*PSI)
         FCINDE=PORE/(UNO-PORE)
      END IF
C
      RETURN
      END


!---------------------------------------------------!
! Copyright (c) 2016 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
!-------10--------20--------30--------40--------50--------60--------70--------80--------90
subroutine dt_evolve_ms(Etz,im)
  use global_variables_ms
  implicit none
  integer, intent(in) :: im
  real(8), intent(in) :: Etz
  real(8) :: lambda,theta_p,theta_m,eps_p,eps_m
  real(8) :: ss
  complex(8) :: zsp,zsm
  integer :: ikr,ikz
  complex(8) :: zeig_vec_p(2), zeig_vec_m(2)

  do ikz = -NKz,NKz
  do ikr = 1,NKr

    lambda = deps_int(ikr,ikz,im)
    theta_p = lambda + 0.5d0*pi; theta_m = lambda - 0.5d0*pi
    zeig_vec_p(1) = 1d0/sqrt(2d0); zeig_vec_p(2) = exp(zi*theta_p)/sqrt(2d0)
    zeig_vec_m(1) = 1d0/sqrt(2d0); zeig_vec_m(2) = exp(zi*theta_m)/sqrt(2d0)

    eps_p = -piz_vc*Etz/deps(ikr,ikz,im); eps_m = -eps_p

    zsp = sum(conjg(zeig_vec_p(:))*zCt(:,ikr,ikz,im))
    zsm = sum(conjg(zeig_vec_m(:))*zCt(:,ikr,ikz,im))

    zsp = zsp * exp(-zI*eps_p*dt)
    zsm = zsm * exp(-zI*eps_m*dt)
    zCt(:,ikr,ikz,im) = zsp*zeig_vec_p(:) + zsm*zeig_vec_m(:)

  end do
  end do

  return
end subroutine dt_evolve_ms


!
!     jacobian,bd,pd calculation
!
subroutine r_bdpd_curr(xji)
  use solid_variables, only: nsd_solid,nen_solid
  use r_common
  implicit none

  real(8) :: xji(nsd_solid,nsd_solid)

  integer :: i,j,k
  real(8) :: dumcd

 !...compute the bd matrix-> strain displacement matrix
  do i=1,nen_solid
     do k=1,nsd_solid
        dumcd=0.0d0
        do j=1,nsd_solid
           dumcd=dumcd+xji(j,k)*r_p(j,i)
        enddo
        bd_curr(k,i)=dumcd
    enddo
  enddo

  return
end subroutine r_bdpd_curr


*DECK CPODI
      SUBROUTINE CPODI (A, LDA, N, DET, JOB)
C***BEGIN PROLOGUE  CPODI
C***PURPOSE  Compute the determinant and inverse of a certain complex
C            Hermitian positive definite matrix using the factors
C            computed by CPOCO, CPOFA, or CQRDC.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D2D1B, D3D1B
C***TYPE      COMPLEX (SPODI-S, DPODI-D, CPODI-C)
C***KEYWORDS  DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX,
C             POSITIVE DEFINITE
C***AUTHOR  Moler, C. B., (U. of New Mexico)
C***DESCRIPTION
C
C     CPODI computes the determinant and inverse of a certain
C     complex Hermitian positive definite matrix (see below)
C     using the factors computed by CPOCO, CPOFA or CQRDC.
C
C     On Entry
C
C        A       COMPLEX(LDA, N)
C                the output  A  from CPOCO or CPOFA
C                or the output  X  from CQRDC.
C
C        LDA     INTEGER
C                the leading dimension of the array  A .
C
C        N       INTEGER
C                the order of the matrix  A .
C
C        JOB     INTEGER
C                = 11   both determinant and inverse.
C                = 01   inverse only.
C                = 10   determinant only.
C
C     On Return
C
C        A       If CPOCO or CPOFA was used to factor  A  then
C                CPODI produces the upper half of INVERSE(A) .
C                If CQRDC was used to decompose  X  then
C                CPODI produces the upper half of INVERSE(CTRANS(X)*X)
C                where CTRANS(X) is the conjugate transpose.
C                Elements of  A  below the diagonal are unchanged.
C                If the units digit of JOB is zero,  A  is unchanged.
C
C        DET     REAL(2)
C                determinant of  A  or of  CTRANS(X)*X  if requested.
C                Otherwise not referenced.
C                Determinant = DET(1) * 10.0**DET(2)
C                with  1.0 .LE. DET(1) .LT. 10.0
C                or  DET(1) .EQ. 0.0 .
C
C     Error Condition
C
C        a division by zero will occur if the input factor contains
C        a zero on the diagonal and the inverse is requested.
C        It will not occur if the subroutines are called correctly
C        and if CPOCO or CPOFA has set INFO .EQ. 0 .
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  CAXPY, CSCAL
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  CPODI
      INTEGER LDA,N,JOB
      COMPLEX A(LDA,*)
      REAL DET(2)
C
      COMPLEX T
      REAL S
      INTEGER I,J,JM1,K,KP1
C***FIRST EXECUTABLE STATEMENT  CPODI
C
C     COMPUTE DETERMINANT
C
      IF (JOB/10 .EQ. 0) GO TO 70
         DET(1) = 1.0E0
         DET(2) = 0.0E0
         S = 10.0E0
         DO 50 I = 1, N
            DET(1) = REAL(A(I,I))**2*DET(1)
            IF (DET(1) .EQ. 0.0E0) GO TO 60
   10       IF (DET(1) .GE. 1.0E0) GO TO 20
               DET(1) = S*DET(1)
               DET(2) = DET(2) - 1.0E0
            GO TO 10
   20       CONTINUE
   30       IF (DET(1) .LT. S) GO TO 40
               DET(1) = DET(1)/S
               DET(2) = DET(2) + 1.0E0
            GO TO 30
   40       CONTINUE
   50    CONTINUE
   60    CONTINUE
   70 CONTINUE
C
C     COMPUTE INVERSE(R)
C
      IF (MOD(JOB,10) .EQ. 0) GO TO 140
         DO 100 K = 1, N
            A(K,K) = (1.0E0,0.0E0)/A(K,K)
            T = -A(K,K)
            CALL CSCAL(K-1,T,A(1,K),1)
            KP1 = K + 1
            IF (N .LT. KP1) GO TO 90
            DO 80 J = KP1, N
               T = A(K,J)
               A(K,J) = (0.0E0,0.0E0)
               CALL CAXPY(K,T,A(1,K),1,A(1,J),1)
   80       CONTINUE
   90       CONTINUE
  100    CONTINUE
C
C        FORM  INVERSE(R) * CTRANS(INVERSE(R))
C
         DO 130 J = 1, N
            JM1 = J - 1
            IF (JM1 .LT. 1) GO TO 120
            DO 110 K = 1, JM1
               T = CONJG(A(K,J))
               CALL CAXPY(K,T,A(1,J),1,A(1,K),1)
  110       CONTINUE
  120       CONTINUE
            T = CONJG(A(J,J))
            CALL CSCAL(J,T,A(1,J),1)
  130    CONTINUE
  140 CONTINUE
      RETURN
      END


c Author: Anand Patil, anand.prabhakar.patil@gmail.com

      SUBROUTINE chol_mvnorm(x, mu, sig, n, like, info)

cf2py double precision dimension(n), intent(copy) :: x
cf2py double precision dimension(n), intent(copy) :: mu
cf2py integer intent(hide),depend(x) :: n=len(x)
cf2py double precision dimension(n,n), intent(copy) :: sig
cf2py double precision intent(out) :: like
cf2py integer intent(hide) :: info

      DOUBLE PRECISION sig(n,n), x(n), mu(n), like
      INTEGER n, info
      DOUBLE PRECISION infinity
      PARAMETER (infinity = 1.7976931348623157d308)
      DOUBLE PRECISION PI
      PARAMETER (PI=3.141592653589793238462643d0)
      DOUBLE PRECISION twopi_N, log_detC

      EXTERNAL DPOTRS
! DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) Solves triangular system
      EXTERNAL DAXPY
! DAXPY(N,DA,DX,INCX,DY,INCY) Adding vectors
      EXTERNAL DCOPY
! DCOPY(N,DX,INCX,DY,INCY) copies x to y
      EXTERNAL DDOT

!     x <- (x-mu)
      call DAXPY(n, -1.0D0, mu, 1, x, 1)

!       mu <- x
      call DCOPY(n,x,1,mu,1)

!     x <- sig ^-1 * x
      call DPOTRS('L',n,1,sig,n,x,n,info)

!     like <- .5 dot(x,mu) (.5 (x-mu) C^{-1} (x-mu)^T)
      like = -0.5D0 * DDOT(n, x, 1, mu, 1)
!       print *, like

      twopi_N = 0.5D0 * N * dlog(2.0D0*PI)
!       print *, twopi_N

      log_detC = 0.0D0
      do i=1,n
        log_detC = log_detC + log(sig(i,i))
      enddo
!       print *, log_detC

      like = like - twopi_N - log_detC

      return
      END

      SUBROUTINE cov_mvnorm(x, mu, C, n, like, info)

cf2py double precision dimension(n), intent(copy) :: x
cf2py double precision dimension(n), intent(copy) :: mu
cf2py integer intent(hide),depend(x) :: n=len(x)
cf2py double precision dimension(n,n), intent(copy) :: C
cf2py double precision intent(out) :: like
cf2py integer intent(hide) :: info

      DOUBLE PRECISION C(n,n), x(n), mu(n), like
      INTEGER n, info
      DOUBLE PRECISION infinity
      PARAMETER (infinity = 1.7976931348623157d308)
      DOUBLE PRECISION PI
      PARAMETER (PI=3.141592653589793238462643d0)
      DOUBLE PRECISION twopi_N, log_detC

      EXTERNAL DPOTRF
! DPOTRF( UPLO, N, A, LDA, INFO ) Cholesky factorization
      EXTERNAL DPOTRS
! DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) Solves triangular system
      EXTERNAL DAXPY
! DAXPY(N,DA,DX,INCX,DY,INCY) Adding vectors
      EXTERNAL DCOPY
! DCOPY(N,DX,INCX,DY,INCY) copies x to y
      EXTERNAL DDOT

!     C <- cholesky(C)
      call DPOTRF( 'L', n, C, n, info )
!       print *, C

!     Puke if C not positive definite
      if (info .GT. 0) then
        like=-infinity
        RETURN
      endif

!     x <- (x-mu)
      call DAXPY(n, -1.0D0, mu, 1, x, 1)

!       mu <- x
      call DCOPY(n,x,1,mu,1)

!     x <- C ^-1 * x
      call DPOTRS('L',n,1,C,n,x,n,info)

!     like <- .5 dot(x,mu) (.5 (x-mu) C^{-1} (x-mu)^T)
      like = -0.5D0 * DDOT(n, x, 1, mu, 1)
!       print *, like

      twopi_N = 0.5D0 * N * dlog(2.0D0*PI)
!       print *, twopi_N

      log_detC = 0.0D0
      do i=1,n
        log_detC = log_detC + log(C(i,i))
      enddo
!       print *, log_detC

      like = like - twopi_N - log_detC

      return
      END

      SUBROUTINE blas_mvnorm(x, mu, tau, n, like)

cf2py double precision dimension(n), intent(copy) :: x
cf2py double precision dimension(n), intent(copy) :: mu
cf2py integer intent(hide),depend(x) :: n=len(x)
cf2py double precision dimension(n,n), intent(in) :: tau
cf2py double precision intent(out) :: like

      DOUBLE PRECISION tau(n,n), x(n), mu(n), like
      INTEGER n, info
      DOUBLE PRECISION infinity
      PARAMETER (infinity = 1.7976931348623157d308)
      DOUBLE PRECISION PI
      PARAMETER (PI=3.141592653589793238462643d0)
      DOUBLE PRECISION twopi_N, log_dettau

      EXTERNAL DPOTRF
! DPOTRF( UPLO, N, A, LDA, INFO ) Cholesky factorization
      EXTERNAL DSYMV
! Symmetric matrix-vector multiply
      EXTERNAL DAXPY
! DAXPY(N,DA,DX,INCX,DY,INCY) Adding vectors
      EXTERNAL DCOPY
! DCOPY(N,DX,INCX,DY,INCY) copies x to y
      EXTERNAL DDOT

      twopi_N = 0.5D0 * N * dlog(2.0D0*PI)

!     x <- (x-mu)
      call DAXPY(n, -1.0D0, mu, 1, x, 1)

!       mu <- x
      call DCOPY(n,x,1,mu,1)

!     x <- tau * x
      call DSYMV('L',n,1.0D0,tau,n,x,1,0.0D0,mu,1)

!     like <- .5 dot(x,mu) (.5 (x-mu) C^{-1} (x-mu)^T)
      like = -0.5D0 * DDOT(n, x, 1, mu, 1)

!      Cholesky factorize tau for the determinant.
       call DPOTRF( 'L', n, tau, n, info )

!      If cholesky failed, puke.
       if (info .GT. 0) then
         like = -infinity
         RETURN
       endif

!      Otherwise read off determinant.
       log_dettau = 0.0D0
       do i=1,n
         log_dettau = log_dettau + dlog(tau(i,i))
       enddo

       like = like - twopi_N + log_dettau

      return
      END

      SUBROUTINE blas_wishart(X,k,n,V,like)

c Wishart log-likelihood function.

cf2py double precision dimension(k,k),intent(copy) :: X,V
cf2py double precision intent(out) :: like
cf2py integer intent(hide),depend(X) :: k=len(X)

      INTEGER i,k,n
      DOUBLE PRECISION X(k,k),V(k,k),bx(k,k)
      DOUBLE PRECISION dx,db,tbx,a,g,like
      DOUBLE PRECISION infinity
      PARAMETER (infinity = 1.7976931348623157d308)

      EXTERNAL DCOPY
! DCOPY(N,DX,INCX,DY,INCY) copies x to y
      EXTERNAL DSYMM
! DSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) alpha*A*B + beta*C when side='l'
      EXTERNAL DPOTRF
! DPOTRF( UPLO, N, A, LDA, INFO ) Cholesky factorization

      print *, 'Warning, vectorized Wisharts are untested'
c determinants
      call dtrm(X,k,dx)
      call dtrm(V,k,db)

c trace of V*X
!     bx <- V * bx
      call DSYMM('l','L',n,n,1.0D0,V,n,x,n,0.0D0,bx)

c Cholesky factor V, puke if not pos def.
      call DPOTRF( 'L', n, V, n, info )
      if (info .GT. 0) then
        like = -infinity
        RETURN
      endif
c Cholesky factor X, puke if not pos def.
      call DPOTRF( 'L', n, X, n, info )
      if (info .GT. 0) then
        like = -infinity
        RETURN
      endif

c Get the trace and log-sqrt-determinants
      tbx = 0.0D0
      dx = 0.0D0
      db = 0.0D0

      do i=1,n
        tbx = tbx + bx(i,i)
        dx = dx + dlog(X(i,i))
        dx = dx + dlog(V(i,i))
      enddo

      if (k .GT. n) then
        like = -infinity
        RETURN
      endif

      like = (n - k - 1) * dx
      like = like + n * db
      like = like - 0.5 * tbx
      like = like - (n*k/2.0)*dlog(2.0d0)

      do i=1,k
        a = (n - i + 1)/2.0
        call gamfun(a, g)
        like = like - g
      enddo

      return
      END

c

      SUBROUTINE blas_wishart_cov(X,k,n,V,like)

c Wishart log-likelihood function.
c Doesn't vectorize the determinants, just the matrix multiplication.

cf2py double precision dimension(k,k),intent(copy) :: V,X
cf2py double precision intent(out) :: like
cf2py integer intent(hide),depend(X) :: k=len(X)

      INTEGER i,k,info, n
      DOUBLE PRECISION X(k,k),V(k,k),bx(k,k)
      DOUBLE PRECISION dx,db,tbx,a,g,like
      DOUBLE PRECISION infinity
      PARAMETER (infinity = 1.7976931348623157d308)
c
      EXTERNAL DCOPY
! DCOPY(N,DX,INCX,DY,INCY) copies x to y
      EXTERNAL DPOTRF
! DPOTRF( UPLO, N, A, LDA, INFO ) Cholesky factorization
      EXTERNAL DPOTRS
! DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) Solves triangular system
      print *, 'Warning, vectorized Wisharts are untested'
c determinants

c Cholesky factorize sigma, puke if not pos def
!     V <- cholesky(V)
      call DPOTRF( 'L', n, V, n, info )
      if (info .GT. 0) then
        like = -infinity
        RETURN
      endif

c trace of sigma*X
!     bx <- X
      call DCOPY(n * n,X,1,bx,1)
!     bx <- sigma * bx
      call DPOTRS('L',n,n,V,n,bx,n,info)

!     X <- cholesky(X)
      call DPOTRF( 'L', n, X, n, info )

! sqrt-log-determinant of sigma and X, and trace
      db=0.0D0
      dx=0.0D0
      tbx = 0.0D0
      do i=1,n
        db = db + dlog(V(i,i))
        dx = dx + dlog(X(i,i))
        tbx = tbx + bx(i,i)
      enddo

      if (k .GT. n) then
        like = -infinity
        RETURN
      endif

      like = (n - k - 1) * dx
      like = like + n * db
      like = like - 0.5*tbx
      like = like - (n*k/2.0)*dlog(2.0d0)

      do i=1,k
        a = (n - i + 1)/2.0
        call gamfun(a, g)
        like = like - dlog(g)
      enddo

      return
      END

c

      subroutine dchdc_wrap(a,lda,p,work,piv,job,info)

cf2py double precision intent(inplace), dimension(lda,p) :: a
cf2py integer intent(hide), depend(p):: lda=p
cf2py integer intent(hide), depend(a):: p=shape(a,0)
cf2py double precision intent(hide) :: work
cf2py integer intent(out), dimension(p) :: piv
cf2py integer intent(hide) :: job=1
cf2py integer intent(out) :: info

      integer lda,p,piv(p),job,info
      double precision a(lda,p),work(p)

c
c     dchdc computes the cholesky decomposition of a positive definite
c     matrix.  a pivoting option allows the user to estimate the
c     condition of a positive definite matrix or determine the rank
c     of a positive semidefinite matrix.
c
c     on entry
c
c         a      double precision(lda,p).
c                a contains the matrix whose decomposition is to
c                be computed.  onlt the upper half of a need be stored.
c                the lower part of the array a is not referenced.
c
c         lda    integer.
c                lda is the leading dimension of the array a.
c
c         Since f2py will make sure that a is column-major contiguous,
c         lda is set to p in this wrapper.
c
c         p      integer.
c                p is the order of the matrix.
c
c         work   double precision.
c                work is a work array.
c
c         piv   integer(p).
c                piv contains integers that control the selection
c                of the pivot elements, if pivoting has been requested.
c                each diagonal element a(k,k)
c                is placed in one of three classes according to the
c                value of piv(k).
c
c                   if piv(k) .gt. 0, then x(k) is an initial
c                                      element.
c
c                   if piv(k) .eq. 0, then x(k) is a free element.
c
c                   if piv(k) .lt. 0, then x(k) is a final element.
c
c                before the decomposition is computed, initial elements
c                are moved by symmetric row and column interchanges to
c                the beginning of the array a and final
c                elements to the end.  both initial and final elements
c                are frozen in place during the computation and only
c                free elements are moved.  at the k-th stage of the
c                reduction, if a(k,k) is occupied by a free element
c                it is interchanged with the largest free element
c                a(l,l) with l .ge. k.  piv is not referenced if
c                job .eq. 0.
c
c        job     integer.
c                job is an integer that initiates column pivoting.
c                if job .eq. 0, no pivoting is done.
c                if job .ne. 0, pivoting is done.
c
c        In this wrapper, job=1.
c
c     on return
c
c         a      a contains in its upper half the cholesky factor
c                of the matrix a as it has been permuted by pivoting.
c
c         piv   piv(j) contains the index of the diagonal element
c                of a that was moved into the j-th position,
c                provided pivoting was requested.
c
c         info   contains the index of the last positive diagonal
c                element of the cholesky factor.
c
c     for positive definite matrices info = p is the normal return.
c     for pivoting with positive semidefinite matrices info will
c     in general be less than p.  however, info may be greater than
c     the rank of a, since rounding error can cause an otherwise zero
c     element to be positive. indefinite systems will always cause
c     info to be less than p.
c
c     linpack. this version dated 08/14/78 .
c     j.j. dongarra and g.w. stewart, argonne national laboratory and
c     university of maryland.
c
c
c     blas daxpy,dswap
c     fortran dsqrt
c
c     internal variables
c
      integer pu,pl,plp1,i,j,jp,jt,k,kb,km1,kp1,l,maxl
      double precision temp
      double precision maxdia
      logical swapk,negk
c
      pl = 1
      pu = 0
      info = p
      if (job .eq. 0) go to 160
c
c        pivoting has been requested. rearrange the
c        the elements according to piv.
c
         do 70 k = 1, p
            swapk = piv(k) .gt. 0
            negk = piv(k) .lt. 0
            piv(k) = k
            if (negk) piv(k) = -piv(k)
            if (.not.swapk) go to 60
               if (k .eq. pl) go to 50
                  call dswap(pl-1,a(1,k),1,a(1,pl),1)
                  temp = a(k,k)
                  a(k,k) = a(pl,pl)
                  a(pl,pl) = temp
                  plp1 = pl + 1
                  if (p .lt. plp1) go to 40
                  do 30 j = plp1, p
                     if (j .ge. k) go to 10
                        temp = a(pl,j)
                        a(pl,j) = a(j,k)
                        a(j,k) = temp
                     go to 20
   10                continue
                     if (j .eq. k) go to 20
                        temp = a(k,j)
                        a(k,j) = a(pl,j)
                        a(pl,j) = temp
   20                continue
   30             continue
   40             continue
                  piv(k) = piv(pl)
                  piv(pl) = k
   50          continue
               pl = pl + 1
   60       continue
   70    continue
         pu = p
         if (p .lt. pl) go to 150
         do 140 kb = pl, p
            k = p - kb + pl
            if (piv(k) .ge. 0) go to 130
               piv(k) = -piv(k)
               if (pu .eq. k) go to 120
                  call dswap(k-1,a(1,k),1,a(1,pu),1)
                  temp = a(k,k)
                  a(k,k) = a(pu,pu)
                  a(pu,pu) = temp
                  kp1 = k + 1
                  if (p .lt. kp1) go to 110
                  do 100 j = kp1, p
                     if (j .ge. pu) go to 80
                        temp = a(k,j)
                        a(k,j) = a(j,pu)
                        a(j,pu) = temp
                     go to 90
   80                continue
                     if (j .eq. pu) go to 90
                        temp = a(k,j)
                        a(k,j) = a(pu,j)
                        a(pu,j) = temp
   90                continue
  100             continue
  110             continue
                  jt = piv(k)
                  piv(k) = piv(pu)
                  piv(pu) = jt
  120          continue
               pu = pu - 1
  130       continue
  140    continue
  150    continue
  160 continue
      do 270 k = 1, p
c
c        reduction loop.
c
         maxdia = a(k,k)
         kp1 = k + 1
         maxl = k
c
c        determine the pivot element.
c
         if (k .lt. pl .or. k .ge. pu) go to 190
            do 180 l = kp1, pu
               if (a(l,l) .le. maxdia) go to 170
                  maxdia = a(l,l)
                  maxl = l
  170          continue
  180       continue
  190    continue
c
c        quit if the pivot element is not positive.
c
         if (maxdia .gt. 0.0d0) go to 200
            info = k - 1
c     ......exit
            go to 280
  200    continue
         if (k .eq. maxl) go to 210
c
c           start the pivoting and update piv.
c
            km1 = k - 1
            call dswap(km1,a(1,k),1,a(1,maxl),1)
            a(maxl,maxl) = a(k,k)
            a(k,k) = maxdia
            jp = piv(maxl)
            piv(maxl) = piv(k)
            piv(k) = jp
  210    continue
c
c        reduction step. pivoting is contained across the rows.
c
         work(k) = dsqrt(a(k,k))
         a(k,k) = work(k)
         if (p .lt. kp1) go to 260
         do 250 j = kp1, p
            if (k .eq. maxl) go to 240
               if (j .ge. maxl) go to 220
                  temp = a(k,j)
                  a(k,j) = a(j,maxl)
                  a(j,maxl) = temp
               go to 230
  220          continue
               if (j .eq. maxl) go to 230
                  temp = a(k,j)
                  a(k,j) = a(maxl,j)
                  a(maxl,j) = temp
  230          continue
  240       continue
            a(k,j) = a(k,j)/work(k)
            work(j) = a(k,j)
            temp = -a(k,j)
            call daxpy(j-k,temp,work(kp1),1,a(kp1,j),1)
  250    continue
  260    continue
  270 continue
  280 continue

C Zero the lower triangle
      do i=2,info
        do j=1,i-1
          a(i,j) = 0.0D0
        enddo
      enddo

C decrement the pivots.
      do i=1,p
        piv(i) = piv(i)-1
      enddo
      return
      end


module mod_particle
use,intrinsic :: ISO_FORTRAN_ENV, only : REAL64
implicit none
private
public :: particle
public ::  assignment (=)
!
  type particle
    real(REAL64) :: q(3)    = 0D0
    real(REAL64) :: f(3)    = 0D0
  end type particle
!
! type tension
!   real(REAL64) :: core    = 1D0
!   real(REAL64) :: r       = 0D0
! contains
!   procedure    :: force => tension_force
! end type tension
!
! type pressure
!   real(REAL64) :: h       = 0D0
!   real(REAL64) :: vert(3) = [0D0,0D0,1D0] / 4D0
! contains
!   procedure    :: force => pressure_force
! end type pressure
!
  interface assignment (=)
    module procedure particle_assign
  end interface assignment (=)
!
contains
!
  pure elemental subroutine particle_assign(l,r)
  class(particle),intent(inout) :: l
  class(particle),intent(in)    :: r
    l%q(:) = r%q(:)
    l%f(:) = r%f(:)
  end subroutine particle_assign
!
! pure elemental subroutine tension_force(this,p0,p1,f)
! class(tension),intent(in)              :: this
! class(particle),intent(inout)          :: p0,p1
! class(particle),intent(inout),optional :: f
! real(REAL64)                           :: v(3),r,r1,g
!
!   v(:) = p1%q(:) - p0%q(:)
!   g    = DOT_PRODUCT( v, v ) ; if(g<=0D0) RETURN
!   r    = SQRT( g )
!   r1   = 1D0 / r
!   g    = ( r - this%r ) * r1
!   r1   = this%r * r1
!   if(r1>1D0)then
!     r1   = r1 * r1
!     r1   = r1 * r1
!     r1   = r1 * r1
!     r1   = r1 * r1
!     r1   = 1D0 - r1
!   else
!     r1   = 0D0
!   endif
!
!   g    = g + this%core * r1
!   !g    = g + this%core * ( r1 - r1 * r1 )
!   v(:) = g * v(:)
!
!   if(PRESENT(f))then
!     f%f(:)  = v(:)
!   else
!     p0%f(:) = p0%f(:) + v(:)
!     p1%f(:) = p1%f(:) - v(:)
!   endif
!
! end subroutine tension_force
!
! pure elemental subroutine pressure_force(this,p0,p1,p2,p3,f)
! class(pressure),intent(in)             :: this
! class(particle),intent(inout)          :: p0,p1,p2,p3
! class(particle),intent(inout),optional :: f
! real(REAL64),parameter                 :: rsix = 1D0 / 6D0
! real(REAL64)                           :: a(3),b(3),n(3),g,s
!
!   a(:) = p0%q(:) + p1%q(:) + p2%q(:) + p3%q(:)
!   g    = this%h - DOT_PRODUCT( this%vert(:), a(:) )
!   if(g<0D0) g = 0D0
!
!   a(:) = p2%q(:) - p0%q(:)
!
!   b(:) = p1%q(:) - p0%q(:)
!   s    = SQRT( 1D0 - DOT_PRODUCT(a,b)**2 / ( DOT_PRODUCT(a,a) * DOT_PRODUCT(b,b) ) )
!
!   b(:) = p3%q(:) - p0%q(:)
!   s    = SQRT( 1D0 - DOT_PRODUCT(a,b)**2 / ( DOT_PRODUCT(a,a) * DOT_PRODUCT(b,b) ) ) + s
!
!   b(:) = p3%q(:) - p1%q(:)
!
!   n(1) = a(2) * b(3) - a(3) * b(2)
!   n(2) = a(3) * b(1) - a(1) * b(3)
!   n(3) = a(1) * b(2) - a(2) * b(1)
!
!   n(:) = rsix * g * s * n(:)
!
!   if(PRESENT(f))then
!     f%f(:) = - n(:)
!   else
!     p0%f(:) = p0%f(:) - n(:)
!     p1%f(:) = p1%f(:) - n(:)
!     p2%f(:) = p2%f(:) - n(:)
!     p3%f(:) = p3%f(:) - n(:)
!   endif
!
! end subroutine pressure_force
!
end module mod_particle


! --------------------------------------------------------------------
!
! Copyright (C) 2015 Rocco Meli
!
! 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 <http://www.gnu.org/licenses/>.
!
! ---------------------------------------------------------------------

PROGRAM electronic_test

    USE ELECTRONIC
    USE OUTPUT, only: print_ee_list

    IMPLICIT NONE

    ! TODO allows flexibility
    INTEGER, PARAMETER :: c = 3 ! Number of contractions (STO-3G)

    REAL*8, PARAMETER :: zeta_H = 1.24D0    ! STO coefficient correction for H
    REAL*8, PARAMETER :: zeta_He = 2.0925D0 ! STO coefficient correction for He
    REAL*8, PARAMETER :: zeta_O_1 = 7.66D0 ! STO coefficient correction for He
    REAL*8, PARAMETER :: zeta_O_2 = 2.25D0 ! STO coefficient correction for He

    ! ------------------
    ! BASIS SET FOR HeH+
    ! ------------------
    INTEGER, PARAMETER :: K_HeH = 2     ! Number of basis functions
    INTEGER, PARAMETER :: Nn_HeH = 2    ! Number of nuclei

    INTEGER, dimension(K_HeH,3) :: basis_L_HeH              ! Angular momenta of basis set Gaussians
    REAL*8, dimension(K_HeH,3) :: basis_R_HeH               ! Centers of basis set Gaussians
    REAL*8, dimension(K_HeH,c) :: basis_D_HeH, basis_A_HeH  ! Basis set coefficients

    REAL*8, dimension(K_HeH,K_HeH) :: Vn1_HeH   ! Nucleus-electron interaction matrix
    REAL*8, dimension(K_HeH,K_HeH) :: Vn2_HeH   ! Nucleus-electron interaction matrix

    REAL*8, dimension(Nn_HeH,3) :: R_HeH    ! Nuclear positions
    INTEGER, dimension(Nn_HeH) :: Zn_HeH    ! Nuclear charges

    ! -------------
    ! MOLECULE HeH+
    ! -------------

    REAL*8, dimension(K_HeH,K_HeH,K_HeH,K_HeH) :: ee_HeH

    R_HeH(1,1:3) = (/0.0D0, 0.0D0, 0.0D0/)       ! Position of first H atom
    R_HeH(2,1:3) = (/1.4632D0, 0.0D0, 0.0D0/)    ! Position of the second H atom

    Zn_HeH = (/1, 2/)

    basis_R_HeH(1,1:3) = R_HeH(1,1:3)    ! Position of the H atom
    basis_R_HeH(2,1:3) = R_HeH(2,1:3)    ! Position of the He atom

    basis_L_HeH(1,1:3) = (/0, 0, 0/) ! Angular momenta for the first basis function
    basis_L_HeH(2,1:3) = (/0, 0, 0/) ! Angular momenta for the second basis function

    basis_D_HeH(1,1:c) = (/0.444635D0, 0.535328D0, 0.154329D0 /)
    basis_D_HeH(2,1:c) = (/0.444635D0, 0.535328D0, 0.154329D0 /)

    basis_A_HeH(1,1:c) = (/0.109818D0 * zeta_H**2, 0.405771 * zeta_H**2, 2.22766 * zeta_H**2/)
    basis_A_HeH(2,1:c) = (/0.109818D0 * zeta_He**2, 0.405771 * zeta_He**2, 2.22766 * zeta_He**2/)

    WRITE(*,*) "#############"
    WRITE(*,*) "Molecule HeH+"
    WRITE(*,*) "#############"

    CALL ee_list(K_HeH,basis_D_HeH,basis_A_HeH,basis_L_HeH,basis_R_HeH,ee_HeH)

    WRITE(*,*) "HeH+ electron-electron integrals:"
    CALL print_ee_list(K_HeH,ee_HeH)

END PROGRAM electronic_test


      module eval
        ! Molecular integral evaluation (S, P, and D).
        !
        ! Reference:
        !
        !     H. Taketa et. al., J. Phys. Soc. Jpn. 21, 2313 (1966).
        !
        implicit none
        private
        real(8),parameter::PI=3.1415926535897931d0,TWOETOL=1d-8
        ! --------------------------------------------------------------
        public ::
     &      eval_overlap,
     &      eval_kinetic,
     &      eval_attract,
     &      eval_repulse,
     &      eval_velocity
        ! --------------------------------------------------------------

      contains

        subroutine eval_overlap(n1,n2,c1,c2,e1,e2,r1,r2,l1,l2,val)
          implicit none
          integer,intent(in)::n1,n2,l1(3),l2(3)
          real(8),intent(in)::c1(n1),c2(n2),e1(n1),e2(n2),r1(3),r2(3)
          real(8),intent(out)::val
          integer::i,j
          real(8)::vt
          val=0d0
          do i=1,n1
            do j=1,n2
              call overlap_pg_(e1(i),e2(j),r1,r2,l1,l2,vt)
              vt=vt*pgn_(l1,e1(i))*pgn_(l2,e2(j))
              vt=vt*c1(i)*c2(j)
              val=val+vt
            end do
          end do
        end subroutine

        subroutine overlap_pg_(e1i,e2i,r1,r2,l1,l2,val)
          implicit none
          real(8),intent(in)::e1i,e2i,r1(3),r2(3)
          real(8),intent(out)::val
          integer,intent(in)::l1(3),l2(3)
          integer::ix,nn,i
          real(8)::gm,rp(3),pa,pb,vt,w,vf
          gm=e1i+e2i
          rp(:)=(e1i*r1(:)+e2i*r2(:))/gm
          val=(PI/gm)**1.5
          val=val*EXP(-e1i*e2i*SUM((r1-r2)**2)/gm)
          do ix=1,3
            pa=rp(ix)-r1(ix)
            pb=rp(ix)-r2(ix)
            nn=FLOOR((l1(ix)+l2(ix))/2d0)
            vt=0d0
            do i=0,nn
              w=nfact2_(i)/((2d0*gm)**i)
              call fcoef_(2*i,l1(ix),l2(ix),pa,pb,vf)
              w=w*vf
              vt=vt+w
            end do
            val=val*vt
          end do
        end subroutine

        integer function nfact2_(i)
          implicit none
          integer,intent(in)::i
          integer,parameter::MX=5,NLS(MX)=(/1,1,3,15,105/)
          if (i+1>MX) then
            write(*,'("error: out of range: nfact2_()")')
            stop 1
          end if
          nfact2_=NLS(i+1)
        end function

        subroutine fcoef_(i,m,l,a,b,val)
          implicit none
          integer,intent(in)::i,m,l
          real(8),intent(in)::a,b
          real(8),intent(out)::val
          integer::j,k
          if (i>6) then
            write(*,'("error: out of range: fcoef_()")')
            stop 1
          end if
          val=0d0
          do j=0,i
            k=i-j
            if (m>=j.and.l>=k) then
              val=val+nbin_(m,j)*a**(m-j)*nbin_(l,k)*b**(l-k)
            end if
          end do
        end subroutine

        integer function nbin_(m,l)
          ! Binomial constant.
          implicit none
          integer,intent(in)::m,l
          integer,parameter::MX=7,NLS(MX,MX)=RESHAPE((/
     &      1,0,0,0,0,0,0,
     &      1,1,0,0,0,0,0,
     &      1,2,1,0,0,0,0,
     &      1,3,3,1,0,0,0,
     &      1,4,6,4,1,0,0,
     &      1,5,10,10,5,1,0,
     &      1,6,15,20,15,6,1
     &      /),(/MX,MX/))
          if (l+1>MX.or.m+1>MX) then
            write(*,'("error: out of range: nbin_()")')
            stop 1
          end if
          nbin_=NLS(l+1,m+1)
        end function

        real(8) function pgn_(l1,e1i) result(vn)
          ! Norm of a primitive Gaussian function.
          implicit none
          integer,intent(in)::l1(3)
          real(8),intent(in)::e1i
          integer::i
          vn=2d0**(2d0*SUM(l1)+1.5d0)
          vn=vn*e1i**(SUM(l1)+1.5d0)
          do i=1,3
            vn=vn/nfact2_(l1(i))
          end do
          vn=vn/PI**1.5
          vn=vn**0.5d0
        end function

        subroutine eval_kinetic(n1,n2,c1,c2,e1,e2,r1,r2,l1,l2,val)
          implicit none
          integer,intent(in)::n1,n2,l1(3),l2(3)
          real(8),intent(in)::c1(n1),c2(n2),e1(n1),e2(n2),r1(3),r2(3)
          real(8),intent(out)::val
          integer::i,j
          real(8)::vt
          val=0d0
          do i=1,n1
            do j=1,n2
              call kinetic_pg_(e1(i),e2(j),r1,r2,l1,l2,vt)
              vt=vt*pgn_(l1,e1(i))*pgn_(l2,e2(j))
              vt=vt*c1(i)*c2(j)
              val=val+vt
            end do
          end do
        end subroutine

        subroutine kinetic_pg_(e1i,e2i,r1,r2,l1,l2,val)
          implicit none
          real(8),intent(in)::e1i,e2i,r1(3),r2(3)
          real(8),intent(out)::val
          integer,intent(in)::l1(3),l2(3)
          integer::lps(3),ix
          real(8)::vt,st
          call overlap_pg_(e1i,e2i,r1,r2,l1,l2,st)
          val=e2i*(2*SUM(l2)+3)*st
          vt=0d0
          do ix=1,3
            lps(:)=0
            lps(ix)=lps(ix)+2
            call overlap_pg_(e1i,e2i,r1,r2,l1,l2+lps,st)
            vt=vt+st
          end do
          val=val-2d0*e2i**2d0*vt
          vt=0d0
          do ix=1,3
            if (l2(ix)>=2) then
              lps(:)=0
              lps(ix)=lps(ix)-2
              call overlap_pg_(e1i,e2i,r1,r2,l1,l2+lps,st)
              vt=vt+l2(ix)*(l2(ix)-1)*st
            end if
          end do
          val=val-0.5d0*vt
        end subroutine

        subroutine eval_attract(n1,n2,c1,c2,e1,e2,r1,r2,l1,l2,r3,val)
          implicit none
          integer,intent(in)::n1,n2,l1(3),l2(3)
          real(8),intent(in)::
     &      c1(n1),c2(n2),e1(n1),e2(n2),r1(3),r2(3),r3(3)
          real(8),intent(out)::val
          integer::i,j
          real(8)::vt
          val=0d0
          do i=1,n1
            do j=1,n2
              call attract_pg_(e1(i),e2(j),r1,r2,l1,l2,r3,vt)
              vt=vt*pgn_(l1,e1(i))*pgn_(l2,e2(j))
              vt=vt*c1(i)*c2(j)
              val=val+vt
            end do
          end do
        end subroutine

        subroutine attract_pg_(e1i,e2i,r1,r2,l1,l2,r3,val)
          implicit none
          real(8),intent(in)::e1i,e2i,r1(3),r2(3),r3(3)
          real(8),intent(out)::val
          integer,intent(in)::l1(3),l2(3)
          integer::ix,ii,jj,kk
          real(8) ::
     &      gm,rp(3),gls(5,3),pa(3),pb(3),pc(3),vt,vb,gpc2
          gm=e1i+e2i
          val=2d0*PI/gm*EXP(-e1i*e2i*SUM((r1-r2)**2)/gm)
          rp(:)=(e1i*r1(:)+e2i*r2(:))/gm
          pa(:)=rp(:)-r1(:)
          pb(:)=rp(:)-r2(:)
          pc(:)=rp(:)-r3(:)
          gpc2=gm*SUM(pc**2)
          do ix=1,3
            call glist_(l1(ix),l2(ix),pa(ix),pb(ix),pc(ix),gm,gls(:,ix))
          end do
          vt=0d0
          do ii=0,l1(1)+l2(1)
            do jj=0,l1(2)+l2(2)
              do kk=0,l1(3)+l2(3)
                call boys_(ii+jj+kk,gpc2,vb)
                vt=vt+gls(ii+1,1)*gls(jj+1,2)*gls(kk+1,3)*vb
              end do
            end do
          end do
          val=val*vt
        end subroutine

        subroutine boys_(n,x,val)
          ! Boys function interface.
          implicit none
          integer,parameter::NMAX=10
          integer,intent(in)::n
          real(8),intent(in)::x
          real(8),intent(out)::val
          if (x<1d-6) then
            val=1d0/(2d0*n+1)-x/(2d0*n+3d0)
          else
            val=fboys_(n,x)
          end if
        end subroutine

        recursive real(8) function fboys_(n,x) result(v)
          ! Reculsive implementation of Boys function.
          implicit none
          integer,intent(in)::n
          real(8),intent(in)::x
          real(8)::expmx
          if (n==0) then
            v=SQRT(PI/x)*ERF(SQRT(x))/2d0
          else
            ! Avoiding underflow:
            expmx=0d0
            if (x<1d3) then
              expmx=EXP(-x)
            end if
            v=((2*n-1)*fboys_(n-1,x)-expmx)/(2d0*x)
          end if
        end function

        subroutine glist_(l1w,l2w,paw,pbw,pcw,gm,glsw)
          implicit none
          integer,intent(in)::l1w,l2w
          real(8),intent(in)::paw,pbw,pcw,gm
          real(8),intent(out)::glsw(:)
          real(8)::f0,f1,f2,f3
          glsw(:)=0d0
          if (l1w+l2w==0) then
            glsw(1)=1d0
          else if (l1w+l2w==1) then
            call fcoef_(0,l1w,l2w,paw,pbw,f0)
            glsw(1)=f0
            glsw(2)=-pcw
          else if (l1w+l2w==2) then
            call fcoef_(0,l1w,l2w,paw,pbw,f0)
            call fcoef_(1,l1w,l2w,paw,pbw,f1)
            glsw(1)=f0+1/(2*gm)
            glsw(2)=-f1*pcw-1/(2*gm)
            glsw(3)=pcw**2
          else if (l1w+l2w==3) then
            call fcoef_(0,l1w,l2w,paw,pbw,f0)
            call fcoef_(1,l1w,l2w,paw,pbw,f1)
            call fcoef_(2,l1w,l2w,paw,pbw,f2)
            glsw(1)=f0+f2/(2*gm)
            glsw(2)=-f1*pcw-f2/(2*gm)-3*pcw/(2*gm)
            glsw(3)=f2*pcw**2+3*pcw/(2*gm)
            glsw(4)=-pcw**3
          else if (l1w+l2w==4) then
            call fcoef_(0,l1w,l2w,paw,pbw,f0)
            call fcoef_(1,l1w,l2w,paw,pbw,f1)
            call fcoef_(2,l1w,l2w,paw,pbw,f2)
            call fcoef_(3,l1w,l2w,paw,pbw,f3)
            glsw(1)=f0+f2/(2*gm)+3/(4*gm**2)
            glsw(2)=-f1*pcw-f2/(2*gm)-3*pcw*f3/gm-3/(2*gm**2)
            glsw(3)=f2*pcw**2+3*pcw*f3/(2*gm)+3*pcw**2/gm+3/(4*gm**2)
            glsw(4)=-f3*pcw**3-3*pcw**2/gm
            glsw(5)=pcw**4
          else
            write(*,'("error: out of range: glist_()")')
            stop 1
          end if
        end subroutine

        subroutine eval_repulse(
     &      n1,n2,n3,n4,c1,c2,c3,c4,e1,e2,e3,e4,
     &      r1,r2,r3,r4,l1,l2,l3,l4,val)
          implicit none
          integer,intent(in)::n1,n2,n3,n4,l1(3),l2(3),l3(3),l4(3)
          real(8),intent(in)::
     &      c1(n1),c2(n2),c3(n3),c4(n4),e1(n1),e2(n2),e3(n3),e4(n4),
     &      r1(3),r2(3),r3(3),r4(3)
          real(8),intent(out)::val
          real(8)::vt
          integer::i,j,k,l
          val=0d0
          do i=1,n1
            do j=1,n2
              do k=1,n3
                do l=1,n4
                  call repulse_pg_(
     &              e1(i),e2(j),e3(k),e4(l),r1,r2,r3,r4,l1,l2,l3,l4,vt)
                  vt=vt*pgn_(l1,e1(i))*pgn_(l2,e2(j))
                  vt=vt*pgn_(l3,e3(k))*pgn_(l4,e4(l))
                  vt=vt*c1(i)*c2(j)*c3(k)*c4(l)
                  val=val+vt
                end do
              end do
            end do
          end do
        end subroutine

        subroutine repulse_pg_(
     &      e1i,e2i,e3i,e4i,r1,r2,r3,r4,l1,l2,l3,l4,val)
          implicit none
          integer,intent(in)::l1(3),l2(3),l3(3),l4(3)
          real(8),intent(in) ::
     &      e1i,e2i,e3i,e4i,r1(3),r2(3),r3(3),r4(3)
          real(8),intent(out)::val
          integer::ix,ii,jj,kk
          real(8)::gm1,gm2,rp(3),rq(3),rab2,rcd2,rpq2,delta,
     &      cls(9,3),vt,vb
          gm1=e1i+e2i
          gm2=e3i+e4i
          rp(:)=(e1i*r1(:)+e2i*r2(:))/gm1
          rq(:)=(e3i*r3(:)+e4i*r4(:))/gm2
          rab2=SUM((r1-r2)**2)
          rcd2=SUM((r3-r4)**2)
          rpq2=SUM((rp-rq)**2)
          delta=(1d0/gm1+1d0/gm2)/4d0
          val=1d0
          val=val*2*PI**2.5/(gm1*gm2)/((gm1+gm2)**0.5)
          val=val*EXP(-(e1i*e2i*rab2/gm1)-(e3i*e4i*rcd2/gm2))
          if (ABS(val)>TWOETOL) then
            do ix=1,3
              call clist_(
     &          r1(ix),l1(ix),r2(ix),l2(ix),rp(ix),e1i+e2i,
     &          r3(ix),l3(ix),r4(ix),l4(ix),rq(ix),e3i+e4i,cls(:,ix))
            end do
            vt=0d0
            do ii=0,l1(1)+l2(1)+l3(1)+l4(1)
              do jj=0,l1(2)+l2(2)+l3(2)+l4(2)
                do kk=0,l1(3)+l2(3)+l3(3)+l4(3)
                  call boys_(ii+jj+kk,rpq2/(4*delta),vb)
                  vt=vt+cls(ii+1,1)*cls(jj+1,2)*cls(kk+1,3)*vb
                end do
              end do
            end do
            val=val*vt
          end if
        end subroutine

        subroutine clist_(
     &      raw,l1w,rbw,l2w,rpw,gm1,rcw,l3w,rdw,l4w,rqw,gm2,clsw)
          implicit none
          integer,intent(in)::l1w,l2w,l3w,l4w
          real(8),intent(in)::raw,rbw,rpw,gm1,rcw,rdw,rqw,gm2
          real(8),intent(out)::clsw(:)
          real(8)::pa,pb,qc,qd,delta,hls1(5),hls2(5),f3n,f3d
          integer::i,j,ii,u
          pa=rpw-raw
          pb=rpw-rbw
          qc=rqw-rcw
          qd=rqw-rdw
          delta=0.25d0*(1d0/gm1+1d0/gm2)
          clsw(:)=0d0
          call hlist_(l1w,l2w,pa,pb,gm1,hls1)
          call hlist_(l3w,l4w,qc,qd,gm2,hls2)
          do i=0,l1w+l2w
            do j=0,l3w+l4w
              do u=0,INT(FLOOR((i+j)/2d0))
                f3n=1d0
                f3n=f3n*nfact_(i+j)*(-1)**u
                f3n=f3n*(rqw-rpw)**(i+j-2*u)
                f3d=1d0
                f3d=f3d*nfact_(u)
                f3d=f3d*nfact_(i+j-2*u)
                f3d=f3d*delta**(i+j-u)
                ii=i+j-u+1
                if (ii>SIZE(clsw)) then
                  write(*,'("error: out of range: clist_()")')
                  stop 1
                end if
                clsw(ii)=clsw(ii)+hls1(i+1)*(-1)**j*hls2(j+1)*f3n/f3d
              end do
            end do
          end do
        end subroutine

        integer function nfact_(i)
          implicit none
          integer,intent(in)::i
          integer,parameter::
     &      MX=10,NLS(MX)=(/1,1,2,6,24,120,720,5040,40320,362880/)
          if (i+1>MX) then
            write(*,'("error: out of range: ncact()")')
            stop 1
          end if
          nfact_=NLS(i+1)
        end function

        subroutine hlist_(l1w0,l2w0,pa0,pb0,gm,hls)
          implicit none
          integer,intent(in)::l1w0,l2w0
          real(8),intent(in)::pa0,pb0,gm
          integer::l1w,l2w
          real(8)::pa,pb
          real(8),intent(out)::hls(:)
          if (l1w0>=l2w0) then
            l1w=l1w0
            l2w=l2w0
            pa=pa0
            pb=pb0
          else
            l1w=l2w0
            l2w=l1w0
            pa=pb0
            pb=pa0
          end if
          hls(:)=0d0
          if (l1w==0.and.l2w==0) then
            hls(1)=1d0
          else if (l1w==1.and.l2w==0) then
            hls(1)=pa
            hls(2)=1/(4*gm)
          else if (l1w==1.and.l2w==1) then
            hls(1)=pa*pb+1d0/(2*gm)
            hls(2)=(pa+pb)/(4*gm)
            hls(3)=1/(4*gm)**2
          else if (l1w==2.and.l2w==0) then
            hls(1)=pa**2+1d0/(2*gm)
            hls(2)=pa/(2*gm)
            hls(3)=1/(4*gm)**2
          else if (l1w==2.and.l2w==1) then
            hls(1)=pa**2*pb+(2*pa+pb)/(2*gm)
            hls(2)=(2*pa*pb+pa**2)/(4*gm)+6*(1/(4*gm)**2)
            hls(3)=(2*pa+pb)*(1/(4*gm))**2
            hls(4)=(1/(4*gm))**3
          else if (l1w==2.and.l2w==2) then
            hls(1)=(pa*pb)**2+(pa**2+4*pa*pb+pb**2)/(2*gm)
     &        +12*(1/(4*gm)**2)
            hls(2)=pa*pb*(pa+pb)/(2*gm)+12*(pa+pb)*(1/(4*gm))**2
            hls(3)=(pa**2+4*pa*pb+pb**2)*(1/(4*gm))**2+12*(1/(4*gm))**3
            hls(4)=2*(pa+pb)*(1/(4*gm))**3
            hls(5)=(1/(4*gm))**4
          else
            write(*,'("error: out of range: hlist_()")')
            stop 1
          end if
        end subroutine

        subroutine eval_velocity(n1,n2,c1,c2,e1,e2,r1,r2,l1,l2,ix,val)
          implicit none
          integer,intent(in)::n1,n2,l1(3),l2(3),ix
          real(8),intent(in)::c1(n1),c2(n2),e1(n1),e2(n2),r1(3),r2(3)
          real(8),intent(out)::val
          integer::i,j
          real(8)::vt
          val=0d0
          do i=1,n1
            do j=1,n2
              call velocity_pg_(e1(i),e2(j),r1,r2,l1,l2,ix,vt)
              vt=vt*pgn_(l1,e1(i))*pgn_(l2,e2(j))
              vt=vt*c1(i)*c2(j)
              val=val+vt
            end do
          end do
        end subroutine

        subroutine velocity_pg_(e1i,e2i,r1,r2,l1,l2,ix,val)
          implicit none
          integer,intent(in)::l1(3),l2(3),ix
          real(8),intent(in)::e1i,e2i,r1(3),r2(3)
          real(8),intent(out)::val
          integer::lps(3)
          real(8)::vt
          lps(:)=0
          lps(ix)=lps(ix)+1
          call overlap_pg_(e1i,e2i,r1,r2,l1,l2+lps,vt)
          val=-2d0*e2i*vt
          if (l2(ix)>0) then
            call overlap_pg_(e1i,e2i,r1,r2,l1,l2-lps,vt)
            val=val+l2(ix)*vt
          end if
        end subroutine

      end module


*DECK SCNRM2
      REAL FUNCTION SCNRM2 (N, CX, INCX)
C***BEGIN PROLOGUE  SCNRM2
C***PURPOSE  Compute the unitary norm of a complex vector.
C***LIBRARY   SLATEC (BLAS)
C***CATEGORY  D1A3B
C***TYPE      COMPLEX (SNRM2-S, DNRM2-D, SCNRM2-C)
C***KEYWORDS  BLAS, EUCLIDEAN LENGTH, EUCLIDEAN NORM, L2,
C             LINEAR ALGEBRA, UNITARY, VECTOR
C***AUTHOR  Lawson, C. L., (JPL)
C           Hanson, R. J., (SNLA)
C           Kincaid, D. R., (U. of Texas)
C           Krogh, F. T., (JPL)
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of Parameters
C
C     --Input--
C        N  number of elements in input vector(s)
C       CX  complex vector with N elements
C     INCX  storage spacing between elements of CX
C
C     --Output--
C   SCNRM2  single precision result (zero if N .LE. 0)
C
C     Unitary norm of the complex N-vector stored in CX with storage
C     increment INCX.
C     If N .LE. 0, return with result = 0.
C     If N .GE. 1, then INCX must be .GE. 1
C
C     Four phase method using two built-in constants that are
C     hopefully applicable to all machines.
C         CUTLO = maximum of  SQRT(U/EPS)  over all known machines.
C         CUTHI = minimum of  SQRT(V)      over all known machines.
C     where
C         EPS = smallest no. such that EPS + 1. .GT. 1.
C         U   = smallest positive no.   (underflow limit)
C         V   = largest  no.            (overflow  limit)
C
C     Brief outline of algorithm.
C
C     Phase 1 scans zero components.
C     Move to phase 2 when a component is nonzero and .LE. CUTLO
C     Move to phase 3 when a component is .GT. CUTLO
C     Move to phase 4 when a component is .GE. CUTHI/M
C     where M = N for X() real and M = 2*N for complex.
C
C     Values for CUTLO and CUTHI.
C     From the environmental parameters listed in the IMSL converter
C     document the limiting values are as follows:
C     CUTLO, S.P.   U/EPS = 2**(-102) for  Honeywell.  Close seconds are
C                   Univac and DEC at 2**(-103)
C                   Thus CUTLO = 2**(-51) = 4.44089E-16
C     CUTHI, S.P.   V = 2**127 for Univac, Honeywell, and DEC.
C                   Thus CUTHI = 2**(63.5) = 1.30438E19
C     CUTLO, D.P.   U/EPS = 2**(-67) for Honeywell and DEC.
C                   Thus CUTLO = 2**(-33.5) = 8.23181D-11
C     CUTHI, D.P.   same as S.P.  CUTHI = 1.30438D19
C     DATA CUTLO, CUTHI /8.232D-11,  1.304D19/
C     DATA CUTLO, CUTHI /4.441E-16,  1.304E19/
C
C***REFERENCES  C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T.
C                 Krogh, Basic linear algebra subprograms for Fortran
C                 usage, Algorithm No. 539, Transactions on Mathematical
C                 Software 5, 3 (September 1979), pp. 308-323.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   791001  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  SCNRM2
      LOGICAL IMAG, SCALE
      INTEGER NEXT
      REAL CUTLO, CUTHI, HITEST, SUM, XMAX, ABSX, ZERO, ONE
      COMPLEX CX(*)
      SAVE CUTLO, CUTHI, ZERO, ONE
      DATA ZERO, ONE /0.0E0, 1.0E0/
C
      DATA CUTLO, CUTHI /4.441E-16,  1.304E19/
C***FIRST EXECUTABLE STATEMENT  SCNRM2
      IF (N .GT. 0) GO TO 10
         SCNRM2  = ZERO
         GO TO 300
C
   10 ASSIGN 30 TO NEXT
      SUM = ZERO
      NN = N * INCX
C
C                                                 BEGIN MAIN LOOP
C
      DO 210 I = 1,NN,INCX
         ABSX = ABS(REAL(CX(I)))
         IMAG = .FALSE.
         GO TO NEXT,(30, 50, 70, 90, 110)
   30 IF (ABSX .GT. CUTLO) GO TO 85
      ASSIGN 50 TO NEXT
      SCALE = .FALSE.
C
C                        PHASE 1.  SUM IS ZERO
C
   50 IF (ABSX .EQ. ZERO) GO TO 200
      IF (ABSX .GT. CUTLO) GO TO 85
C
C                                PREPARE FOR PHASE 2.
C
      ASSIGN 70 TO NEXT
      GO TO 105
C
C                                PREPARE FOR PHASE 4.
C
  100 ASSIGN 110 TO NEXT
      SUM = (SUM / ABSX) / ABSX
  105 SCALE = .TRUE.
      XMAX = ABSX
      GO TO 115
C
C                   PHASE 2.  SUM IS SMALL.
C                             SCALE TO AVOID DESTRUCTIVE UNDERFLOW.
C
   70 IF (ABSX .GT. CUTLO) GO TO 75
C
C                     COMMON CODE FOR PHASES 2 AND 4.
C                     IN PHASE 4 SUM IS LARGE.  SCALE TO AVOID OVERFLOW.
C
  110 IF (ABSX .LE. XMAX) GO TO 115
         SUM = ONE + SUM * (XMAX / ABSX)**2
         XMAX = ABSX
         GO TO 200
C
  115 SUM = SUM + (ABSX/XMAX)**2
      GO TO 200
C
C                  PREPARE FOR PHASE 3.
C
   75 SUM = (SUM * XMAX) * XMAX
C
   85 ASSIGN 90 TO NEXT
      SCALE = .FALSE.
C
C     FOR REAL OR D.P. SET HITEST = CUTHI/N
C     FOR COMPLEX      SET HITEST = CUTHI/(2*N)
C
      HITEST = CUTHI / N
C
C                   PHASE 3.  SUM IS MID-RANGE.  NO SCALING.
C
   90 IF (ABSX .GE. HITEST) GO TO 100
         SUM = SUM + ABSX**2
  200 CONTINUE
C
C                  CONTROL SELECTION OF REAL AND IMAGINARY PARTS.
C
      IF (IMAG) GO TO 210
         ABSX = ABS(AIMAG(CX(I)))
         IMAG = .TRUE.
      GO TO NEXT,(  50, 70, 90, 110 )
C
  210 CONTINUE
C
C              END OF MAIN LOOP.
C              COMPUTE SQUARE ROOT AND ADJUST FOR SCALING.
C
      SCNRM2 = SQRT(SUM)
      IF (SCALE) SCNRM2 = SCNRM2 * XMAX
  300 CONTINUE
      RETURN
      END


#define DAT 0
#include "ButterflyPACK_config.fi"

module APPLICATION_MODULE_FULL_SIMPLE
use BPACK_DEFS
implicit none

	!**** define your application-related variables here
	type quant_app
		complex(kind=8), allocatable :: matU_glo(:,:),matV_glo(:,:) ! Full Matrix: the random LR matrix to sample its entries
		complex(kind=8), allocatable :: matZ_glo(:,:) ! Full Matrix: Full matrix read from files
		real(kind=8), allocatable :: locations(:,:) ! geometrical points
		integer:: rank
		integer:: Nunk
		integer:: Ndim
		real(kind=8):: lambda
		CHARACTER (LEN=1000) DATA_DIR
		CHARACTER (LEN=1000) GEO_DIR
		integer:: tst=1
	end type quant_app

contains

	!**** user-defined subroutine to sample Z_mn as two LR products
	subroutine Zelem_LR(m,n,value_e,quant)
		use BPACK_DEFS
		implicit none

		class(*),pointer :: quant
		integer, INTENT(IN):: m,n
		complex(kind=8)::value_e
		integer ii

		integer dimn

		select TYPE(quant)
		type is (quant_app)
			value_e = 0
			do ii=1,quant%rank
				value_e = value_e + quant%matU_glo(m,ii)*quant%matV_glo(ii,n)
			enddo
			if(m==n)then
				value_e = value_e + quant%lambda
			endif

			! value_e = quant%matZ_glo(m,n)
		class default
			write(*,*)"unexpected type"
			stop
		end select
	end subroutine Zelem_LR

	!**** user-defined subroutine to sample Z_mn as full matrix
	subroutine Zelem_FULL(m,n,value,quant)
		use BPACK_DEFS
		implicit none

		class(*),pointer :: quant
		integer, INTENT(IN):: m,n
		complex(kind=8)::value
		integer ii

		integer dimn

		select TYPE(quant)
		type is (quant_app)
			value = quant%matZ_glo(m,n)
		class default
			write(*,*)"unexpected type"
			stop
		end select
	end subroutine Zelem_FULL
end module APPLICATION_MODULE_FULL_SIMPLE

PROGRAM ButterflyPACK_TEMPLATE
    use BPACK_DEFS
    use APPLICATION_MODULE_FULL_SIMPLE
	use BPACK_Solve_Mul

	use BPACK_structure
	use BPACK_factor
	use BPACK_constr
	use omp_lib
	use MISC_Utilities
	use BPACK_constr
    implicit none

    integer rank,ii
	real(kind=8),allocatable:: datain(:)

	integer :: ierr
	type(Hoption),target::option
	type(Hstat),target::stats
	type(mesh),target::msh
	type(kernelquant),target::ker
	type(quant_app),target::quant
	type(Bmatrix),target::bmat
	integer,allocatable:: groupmembers(:)
	integer nmpi
	integer level,Maxlevel
	type(proctree),target::ptree
	integer,allocatable::Permutation(:)
	integer Nunk_loc
	integer,allocatable::tree(:)
	complex(kind=8),allocatable::rhs_glo(:,:),rhs_loc(:,:),x_glo(:,:),x_loc(:,:)
	integer nrhs

	!**** nmpi and groupmembers should be provided by the user
	call MPI_Init(ierr)
	call MPI_Comm_size(MPI_Comm_World,nmpi,ierr)
	allocate(groupmembers(nmpi))
	do ii=1,nmpi
		groupmembers(ii)=(ii-1)
	enddo

	!**** create the process tree
	call CreatePtree(nmpi,groupmembers,MPI_Comm_World,ptree)
	deallocate(groupmembers)
	!**** initialize stats and option
	call InitStat(stats)
	call SetDefaultOptions(option)

	!**** set solver parameters
	option%ErrSol=1  ! whether or not checking the factorization accuracy
	option%format=  HODLR! HMAT!   ! the hierarhical format
	option%near_para=2.01d0        ! admissibiltiy condition, not referenced if option%format=  HODLR
	option%verbosity=1             ! verbosity level
	option%LRlevel=0             ! 0: low-rank compression 100: butterfly compression

	quant%tst = 2 ! 1: use a LR product as the kernel, 2: read the full matrix from a file as the kernel
	quant%DATA_DIR = '../EXAMPLE/FULLMAT_DATA/K05N4096.csv' ! file storing the full matrix
	quant%Nunk = 4096  ! matrix size
	quant%rank = 6   ! rank of the LR product kernel
	option%nogeo = 1  ! 1. no geometry info available. 2. geometry info available

	if(option%nogeo==1)then
		! no geometry points available
		option%xyzsort=NATURAL ! no reordering will be perfomed
	else
		! geometry points available
		option%xyzsort=TM ! no reordering will be perfomed
		option%knn=20   ! neareat neighbour points per geometry point, which helps improving the compression accuracy
		quant%GEO_DIR = '../EXAMPLE/FULLMAT_DATA/Geometry_3D.csv' ! file storing the geometry
		quant%Ndim = 3 ! dimension of the geometry information, not referenced if option%nogeo=1
	endif

	call PrintOptions(option,ptree)

!******************************************************************************!
! generate a LR matrix as two matrix product
	if(quant%tst==1)then
		allocate(tree(1))
		tree=quant%Nunk
		!**** Get matrix size and rank and create the matrix
		quant%lambda = 1d5
		allocate(quant%matU_glo(quant%Nunk,quant%rank))
		call RandomMat(quant%Nunk,quant%rank,quant%rank,quant%matU_glo,0)
		call MPI_Bcast(quant%matU_glo,quant%Nunk*quant%rank,MPI_DT,Main_ID,ptree%Comm,ierr)

		allocate(quant%matV_glo(quant%rank,quant%Nunk))
		call RandomMat(quant%rank,quant%Nunk,quant%rank,quant%matV_glo,0)
		call MPI_Bcast(quant%matV_glo,quant%Nunk*quant%rank,MPI_DT,Main_ID,ptree%Comm,ierr)
	   !***********************************************************************
	   if(ptree%MyID==Main_ID)then
	   write (*,*) ''
	   write (*,*) 'Random LR Kernel computing'
	   write (*,*) 'Matrix size:', quant%Nunk
       write (*,*) ''
	   endif
	   !***********************************************************************

		!**** register the user-defined function and type in ker
		ker%QuantApp => quant
		ker%FuncZmn => Zelem_LR

		!**** initialization of the construction phase
		allocate(Permutation(quant%Nunk))
		call BPACK_construction_Init(quant%Nunk,Permutation,Nunk_loc,bmat,option,stats,msh,ker,ptree)
		call MPI_Bcast(Permutation,quant%Nunk,MPI_integer,0,ptree%comm,ierr)
	endif

!******************************************************************************!
! generate a full matrix stored in a files
	if(quant%tst==2)then
		allocate(tree(1))
		tree=quant%Nunk

		!**** Get matrix size and rank and create the matrix
		allocate(quant%matZ_glo(quant%Nunk,quant%Nunk))

		!***** assuming reading one row every time, reading a real matrix stored in file as a complex matrix
		allocate(datain(quant%Nunk))
		if(ptree%MyID==Main_ID)then
		open(10, file=quant%DATA_DIR)
		do ii=1,quant%Nunk
			read(10,*) datain
			quant%matZ_glo(ii,:)=datain(:)
		enddo
		close(10)
		endif
		deallocate(datain)

		call MPI_Bcast(quant%matZ_glo,quant%Nunk*quant%Nunk,MPI_DT,Main_ID,ptree%Comm,ierr)

		if(option%nogeo==0)then
			!***** assuming reading one dimension each time, the geometry is used to partition the matrix
			allocate(quant%locations(quant%Ndim,quant%Nunk))
			quant%locations=0
			allocate(datain(quant%Nunk))
			open(10, file=quant%GEO_DIR)
			do ii=1,quant%Ndim
				read(10,*) datain(:)
				quant%locations(ii,:)=datain(:)
			enddo
			close(10)
			deallocate(datain)
		endif

	   !***********************************************************************
		if(ptree%MyID==Main_ID)then
			write (*,*) ''
			write (*,*) 'FullMat computing'
			write (*,*) 'Matrix size:', quant%Nunk
			write (*,*) ''
		endif
		!***********************************************************************

		!**** register the user-defined function and type in ker
		ker%QuantApp => quant
		ker%FuncZmn => Zelem_FULL

		!**** initialization of the construction phase
		allocate(Permutation(quant%Nunk))
		call BPACK_construction_Init(quant%Nunk,Permutation,Nunk_loc,bmat,option,stats,msh,ker,ptree,Coordinates=quant%locations,tree=tree)
		call MPI_Bcast(Permutation,quant%Nunk,MPI_integer,0,ptree%comm,ierr)
		deallocate(tree)
	endif

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

	!**** computation of the construction phase
    call BPACK_construction_Element(bmat,option,stats,msh,ker,ptree)

	if(quant%tst==2)deallocate(quant%matZ_glo)

	!**** factorization phase
    call BPACK_Factorization(bmat,option,stats,ptree,msh)

	!**** generate testing RHSs stored globally on each rank
	nrhs=2
	allocate(rhs_glo(quant%Nunk,nrhs))
	allocate(x_glo(quant%Nunk,nrhs))
	rhs_glo=1d0
	call MPI_Bcast(rhs_glo,quant%Nunk*nrhs,MPI_DOUBLE_COMPLEX,0,ptree%comm,ierr)

	!**** convert global RHSs to local RHSs
	allocate(rhs_loc(msh%idxe-msh%idxs+1,nrhs))
	allocate(x_loc(msh%idxe-msh%idxs+1,nrhs))
	x_loc=0
	do ii=1,msh%idxe-msh%idxs+1
		rhs_loc(ii,:) = rhs_glo(Permutation(ii+msh%idxs-1),:)
	end do

	!**** call the solve routine
	call BPACK_Solution(bmat,x_loc,rhs_loc,msh%idxe-msh%idxs+1,1,option,ptree,stats)

	!**** convert local solutions to global solutions
	x_glo=0
	do ii=1,msh%idxe-msh%idxs+1
		x_glo(Permutation(ii+msh%idxs-1),:) = x_loc(ii,:)
	end do
	call MPI_ALLREDUCE(MPI_IN_PLACE,x_glo,quant%Nunk*nrhs,MPI_DOUBLE_COMPLEX,MPI_SUM, ptree%Comm, ierr)

	!**** print statistics
	call PrintStat(stats,ptree)

	if(allocated(quant%matU_glo))deallocate(quant%matU_glo)
	if(allocated(quant%matV_glo))deallocate(quant%matV_glo)
	if(allocated(quant%matZ_glo))deallocate(quant%matZ_glo)

	call delete_proctree(ptree)
	call delete_Hstat(stats)
	call delete_mesh(msh)
	call delete_kernelquant(ker)
	call BPACK_delete(bmat)

	deallocate(Permutation)

    if(ptree%MyID==Main_ID .and. option%verbosity>=0)write(*,*) "-------------------------------program end-------------------------------------"

	call blacs_exit(1)
	call MPI_Finalize(ierr)

end PROGRAM ButterflyPACK_TEMPLATE


program main
!Calculate the effective interaction.

use gauss_legendre
use bonn
use ab
use x
implicit none

	integer :: c1
	real(8), dimension(ss,2) :: xi0_k,xi_k

	complex, dimension(ss) :: B0
	complex, dimension(ss) :: B12,B6
	complex, dimension(ss) :: B3,B4,B5

	call T0(B0,q,T,cutoff0_inf)
	call T_12_6(B12,B6,q,T)
	call T_3_4_5(B3,B4,B5,q,T)

	open(unit = 10, file = 'calc/g0_0.d')
	open(unit = 20, file = 'calc/g12_0.d')
	open(unit = 30, file = 'calc/g6_0.d')
	open(unit = 40, file = 'calc/g3_0.d')
	open(unit = 50, file = 'calc/g4_0.d')
	open(unit = 60, file = 'calc/g5_0.d')

! 	open(unit = 10, file = 'calc/g0_1.d')
! 	open(unit = 20, file = 'calc/g12_1.d')
! 	open(unit = 30, file = 'calc/g6_1.d')
! 	open(unit = 40, file = 'calc/g3_1.d')
! 	open(unit = 50, file = 'calc/g4_1.d')
! 	open(unit = 60, file = 'calc/g5_1.d')

	call xi(q,xi0_k,cutoff0_inf)
	call xi(q,xi_k,cutoff_inf)

	!^0g
	do c1 = 1,ss

		write(10,*) real( B0(c1) ),aimag( B0(c1) ),xi0_k(c1,1),xi0_k(c1,2)

	enddo

	!^12g,g_6
	do c1 = 1,ss

		write(20,*) real( B12(c1) ),aimag( B12(c1) ),xi_k(c1,1),xi_k(c1,2)
		write(30,*) real( B6(c1) ),aimag( B6(c1) ),xi_k(c1,1),xi_k(c1,2)

	enddo

	!g_3,g_4,g_5
	do c1 = 1,ss

		write(40,*) real( B3(c1) ),aimag( B3(c1) ),xi_k(c1,1),xi_k(c1,2)
		write(50,*) real( B4(c1) ),aimag( B4(c1) ),xi_k(c1,1),xi_k(c1,2)
		write(60,*) real( B5(c1) ),aimag( B5(c1) ),xi_k(c1,1),xi_k(c1,2)

	enddo

	close(10)
	close(20)
	close(30)
	close(40)
	close(50)
	close(60)

end program


MODULE m_angles

   USE m_types
   USE m_constants

   IMPLICIT NONE

   CONTAINS

   !Calculate the correct phase shifts for the rotation in spin-space
   !(needed for LDA+U and Green's functions with noco%l_mperp)

   SUBROUTINE angles(sym)

      TYPE(t_sym),   INTENT(INOUT)  :: sym

      INTEGER iop,d,t

      sym%phase = 0.0

      DO iop = 1, sym%nop
         d = det(sym%mrot(:,:,iop))
         t = (sym%mrot(1,1,iop)+sym%mrot(2,2,iop)+sym%mrot(3,3,iop)) * d
         IF(t.EQ.-1) sym%phase(iop) = 1.0
         IF(t.EQ.0)  sym%phase(iop) = 2.0/3.0
         IF(t.EQ.1)  sym%phase(iop) = 1.0/2.0
         IF(t.EQ.2)  sym%phase(iop) = 1.0/3.0
         IF(t.EQ.3)  sym%phase(iop) = 0.0
         sym%phase(iop) = d*sym%phase(iop)*pi_const
      ENDDO

   END SUBROUTINE

   INTEGER FUNCTION det(m)
      INTEGER m(:,:)
      det = m(1,1)*m(2,2)*m(3,3) + m(1,2)*m(2,3)*m(3,1) + &
            m(2,1)*m(3,2)*m(1,3) - m(1,3)*m(2,2)*m(3,1) - &
            m(2,3)*m(3,2)*m(1,1) - m(2,1)*m(1,2)*m(3,3)
   END FUNCTION det

END MODULE m_angles