MODULE MATHSUBS

 INTERFACE FFT
  MODULE PROCEDURE r4c8FFT1D,r8c8FFT1D,r4c8FFT2D,r8c8FFT2D,r4c8FFT3D,r8c8FFT3D,r8r8FFT1D
 END INTERFACE FFT

 INTERFACE iFFT
  MODULE PROCEDURE c8r4iFFT1D,c8r8iFFT1D,c8r4iFFT2D,c8r8iFFT2D,c8r4iFFT3D,c8r8iFFT3D,r8r8iFFT1D
 END INTERFACE iFFT

 INTERFACE MEAN
  MODULE PROCEDURE R8MEAN1D,R4MEAN1D,I8MEAN1D,I4MEAN1D,R8MEAN2D,R4MEAN2D,I8MEAN2D,I4MEAN2D,R8MEAN3D,R4MEAN3D,I8MEAN3D,I4MEAN3D
 END INTERFACE MEAN

 INTERFACE STDEV
  MODULE PROCEDURE r8STDEV1D,r4STDEV1D,i8STDEV1D,i4STDEV1D,r8STDEV2D,r4STDEV2D,i8STDEV2D,i4STDEV2D
 END INTERFACE STDEV

 INTERFACE SKEWNESS
  MODULE PROCEDURE r8SKEWNESS1D,r4SKEWNESS1D,i8SKEWNESS1D,i4SKEWNESS1D,r8SKEWNESS2D,r4SKEWNESS2D,i8SKEWNESS2D,i4SKEWNESS2D
 END INTERFACE SKEWNESS

 INTERFACE KURTOSIS
  MODULE PROCEDURE r8KURTOSIS1D,r4KURTOSIS1D,i8KURTOSIS1D,i4KURTOSIS1D,r8KURTOSIS2D,r4KURTOSIS2D,i8KURTOSIS2D,i4KURTOSIS2D
 END INTERFACE KURTOSIS

 INTERFACE ROT180
  MODULE PROCEDURE C4ROT1801D,C8ROT1801D,R8ROT1801D,R4ROT1801D,C4ROT1802D,C8ROT1802D,R8ROT1802D,R4ROT1802D
 END INTERFACE ROT180

 INTERFACE ROTCW90
  MODULE PROCEDURE R4ROTCW902D,R8ROTCW902D,C4ROTCW902D,C8ROTCW902D
 END INTERFACE ROTCW90

 INTERFACE ROTCCW90
  MODULE PROCEDURE R8ROTCCW902D,C8ROTCCW902D
 END INTERFACE ROTCCW90

 INTERFACE MATINV
  MODULE PROCEDURE R8MATINV,C4MATINV
 END INTERFACE MATINV

 INTERFACE KRON
  MODULE PROCEDURE r4KRON,r8KRON
 END INTERFACE KRON

 INTERFACE SLVLINSYS
  MODULE PROCEDURE R8SLVLINSYS
 END INTERFACE SLVLINSYS

 INTERFACE IDMAT
  MODULE PROCEDURE I4IDMAT2D,R4IDMAT2D,R8IDMAT2D,C4IDMAT2D,C8IDMAT2D
 END INTERFACE IDMAT

 INTERFACE ONES
  MODULE PROCEDURE I4ONES1D,I4ONES2D,I4ONES3D
 END INTERFACE ONES

 INTERFACE SECH
  MODULE PROCEDURE R4SECH1D,R8SECH1D,R4SECH2D,R8SECH2D
 END INTERFACE SECH

 INTERFACE ASINH
   MODULE PROCEDURE R8ASINH,R4ASINH
 END INTERFACE

 INTERFACE RAD2DEG
   MODULE PROCEDURE R8RAD2DEG,R4RAD2DEG
 END INTERFACE

 INTERFACE DEG2RAD
   MODULE PROCEDURE R8DEG2RAD,R4DEG2RAD
 END INTERFACE

 INTERFACE ISPOSTV
   MODULE PROCEDURE I4ISPOSTV,I8ISPOSTV,R4ISPOSTV,R8ISPOSTV
 END INTERFACE ISPOSTV

 INTERFACE ADDNOISETO
   MODULE PROCEDURE R4ADDNOISETO1D,R4ADDNOISETO2D,R4ADDNOISETO3D,R8ADDNOISETO1D,R8ADDNOISETO2D,R8ADDNOISETO3D
 END INTERFACE ADDNOISETO

 INTERFACE DATAMAPPING
  MODULE PROCEDURE r4DATAMAPPING1D,r4DATAMAPPING2D,r4DATAMAPPING3D,&
                 & r8DATAMAPPING1D,r8DATAMAPPING2D,r8DATAMAPPING3D
 END INTERFACE DATAMAPPING

 CONTAINS

!**********************************************************************
!********************** FOURIER TRANSFORMATIONS ***********************
!**********************************************************************

 SUBROUTINE r8r8FFT1D(Ifn,Ofn,FFTPLAN)
  USE OMP_LIB
  IMPLICIT NONE
  include "fftw3.f"
  REAL(8),    INTENT(IN)              :: Ifn(:)
  REAL(8),    INTENT(OUT)             :: Ofn(:)
  INTEGER(8), INTENT(INOUT), OPTIONAL :: FFTPLAN
  INTEGER(8)                          :: PLAN
  INTEGER(4)                          :: FERROR
  INTEGER(4)                          :: MATDIMS
  INTEGER(4)                          :: iD1,iD2,iD3
  REAL(8),    ALLOCATABLE             :: iFFTfn(:)
  REAL(8),    ALLOCATABLE             :: oFFTfn(:)

  MATDIMS=SIZE(Ifn)
  ALLOCATE(iFFTfn(MATDIMS))
  ALLOCATE(oFFTfn(MATDIMS))
  iFFTfn=Ifn
  CALL DFFTW_INIT_THREADS(FERROR)
  IF(FERROR.NE.0) CALL DFFTW_PLAN_WITH_NTHREADS(omp_get_max_threads()/2)
  IF((PRESENT(FFTPLAN).EQV..TRUE.).AND.(FFTPLAN.NE.0)) THEN
   CALL DFFTW_EXECUTE_R2R(FFTPLAN,iFFTfn,oFFTfn)
  ELSE IF((PRESENT(FFTPLAN).EQV..TRUE.).AND.(FFTPLAN.EQ.0)) THEN
   CALL DFFTW_PLAN_R2R_1D(FFTPLAN,MATDIMS,iFFTfn,oFFTfn,FFTW_REDFT10,FFTW_ESTIMATE)
   CALL DFFTW_EXECUTE_R2R(FFTPLAN,iFFTfn,oFFTfn)
  ELSE IF(PRESENT(FFTPLAN).EQV..FALSE.) THEN
   CALL DFFTW_PLAN_R2R_1D(PLAN,MATDIMS,iFFTfn,oFFTfn,FFTW_REDFT10,FFTW_ESTIMATE)
   CALL DFFTW_EXECUTE_R2R(PLAN,iFFTfn,oFFTfn)
   CALL DFFTW_DESTROY_PLAN(PLAN)
  END IF
  Ofn=oFFTfn
 !Ofn=oFFTfn/(2.0d0*SQRT(1.0d0*MATDIMS/2.0d0))
 !Ofn(1)=oFFTfn(1)/(2.0d0*SQRT(1.0d0*(MATDIMS+2.0d0)))
 !Ofn(2:MATDIMS)=oFFTfn(2:MATDIMS)/(2.0d0*SQRT(1.0d0*(MATDIMS+2.0d0)/2.0d0))

  RETURN
 END SUBROUTINE r8r8FFT1D

 SUBROUTINE r8r8iFFT1D(Ifn,Ofn,FFTPLAN)
  USE OMP_LIB
  IMPLICIT NONE
  include "fftw3.f"
  REAL(8),    INTENT(IN)              :: Ifn(:)
  REAL(8),    INTENT(OUT)             :: Ofn(:)
  INTEGER(8), INTENT(INOUT), OPTIONAL :: FFTPLAN
  INTEGER(8)                          :: PLAN
  INTEGER(4)                          :: FERROR
  INTEGER(4)                          :: MATDIMS
  INTEGER(4)                          :: iD1,iD2,iD3
  REAL(8),    ALLOCATABLE             :: iFFTfn(:)
  REAL(8),    ALLOCATABLE             :: oFFTfn(:)

  MATDIMS=SIZE(Ifn)
  ALLOCATE(iFFTfn(MATDIMS))
  ALLOCATE(oFFTfn(MATDIMS))
  iFFTfn=Ifn
  CALL DFFTW_INIT_THREADS(FERROR)
  IF(FERROR.NE.0) CALL DFFTW_PLAN_WITH_NTHREADS(omp_get_max_threads()/2)
  IF((PRESENT(FFTPLAN).EQV..TRUE.).AND.(FFTPLAN.NE.0)) THEN
   CALL DFFTW_EXECUTE_R2R(FFTPLAN,iFFTfn,oFFTfn)
  ELSE IF((PRESENT(FFTPLAN).EQV..TRUE.).AND.(FFTPLAN.EQ.0)) THEN
   CALL DFFTW_PLAN_R2R_1D(FFTPLAN,MATDIMS,iFFTfn,oFFTfn,FFTW_REDFT01,FFTW_ESTIMATE)
   CALL DFFTW_EXECUTE_R2R(FFTPLAN,iFFTfn,oFFTfn)
  ELSE IF(PRESENT(FFTPLAN).EQV..FALSE.) THEN
   CALL DFFTW_PLAN_R2R_1D(PLAN,MATDIMS,iFFTfn,oFFTfn,FFTW_REDFT01,FFTW_ESTIMATE)
   CALL DFFTW_EXECUTE_R2R(PLAN,iFFTfn,oFFTfn)
   CALL DFFTW_DESTROY_PLAN(PLAN)
  END IF
  Ofn=oFFTfn
 !Ofn=oFFTfn/(2.0d0*SQRT(1.0d0*MATDIMS/2.0d0))
 !Ofn(1)=oFFTfn(1)/(2.0d0*SQRT(1.0d0*(MATDIMS+2.0d0)))
 !Ofn(2:MATDIMS)=oFFTfn(2:MATDIMS)/(2.0d0*SQRT(1.0d0*(MATDIMS+2.0d0)/2.0d0))

  RETURN
 END SUBROUTINE r8r8iFFT1D

 SUBROUTINE r8c8FFT1D(Rfn,Kfn,FFTPLAN)
  USE OMP_LIB
  IMPLICIT NONE
  include "fftw3.f"
  REAL(8),    INTENT(IN)              :: Rfn(:)
  COMPLEX(8), INTENT(OUT)             :: Kfn(:)
  INTEGER(8), INTENT(INOUT), OPTIONAL :: FFTPLAN
  COMPLEX(8), ALLOCATABLE             :: kFFTfn(:)
  INTEGER(8)                          :: PLAN
  INTEGER(4)                          :: FERROR
  INTEGER(4)                          :: MATDIMS
  INTEGER(4)                          :: iD1,iD2,iD3
  REAL(8),   ALLOCATABLE              :: rFFTfn(:)

  MATDIMS=SIZE(Rfn)
  ALLOCATE(rFFTfn(MATDIMS))
  ALLOCATE(kFFTfn(MATDIMS/2+1))
  rFFTfn=1.0d0*Rfn
  CALL DFFTW_INIT_THREADS(FERROR)
  IF(FERROR.NE.0) CALL DFFTW_PLAN_WITH_NTHREADS(omp_get_max_threads()/2)
  IF((PRESENT(FFTPLAN).EQV..TRUE.).AND.(FFTPLAN.NE.0)) THEN
   CALL DFFTW_EXECUTE_DFT_R2C(FFTPLAN,rFFTfn,kFFTfn)
  ELSE IF((PRESENT(FFTPLAN).EQV..TRUE.).AND.(FFTPLAN.EQ.0)) THEN
   CALL DFFTW_PLAN_DFT_R2C_1D(FFTPLAN,MATDIMS,rFFTfn,kFFTfn,FFTW_ESTIMATE)
   CALL DFFTW_EXECUTE_DFT_R2C(FFTPLAN,rFFTfn,kFFTfn)
  ELSE IF(PRESENT(FFTPLAN).EQV..FALSE.) THEN
   CALL DFFTW_PLAN_DFT_R2C_1D(PLAN,MATDIMS,rFFTfn,kFFTfn,FFTW_ESTIMATE)
   CALL DFFTW_EXECUTE_DFT_R2C(PLAN,rFFTfn,kFFTfn)
   CALL DFFTW_DESTROY_PLAN(PLAN)
  END IF
  Kfn=kFFTfn

  RETURN
 END SUBROUTINE r8c8FFT1D

 SUBROUTINE r4c8FFT1D(Rfn,Kfn,FFTPLAN)
  USE OMP_LIB
  IMPLICIT NONE
  include "fftw3.f"
  REAL(4),    INTENT(IN)              :: Rfn(:)
  COMPLEX(8), INTENT(OUT)             :: Kfn(:)
  INTEGER(8), INTENT(INOUT), OPTIONAL :: FFTPLAN
  COMPLEX(8), ALLOCATABLE             :: kFFTfn(:)
  INTEGER(8)                          :: PLAN
  INTEGER(4)                          :: FERROR
  INTEGER(4)                          :: MATDIMS
  INTEGER(4)                          :: iD1,iD2,iD3
  REAL(8),   ALLOCATABLE              :: rFFTfn(:)

  MATDIMS=SIZE(Rfn)
  ALLOCATE(rFFTfn(MATDIMS))
  ALLOCATE(kFFTfn(MATDIMS/2+1))
  rFFTfn=1.0d0*Rfn
  CALL DFFTW_INIT_THREADS(FERROR)
  IF(FERROR.NE.0) CALL DFFTW_PLAN_WITH_NTHREADS(omp_get_max_threads()/2)
  IF((PRESENT(FFTPLAN).EQV..TRUE.).AND.(FFTPLAN.NE.0)) THEN
   CALL DFFTW_EXECUTE_DFT_R2C(FFTPLAN,rFFTfn,kFFTfn)
  ELSE IF((PRESENT(FFTPLAN).EQV..TRUE.).AND.(FFTPLAN.EQ.0)) THEN
   CALL DFFTW_PLAN_DFT_R2C_1D(FFTPLAN,MATDIMS,rFFTfn,kFFTfn,FFTW_ESTIMATE)
   CALL DFFTW_EXECUTE_DFT_R2C(FFTPLAN,rFFTfn,kFFTfn)
  ELSE IF(PRESENT(FFTPLAN).EQV..FALSE.) THEN
   CALL DFFTW_PLAN_DFT_R2C_1D(PLAN,MATDIMS,rFFTfn,kFFTfn,FFTW_ESTIMATE)
   CALL DFFTW_EXECUTE_DFT_R2C(PLAN,rFFTfn,kFFTfn)
   CALL DFFTW_DESTROY_PLAN(PLAN)
  END IF
  Kfn=kFFTfn

  RETURN
 END SUBROUTINE r4c8FFT1D

 SUBROUTINE c8r8iFFT1D(Kfn,Rfn,iFFTPLAN)
  USE OMP_LIB
  IMPLICIT NONE
  include "fftw3.f"
  REAL(8),    INTENT(OUT)             :: Rfn(:)
  COMPLEX(8), INTENT(IN)              :: Kfn(:)
  INTEGER(8), INTENT(INOUT), OPTIONAL :: iFFTPLAN
  COMPLEX(8), ALLOCATABLE             :: kFFTfn(:)
  INTEGER(8)                          :: iPLAN
  INTEGER(4)                          :: FERROR
  INTEGER(4)                          :: MATDIMS
  INTEGER(4)                          :: iD1,iD2,iD3
  REAL(8),   ALLOCATABLE              :: rFFTfn(:)

  MATDIMS=SIZE(Rfn)
  ALLOCATE(rFFTfn(MATDIMS))
  ALLOCATE(kFFTfn(MATDIMS/2+1))
  kFFTfn=Kfn
  CALL DFFTW_INIT_THREADS(FERROR)
  IF(FERROR.NE.0) CALL DFFTW_PLAN_WITH_NTHREADS(omp_get_max_threads()/2)
  IF((PRESENT(iFFTPLAN).EQV..TRUE.).AND.(iFFTPLAN.NE.0)) THEN
   CALL DFFTW_EXECUTE_DFT_C2R(iFFTPLAN,kFFTfn,rFFTfn)
  ELSE IF((PRESENT(iFFTPLAN).EQV..TRUE.).AND.(iFFTPLAN.EQ.0)) THEN
   CALL DFFTW_PLAN_DFT_C2R_1D(iFFTPLAN,MATDIMS,kFFTfn,rFFTfn,FFTW_ESTIMATE)
   CALL DFFTW_EXECUTE_DFT_C2R(iFFTPLAN,kFFTfn,rFFTfn)
  ELSE IF(PRESENT(iFFTPLAN).EQV..FALSE.) THEN
   CALL DFFTW_PLAN_DFT_C2R_1D(iPLAN,MATDIMS,kFFTfn,rFFTfn,FFTW_ESTIMATE)
   CALL DFFTW_EXECUTE_DFT_C2R(iPLAN,kFFTfn,rFFTfn)
   CALL DFFTW_DESTROY_PLAN(iPLAN)
  END IF
  Rfn=rFFTfn/REAL(MATDIMS,8)

  RETURN
 END SUBROUTINE c8r8iFFT1D

 SUBROUTINE c8r4iFFT1D(Kfn,Rfn,iFFTPLAN)
  USE OMP_LIB
  IMPLICIT NONE
  include "fftw3.f"
  REAL(4),    INTENT(OUT)             :: Rfn(:)
  COMPLEX(8), INTENT(IN)              :: Kfn(:)
  INTEGER(8), INTENT(INOUT), OPTIONAL :: iFFTPLAN
  COMPLEX(8), ALLOCATABLE             :: kFFTfn(:)
  INTEGER(8)                          :: iPLAN
  INTEGER(4)                          :: FERROR
  INTEGER(4)                          :: MATDIMS
  INTEGER(4)                          :: iD1
  REAL(8),   ALLOCATABLE              :: rFFTfn(:)

  MATDIMS=SIZE(Rfn)
  ALLOCATE(rFFTfn(MATDIMS))
  ALLOCATE(kFFTfn(MATDIMS/2+1))
  kFFTfn=Kfn
  CALL DFFTW_INIT_THREADS(FERROR)
  IF(FERROR.NE.0) CALL DFFTW_PLAN_WITH_NTHREADS(omp_get_max_threads()/2)
  IF((PRESENT(iFFTPLAN).EQV..TRUE.).AND.(iFFTPLAN.NE.0)) THEN
   CALL DFFTW_EXECUTE_DFT_C2R(iFFTPLAN,kFFTfn,rFFTfn)
  ELSE IF((PRESENT(iFFTPLAN).EQV..TRUE.).AND.(iFFTPLAN.EQ.0)) THEN
   CALL DFFTW_PLAN_DFT_C2R_1D(iFFTPLAN,MATDIMS,kFFTfn,rFFTfn,FFTW_ESTIMATE)
   CALL DFFTW_EXECUTE_DFT_C2R(iFFTPLAN,kFFTfn,rFFTfn)
  ELSE IF(PRESENT(iFFTPLAN).EQV..FALSE.) THEN
   CALL DFFTW_PLAN_DFT_C2R_1D(iPLAN,MATDIMS,kFFTfn,rFFTfn,FFTW_ESTIMATE)
   CALL DFFTW_EXECUTE_DFT_C2R(iPLAN,kFFTfn,rFFTfn)
   CALL DFFTW_DESTROY_PLAN(iPLAN)
  END IF
  rFFTfn=rFFTfn/REAL(MATDIMS,8)
  DO iD1=1,MATDIMS
   Rfn(iD1)=REAL(rFFTfn(iD1),4)
  END DO

  RETURN
 END SUBROUTINE c8r4iFFT1D

 SUBROUTINE r8c8FFT2D(Rfn,Kfn,FFTPLAN)
  USE OMP_LIB
  IMPLICIT NONE
  include "fftw3.f"
  REAL(8),    INTENT(IN)              :: Rfn(:,:)
  COMPLEX(8), INTENT(OUT)             :: Kfn(:,:)
  INTEGER(8), INTENT(INOUT), OPTIONAL :: FFTPLAN
  COMPLEX(8), ALLOCATABLE             :: kFFTfn(:,:)
  INTEGER(8)                          :: PLAN
  INTEGER(4)                          :: FERROR
  INTEGER(4)                          :: MATDIMS(2)
  INTEGER(4)                          :: M,N
  INTEGER(4)                          :: iD1,iD2
  REAL(8),   ALLOCATABLE              :: rFFTfn(:,:)

  MATDIMS=SHAPE(Rfn)
  M=MATDIMS(1)
  N=MATDIMS(2)
  ALLOCATE(rFFTfn(M,N))
  ALLOCATE(kFFTfn(M/2+1,N))
  rFFTfn=1.0d0*Rfn
  CALL DFFTW_INIT_THREADS(FERROR)
  IF(FERROR.NE.0) CALL DFFTW_PLAN_WITH_NTHREADS(omp_get_max_threads()/2)
  IF((PRESENT(FFTPLAN).EQV..TRUE.).AND.(FFTPLAN.NE.0)) THEN
   CALL DFFTW_EXECUTE_DFT_R2C(FFTPLAN,rFFTfn,kFFTfn)
  ELSE IF((PRESENT(FFTPLAN).EQV..TRUE.).AND.(FFTPLAN.EQ.0)) THEN
   CALL DFFTW_PLAN_DFT_R2C_2D(FFTPLAN,M,N,rFFTfn,kFFTfn,FFTW_ESTIMATE)
   CALL DFFTW_EXECUTE_DFT_R2C(FFTPLAN,rFFTfn,kFFTfn)
  ELSE IF(PRESENT(FFTPLAN).EQV..FALSE.) THEN
   CALL DFFTW_PLAN_DFT_R2C_2D(PLAN,M,N,rFFTfn,kFFTfn,FFTW_ESTIMATE)
   CALL DFFTW_EXECUTE_DFT_R2C(PLAN,rFFTfn,kFFTfn)
   CALL DFFTW_DESTROY_PLAN(PLAN)
  END IF
  Kfn=kFFTfn

  RETURN
 END SUBROUTINE r8c8FFT2D

 SUBROUTINE r4c8FFT2D(Rfn,Kfn,FFTPLAN)
  USE OMP_LIB
  IMPLICIT NONE
  include "fftw3.f"
  REAL(4),    INTENT(IN)              :: Rfn(:,:)
  COMPLEX(8), INTENT(OUT)             :: Kfn(:,:)
  INTEGER(8), INTENT(INOUT), OPTIONAL :: FFTPLAN
  COMPLEX(8), ALLOCATABLE             :: kFFTfn(:,:)
  INTEGER(8)                          :: PLAN
  INTEGER(4)                          :: FERROR
  INTEGER(4)                          :: MATDIMS(2)
  INTEGER(4)                          :: M,N
  INTEGER(4)                          :: iD1,iD2
  REAL(8),   ALLOCATABLE              :: rFFTfn(:,:)

  MATDIMS=SHAPE(Rfn)
  M=MATDIMS(1)
  N=MATDIMS(2)
  ALLOCATE(rFFTfn(M,N))
  ALLOCATE(kFFTfn(M/2+1,N))
  rFFTfn=1.0d0*Rfn
  CALL DFFTW_INIT_THREADS(FERROR)
  IF(FERROR.NE.0) CALL DFFTW_PLAN_WITH_NTHREADS(omp_get_max_threads()/2)
  IF((PRESENT(FFTPLAN).EQV..TRUE.).AND.(FFTPLAN.NE.0)) THEN
   CALL DFFTW_EXECUTE_DFT_R2C(FFTPLAN,rFFTfn,kFFTfn)
  ELSE IF((PRESENT(FFTPLAN).EQV..TRUE.).AND.(FFTPLAN.EQ.0)) THEN
   CALL DFFTW_PLAN_DFT_R2C_2D(FFTPLAN,M,N,rFFTfn,kFFTfn,FFTW_ESTIMATE)
   CALL DFFTW_EXECUTE_DFT_R2C(FFTPLAN,rFFTfn,kFFTfn)
  ELSE IF(PRESENT(FFTPLAN).EQV..FALSE.) THEN
   CALL DFFTW_PLAN_DFT_R2C_2D(PLAN,M,N,rFFTfn,kFFTfn,FFTW_ESTIMATE)
   CALL DFFTW_EXECUTE_DFT_R2C(PLAN,rFFTfn,kFFTfn)
   CALL DFFTW_DESTROY_PLAN(PLAN)
  END IF
  Kfn=kFFTfn

  RETURN
 END SUBROUTINE r4c8FFT2D

 SUBROUTINE c8r8iFFT2D(Kfn,Rfn,iFFTPLAN)
  USE OMP_LIB
  IMPLICIT NONE
  include "fftw3.f"
  REAL(8),    INTENT(OUT)             :: Rfn(:,:)
  COMPLEX(8), INTENT(IN)              :: Kfn(:,:)
  INTEGER(8), INTENT(INOUT), OPTIONAL :: iFFTPLAN
  COMPLEX(8), ALLOCATABLE             :: kFFTfn(:,:)
  INTEGER(8)                          :: iPLAN
  INTEGER(4)                          :: FERROR
  INTEGER(4)                          :: MATDIMS(2)
  INTEGER(4)                          :: M,N
  INTEGER(4)                          :: iD1,iD2
  REAL(8),   ALLOCATABLE              :: rFFTfn(:,:)

  MATDIMS=SHAPE(Rfn)
  M=MATDIMS(1)
  N=MATDIMS(2)
  ALLOCATE(rFFTfn(M,N))
  ALLOCATE(kFFTfn(M/2+1,N))
  kFFTfn=Kfn
  CALL DFFTW_INIT_THREADS(FERROR)
  IF(FERROR.NE.0) CALL DFFTW_PLAN_WITH_NTHREADS(omp_get_max_threads()/2)
  IF((PRESENT(iFFTPLAN).EQV..TRUE.).AND.(iFFTPLAN.NE.0)) THEN
   CALL DFFTW_EXECUTE_DFT_C2R(iFFTPLAN,kFFTfn,rFFTfn)
  ELSE IF((PRESENT(iFFTPLAN).EQV..TRUE.).AND.(iFFTPLAN.EQ.0)) THEN
   CALL DFFTW_PLAN_DFT_C2R_2D(iFFTPLAN,M,N,kFFTfn,rFFTfn,FFTW_ESTIMATE)
   CALL DFFTW_EXECUTE_DFT_C2R(iFFTPLAN,kFFTfn,rFFTfn)
  ELSE IF(PRESENT(iFFTPLAN).EQV..FALSE.) THEN
   CALL DFFTW_PLAN_DFT_C2R_2D(iPLAN,M,N,kFFTfn,rFFTfn,FFTW_ESTIMATE)
   CALL DFFTW_EXECUTE_DFT_C2R(iPLAN,kFFTfn,rFFTfn)
   CALL DFFTW_DESTROY_PLAN(iPLAN)
  END IF
  Rfn=rFFTfn/REAL(M*N,8)

  RETURN
 END SUBROUTINE c8r8iFFT2D

 SUBROUTINE c8r4iFFT2D(Kfn,Rfn,iFFTPLAN)
  USE OMP_LIB
  IMPLICIT NONE
  include "fftw3.f"
  REAL(4),    INTENT(OUT)             :: Rfn(:,:)
  COMPLEX(8), INTENT(IN)              :: Kfn(:,:)
  INTEGER(8), INTENT(INOUT), OPTIONAL :: iFFTPLAN
  COMPLEX(8), ALLOCATABLE             :: kFFTfn(:,:)
  INTEGER(8)                          :: iPLAN
  INTEGER(4)                          :: FERROR
  INTEGER(4)                          :: MATDIMS(2)
  INTEGER(4)                          :: M,N
  INTEGER(4)                          :: iD1,iD2
  REAL(8),   ALLOCATABLE              :: rFFTfn(:,:)

  MATDIMS=SHAPE(Rfn)
  M=MATDIMS(1)
  N=MATDIMS(2)
  ALLOCATE(rFFTfn(M,N))
  ALLOCATE(kFFTfn(M/2+1,N))
  kFFTfn=Kfn
  CALL DFFTW_INIT_THREADS(FERROR)
  IF(FERROR.NE.0) CALL DFFTW_PLAN_WITH_NTHREADS(omp_get_max_threads()/2)
  IF((PRESENT(iFFTPLAN).EQV..TRUE.).AND.(iFFTPLAN.NE.0)) THEN
   CALL DFFTW_EXECUTE_DFT_C2R(iFFTPLAN,kFFTfn,rFFTfn)
  ELSE IF((PRESENT(iFFTPLAN).EQV..TRUE.).AND.(iFFTPLAN.EQ.0)) THEN
   CALL DFFTW_PLAN_DFT_C2R_2D(iFFTPLAN,M,N,kFFTfn,rFFTfn,FFTW_ESTIMATE)
   CALL DFFTW_EXECUTE_DFT_C2R(iFFTPLAN,kFFTfn,rFFTfn)
  ELSE IF(PRESENT(iFFTPLAN).EQV..FALSE.) THEN
   CALL DFFTW_PLAN_DFT_C2R_2D(iPLAN,M,N,kFFTfn,rFFTfn,FFTW_ESTIMATE)
   CALL DFFTW_EXECUTE_DFT_C2R(iPLAN,kFFTfn,rFFTfn)
   CALL DFFTW_DESTROY_PLAN(iPLAN)
  END IF
  rFFTfn=rFFTfn/REAL(M*N,8)
  DO iD1=1,M
   DO iD2=1,N
    Rfn(iD1,iD2)=REAL(rFFTfn(iD1,iD2),4)
   END DO
  END DO

  RETURN
 END SUBROUTINE c8r4iFFT2D

 SUBROUTINE r8c8FFT3D(Rfn,Kfn,FFTPLAN)
  USE OMP_LIB
  IMPLICIT NONE
  include "fftw3.f"
  REAL(8),    INTENT(IN)              :: Rfn(:,:,:)
  COMPLEX(8), INTENT(OUT)             :: Kfn(:,:,:)
  INTEGER(8), INTENT(INOUT), OPTIONAL :: FFTPLAN
  COMPLEX(8), ALLOCATABLE             :: kFFTfn(:,:,:)
  INTEGER(8)                          :: PLAN
  INTEGER(4)                          :: FERROR
  INTEGER(4)                          :: MATDIMS(3)
  INTEGER(4)                          :: L,M,N
  INTEGER(4)                          :: iD1,iD2,iD3
  REAL(8),   ALLOCATABLE              :: rFFTfn(:,:,:)

  MATDIMS=SHAPE(Rfn)
  L=MATDIMS(1)
  M=MATDIMS(2)
  N=MATDIMS(3)
  ALLOCATE(rFFTfn(L,M,N))
  ALLOCATE(kFFTfn(L/2+1,M,N))
  rFFTfn=1.0d0*Rfn
  CALL DFFTW_INIT_THREADS(FERROR)
  IF(FERROR.NE.0) CALL DFFTW_PLAN_WITH_NTHREADS(omp_get_max_threads()/2)
  IF((PRESENT(FFTPLAN).EQV..TRUE.).AND.(FFTPLAN.NE.0)) THEN
   CALL DFFTW_EXECUTE_DFT_R2C(FFTPLAN,rFFTfn,kFFTfn)
  ELSE IF((PRESENT(FFTPLAN).EQV..TRUE.).AND.(FFTPLAN.EQ.0)) THEN
   CALL DFFTW_PLAN_DFT_R2C_3D(FFTPLAN,L,M,N,rFFTfn,kFFTfn,FFTW_ESTIMATE)
   CALL DFFTW_EXECUTE_DFT_R2C(FFTPLAN,rFFTfn,kFFTfn)
  ELSE IF(PRESENT(FFTPLAN).EQV..FALSE.) THEN
   CALL DFFTW_PLAN_DFT_R2C_3D(PLAN,L,M,N,rFFTfn,kFFTfn,FFTW_ESTIMATE)
   CALL DFFTW_EXECUTE_DFT_R2C(PLAN,rFFTfn,kFFTfn)
   CALL DFFTW_DESTROY_PLAN(PLAN)
  END IF
  Kfn=kFFTfn

  RETURN
 END SUBROUTINE r8c8FFT3D

 SUBROUTINE r4c8FFT3D(Rfn,Kfn,FFTPLAN)
  USE OMP_LIB
  IMPLICIT NONE
  include "fftw3.f"
  REAL(4),    INTENT(IN)              :: Rfn(:,:,:)
  COMPLEX(8), INTENT(OUT)             :: Kfn(:,:,:)
  INTEGER(8), INTENT(INOUT), OPTIONAL :: FFTPLAN
  COMPLEX(8), ALLOCATABLE             :: kFFTfn(:,:,:)
  INTEGER(8)                          :: PLAN
  INTEGER(4)                          :: FERROR
  INTEGER(4)                          :: MATDIMS(3)
  INTEGER(4)                          :: L,M,N
  INTEGER(4)                          :: iD1,iD2,iD3
  REAL(8),   ALLOCATABLE              :: rFFTfn(:,:,:)

  MATDIMS=SHAPE(Rfn)
  L=MATDIMS(1)
  M=MATDIMS(2)
  N=MATDIMS(3)
  ALLOCATE(rFFTfn(L,M,N))
  ALLOCATE(kFFTfn(L/2+1,M,N))
  rFFTfn=1.0d0*Rfn
  CALL DFFTW_INIT_THREADS(FERROR)
  IF(FERROR.NE.0) CALL DFFTW_PLAN_WITH_NTHREADS(omp_get_max_threads()/2)
  IF((PRESENT(FFTPLAN).EQV..TRUE.).AND.(FFTPLAN.NE.0)) THEN
   CALL DFFTW_EXECUTE_DFT_R2C(FFTPLAN,rFFTfn,kFFTfn)
  ELSE IF((PRESENT(FFTPLAN).EQV..TRUE.).AND.(FFTPLAN.EQ.0)) THEN
   CALL DFFTW_PLAN_DFT_R2C_3D(FFTPLAN,L,M,N,rFFTfn,kFFTfn,FFTW_ESTIMATE)
   CALL DFFTW_EXECUTE_DFT_R2C(FFTPLAN,rFFTfn,kFFTfn)
  ELSE IF(PRESENT(FFTPLAN).EQV..FALSE.) THEN
   CALL DFFTW_PLAN_DFT_R2C_3D(PLAN,L,M,N,rFFTfn,kFFTfn,FFTW_ESTIMATE)
   CALL DFFTW_EXECUTE_DFT_R2C(PLAN,rFFTfn,kFFTfn)
   CALL DFFTW_DESTROY_PLAN(PLAN)
  END IF
  Kfn=kFFTfn

  RETURN
 END SUBROUTINE r4c8FFT3D

 SUBROUTINE c8r8iFFT3D(Kfn,Rfn,iFFTPLAN)
  USE OMP_LIB
  IMPLICIT NONE
  include "fftw3.f"
  REAL(8),    INTENT(OUT)             :: Rfn(:,:,:)
  COMPLEX(8), INTENT(IN)              :: Kfn(:,:,:)
  INTEGER(8), INTENT(INOUT), OPTIONAL :: iFFTPLAN
  COMPLEX(8), ALLOCATABLE             :: kFFTfn(:,:,:)
  INTEGER(8)                          :: iPLAN
  INTEGER(4)                          :: FERROR
  INTEGER(4)                          :: MATDIMS(3)
  INTEGER(4)                          :: L,M,N
  INTEGER(4)                          :: iD1,iD2,iD3
  REAL(8),   ALLOCATABLE              :: rFFTfn(:,:,:)

  MATDIMS=SHAPE(Rfn)
  L=MATDIMS(1)
  M=MATDIMS(2)
  N=MATDIMS(3)
  ALLOCATE(rFFTfn(L,M,N))
  ALLOCATE(kFFTfn(L/2+1,M,N))
  kFFTfn=Kfn
  CALL DFFTW_INIT_THREADS(FERROR)
  IF(FERROR.NE.0) CALL DFFTW_PLAN_WITH_NTHREADS(omp_get_max_threads()/2)
  IF((PRESENT(iFFTPLAN).EQV..TRUE.).AND.(iFFTPLAN.NE.0)) THEN
   CALL DFFTW_EXECUTE_DFT_C2R(iFFTPLAN,kFFTfn,rFFTfn)
  ELSE IF((PRESENT(iFFTPLAN).EQV..TRUE.).AND.(iFFTPLAN.EQ.0)) THEN
   CALL DFFTW_PLAN_DFT_C2R_3D(iFFTPLAN,L,M,N,kFFTfn,rFFTfn,FFTW_ESTIMATE)
   CALL DFFTW_EXECUTE_DFT_C2R(iFFTPLAN,kFFTfn,rFFTfn)
  ELSE IF(PRESENT(iFFTPLAN).EQV..FALSE.) THEN
   CALL DFFTW_PLAN_DFT_C2R_3D(iPLAN,L,M,N,kFFTfn,rFFTfn,FFTW_ESTIMATE)
   CALL DFFTW_EXECUTE_DFT_C2R(iPLAN,kFFTfn,rFFTfn)
   CALL DFFTW_DESTROY_PLAN(iPLAN)
  END IF
  Rfn=rFFTfn/REAL(L*M*N,8)

  RETURN
 END SUBROUTINE c8r8iFFT3D

 SUBROUTINE c8r4iFFT3D(Kfn,Rfn,iFFTPLAN)
  USE OMP_LIB
  IMPLICIT NONE
  include "fftw3.f"
  REAL(4),    INTENT(OUT)             :: Rfn(:,:,:)
  COMPLEX(8), INTENT(IN)              :: Kfn(:,:,:)
  INTEGER(8), INTENT(INOUT), OPTIONAL :: iFFTPLAN
  COMPLEX(8), ALLOCATABLE             :: kFFTfn(:,:,:)
  INTEGER(8)                          :: iPLAN
  INTEGER(4)                          :: FERROR
  INTEGER(4)                          :: MATDIMS(3)
  INTEGER(4)                          :: L,M,N
  INTEGER(4)                          :: iD1,iD2,iD3
  REAL(8),   ALLOCATABLE              :: rFFTfn(:,:,:)

  MATDIMS=SHAPE(Rfn)
  L=MATDIMS(1)
  M=MATDIMS(2)
  N=MATDIMS(3)
  ALLOCATE(rFFTfn(L,M,N))
  ALLOCATE(kFFTfn(L/2+1,M,N))
  kFFTfn=Kfn
  CALL DFFTW_INIT_THREADS(FERROR)
  IF(FERROR.NE.0) CALL DFFTW_PLAN_WITH_NTHREADS(omp_get_max_threads()/2)
  IF((PRESENT(iFFTPLAN).EQV..TRUE.).AND.(iFFTPLAN.NE.0)) THEN
   CALL DFFTW_EXECUTE_DFT_C2R(iFFTPLAN,kFFTfn,rFFTfn)
  ELSE IF((PRESENT(iFFTPLAN).EQV..TRUE.).AND.(iFFTPLAN.EQ.0)) THEN
   CALL DFFTW_PLAN_DFT_C2R_3D(iFFTPLAN,L,M,N,kFFTfn,rFFTfn,FFTW_ESTIMATE)
   CALL DFFTW_EXECUTE_DFT_C2R(iFFTPLAN,kFFTfn,rFFTfn)
  ELSE IF(PRESENT(iFFTPLAN).EQV..FALSE.) THEN
   CALL DFFTW_PLAN_DFT_C2R_3D(iPLAN,L,M,N,kFFTfn,rFFTfn,FFTW_ESTIMATE)
   CALL DFFTW_EXECUTE_DFT_C2R(iPLAN,kFFTfn,rFFTfn)
   CALL DFFTW_DESTROY_PLAN(iPLAN)
  END IF
  rFFTfn=rFFTfn/REAL(L*M*N,8)
  DO iD1=1,L
   DO iD2=1,M
    DO iD3=1,N
     Rfn(iD1,iD2,iD3)=REAL(rFFTfn(iD1,iD2,iD3),4)
    END DO
   END DO
  END DO

  RETURN
 END SUBROUTINE c8r4iFFT3D

!**********************************************
!*************** MEAN VALUE *******************
!**********************************************
 FUNCTION R8MEAN1D(inMAT)
  IMPLICIT NONE
  REAL(8) :: R8MEAN1D,inMAT(:)

  R8MEAN1D=SUM(inMAT)/SIZE(inMAT)
  RETURN
 END FUNCTION R8MEAN1D

 FUNCTION R4MEAN1D(inMAT)
  IMPLICIT NONE
  REAL(4) :: R4MEAN1D,inMAT(:)

  R4MEAN1D=SUM(inMAT)/SIZE(inMAT)
  RETURN
 END FUNCTION R4MEAN1D

 FUNCTION I8MEAN1D(inMAT)
  IMPLICIT NONE
  INTEGER(8) :: I8MEAN1D,inMAT(:)

  I8MEAN1D=SUM(inMAT)/SIZE(inMAT)
  RETURN
 END FUNCTION I8MEAN1D

 FUNCTION I4MEAN1D(inMAT)
  IMPLICIT NONE
  INTEGER(4) :: I4MEAN1D,inMAT(:)

  I4MEAN1D=SUM(inMAT)/SIZE(inMAT)
  RETURN
 END FUNCTION I4MEAN1D

 FUNCTION r8MEAN2D(inMAT)
  IMPLICIT NONE
  REAL(8)    :: r8MEAN2D,inMAT(:,:)
  INTEGER(4) :: MATDIMS(2)

  MATDIMS=SHAPE(inMAT)
  r8MEAN2D=SUM(inMAT)/(MATDIMS(1)*MATDIMS(2))
 !r8MEAN2D=SUM(inMAT)/SIZE(inMAT)

  RETURN
 END FUNCTION r8MEAN2D

 FUNCTION R4MEAN2D(inMAT)
  IMPLICIT NONE
  REAL(4) :: R4MEAN2D,inMAT(:,:)
  INTEGER(4) :: MATDIMS(2)

  MATDIMS=SHAPE(inMAT)
  r4MEAN2D=SUM(inMAT)/(MATDIMS(1)*MATDIMS(2))
 !R4MEAN2D=SUM(inMAT)/SIZE(inMAT)

  RETURN
 END FUNCTION R4MEAN2D

 FUNCTION I8MEAN2D(inMAT)
  IMPLICIT NONE
  INTEGER(8) :: I8MEAN2D,inMAT(:,:)
  INTEGER(4) :: MATDIMS(2)

  MATDIMS=SHAPE(inMAT)
  i8MEAN2D=SUM(inMAT)/(MATDIMS(1)*MATDIMS(2))
 !I8MEAN2D=SUM(inMAT)/SIZE(inMAT)

  RETURN
 END FUNCTION I8MEAN2D

 FUNCTION I4MEAN2D(inMAT)
  IMPLICIT NONE
  INTEGER(4) :: I4MEAN2D,inMAT(:,:)
  INTEGER(4) :: MATDIMS(2)

  MATDIMS=SHAPE(inMAT)
  i4MEAN2D=SUM(inMAT)/(MATDIMS(1)*MATDIMS(2))
 !I4MEAN2D=SUM(inMAT)/SIZE(inMAT)

  RETURN
 END FUNCTION I4MEAN2D

 FUNCTION R8MEAN3D(inMAT)
  IMPLICIT NONE
  REAL(8) :: R8MEAN3D,inMAT(:,:,:)

  R8MEAN3D=SUM(inMAT)/SIZE(inMAT)

  RETURN
 END FUNCTION R8MEAN3D

 FUNCTION R4MEAN3D(inMAT)
  IMPLICIT NONE
  REAL(4) :: R4MEAN3D,inMAT(:,:,:)

  R4MEAN3D=SUM(inMAT)/SIZE(inMAT)

  RETURN
 END FUNCTION R4MEAN3D

 FUNCTION I8MEAN3D(inMAT)
  IMPLICIT NONE
  INTEGER(8) :: I8MEAN3D,inMAT(:,:,:)

  I8MEAN3D=SUM(inMAT)/SIZE(inMAT)

  RETURN
 END FUNCTION I8MEAN3D

 FUNCTION I4MEAN3D(inMAT)
  IMPLICIT NONE
  INTEGER(4) :: I4MEAN3D,inMAT(:,:,:)

  I4MEAN3D=SUM(inMAT)/SIZE(inMAT)

  RETURN
 END FUNCTION I4MEAN3D

!**********************************************
!********* STANDARD-DEVIATION VALUE ***********
!**********************************************
 FUNCTION r8STDEV1D(inMAT)
  IMPLICIT NONE
  REAL(8)    :: r8STDEV1D,inMAT(:)
  REAL(8)    :: tmp,arrayMEAN
  INTEGER(4) :: iCONTR

  arrayMEAN=MEAN(inMAT)
  tmp=0.0d0
  DO iCONTR=1,SIZE(inMAT)
   tmp=tmp+(inMAT(iCONTR)-arrayMEAN)**2
  END DO
  r8STDEV1D=SQRT(tmp/SIZE(inMAT))
  RETURN
 END FUNCTION r8STDEV1D

 FUNCTION r4STDEV1D(inMAT)
  IMPLICIT NONE
  REAL(4)    :: r4STDEV1D,inMAT(:)
  REAL(4)    :: tmp,arrayMEAN
  INTEGER(4) :: iCONTR

  arrayMEAN=MEAN(inMAT)
  tmp=0.0
  DO iCONTR=1,SIZE(inMAT)
   tmp=tmp+(inMAT(iCONTR)-arrayMEAN)**2
  END DO
  r4STDEV1D=SQRT(tmp/SIZE(inMAT))
  RETURN
 END FUNCTION r4STDEV1D

 FUNCTION i8STDEV1D(inMAT)
  IMPLICIT NONE
  INTEGER(8) :: inMAT(:)
  INTEGER(4) :: iCONTR
  REAL(8)    :: i8STDEV1D
  REAL(8)    :: tmp,arrayMEAN

  arrayMEAN=MEAN(inMAT)
  tmp=0.0d0
  DO iCONTR=1,SIZE(inMAT)
   tmp=tmp+(inMAT(iCONTR)-arrayMEAN)**2
  END DO
  i8STDEV1D=SQRT(tmp/SIZE(inMAT))
  RETURN
 END FUNCTION i8STDEV1D

 FUNCTION i4STDEV1D(inMAT)
  IMPLICIT NONE
  INTEGER(4) :: inMAT(:)
  INTEGER(4) :: iCONTR
  REAL(4)    :: i4STDEV1D
  REAL(4)    :: tmp,arrayMEAN

  arrayMEAN=MEAN(inMAT)
  tmp=0.0
  DO iCONTR=1,SIZE(inMAT)
   tmp=tmp+(inMAT(iCONTR)-arrayMEAN)**2
  END DO
  i4STDEV1D=SQRT(tmp/SIZE(inMAT))
  RETURN
 END FUNCTION i4STDEV1D

 FUNCTION r8STDEV2D(inMAT)
  IMPLICIT NONE
  REAL(8)    :: r8STDEV2D,inMAT(:,:)
  REAL(8)    :: tmp,arrayMEAN
  INTEGER(4) :: iD1,iD2
  INTEGER(4) :: MATDIMS(2)

  MATDIMS=SHAPE(inMAT)
  arrayMEAN=MEAN(inMAT)
  tmp=0.0d0
  DO iD1=1,MATDIMS(1)
   DO iD2=1,MATDIMS(2)
    tmp=tmp+(inMAT(iD1,iD2)-arrayMEAN)**2
   END DO
  END DO
 !r8STDEV2D=SQRT(tmp/(MATDIMS(1)*MATDIMS(2)))
  r8STDEV2D=SQRT(tmp/((MATDIMS(1)-1)*(MATDIMS(2)-1)))
  RETURN
 END FUNCTION r8STDEV2D

 FUNCTION r4STDEV2D(inMAT)
  IMPLICIT NONE
  REAL(4)    :: r4STDEV2D,inMAT(:,:)
  REAL(4)    :: tmp,arrayMEAN
  INTEGER(4) :: iD1,iD2
  INTEGER(4) :: MATDIMS(2)

  MATDIMS=SHAPE(inMAT)
  arrayMEAN=MEAN(inMAT)
  tmp=0.0
  DO iD1=1,MATDIMS(1)
   DO iD2=1,MATDIMS(2)
    tmp=tmp+(inMAT(iD1,iD2)-arrayMEAN)**2
   END DO
  END DO
 !r4STDEV2D=SQRT(tmp/(MATDIMS(1)*MATDIMS(2)))
  r4STDEV2D=SQRT(tmp/((MATDIMS(1)-1)*(MATDIMS(2)-1)))
  RETURN
 END FUNCTION r4STDEV2D

 FUNCTION i8STDEV2D(inMAT)
  IMPLICIT NONE
  INTEGER(8) :: inMAT(:,:)
  INTEGER(4) :: iD1,iD2
  INTEGER(4) :: MATDIMS(2)
  REAL(8)    :: i8STDEV2D
  REAL(8)    :: tmp,arrayMEAN

  MATDIMS=SHAPE(inMAT)
  arrayMEAN=MEAN(inMAT)
  tmp=0.0d0
  DO iD1=1,MATDIMS(1)
   DO iD2=1,MATDIMS(2)
    tmp=tmp+(inMAT(iD1,iD2)-arrayMEAN)**2
   END DO
  END DO
  i8STDEV2D=SQRT(tmp/(MATDIMS(1)*MATDIMS(2)))
  RETURN
 END FUNCTION i8STDEV2D

 FUNCTION i4STDEV2D(inMAT)
  IMPLICIT NONE
  INTEGER(4) :: inMAT(:,:)
  INTEGER(4) :: iD1,iD2
  INTEGER(4) :: MATDIMS(2)
  REAL(4)    :: i4STDEV2D
  REAL(4)    :: tmp,arrayMEAN

  MATDIMS=SHAPE(inMAT)
  arrayMEAN=MEAN(inMAT)
  tmp=0.0
  DO iD1=1,MATDIMS(1)
   DO iD2=1,MATDIMS(2)
    tmp=tmp+(inMAT(iD1,iD2)-arrayMEAN)**2
   END DO
  END DO
  i4STDEV2D=SQRT(tmp/(MATDIMS(1)*MATDIMS(2)))
  RETURN
 END FUNCTION i4STDEV2D

!**********************************************
!*************** SKEWNESS VALUE ***************
!**********************************************
 FUNCTION r8SKEWNESS1D(inMAT)
  IMPLICIT NONE
  REAL(8)    :: r8SKEWNESS1D,inMAT(:)
  REAL(8)    :: moment2,moment3,arrayMEAN
  INTEGER(4) :: iCONTR

  arrayMEAN=MEAN(inMAT)
  moment2=0.0d0
  moment3=0.0d0
  DO iCONTR=1,SIZE(inMAT)
   moment2=moment2+(inMAT(iCONTR)-arrayMEAN)**2
   moment3=moment3+(inMAT(iCONTR)-arrayMEAN)**3
  END DO
  r8SKEWNESS1D=(moment3/SIZE(inMAT))/(moment2/SIZE(inMAT))**(3/2)
  RETURN
 END FUNCTION r8SKEWNESS1D

 FUNCTION r4SKEWNESS1D(inMAT)
  IMPLICIT NONE
  REAL(4)    :: r4SKEWNESS1D,inMAT(:)
  REAL(4)    :: moment2,moment3,arrayMEAN
  INTEGER(4) :: iCONTR

  arrayMEAN=MEAN(inMAT)
  moment2=0.0
  moment3=0.0
  DO iCONTR=1,SIZE(inMAT)
   moment2=moment2+(inMAT(iCONTR)-arrayMEAN)**2
   moment3=moment3+(inMAT(iCONTR)-arrayMEAN)**3
  END DO
  r4SKEWNESS1D=(moment3/SIZE(inMAT))/(moment2/SIZE(inMAT))**(3/2)
  RETURN
 END FUNCTION r4SKEWNESS1D

 FUNCTION i8SKEWNESS1D(inMAT)
  IMPLICIT NONE
  INTEGER(8) :: inMAT(:)
  INTEGER(4) :: iCONTR
  REAL(8)    :: i8SKEWNESS1D
  REAL(8)    :: moment2,moment3,arrayMEAN

  arrayMEAN=MEAN(inMAT)
  moment2=0.0d0
  moment3=0.0d0
  DO iCONTR=1,SIZE(inMAT)
   moment2=moment2+(inMAT(iCONTR)-arrayMEAN)**2
   moment3=moment3+(inMAT(iCONTR)-arrayMEAN)**3
  END DO
  i8SKEWNESS1D=(moment3/SIZE(inMAT))/(moment2/SIZE(inMAT))**(3/2)
  RETURN
 END FUNCTION i8SKEWNESS1D

 FUNCTION i4SKEWNESS1D(inMAT)
  IMPLICIT NONE
  INTEGER(4) :: inMAT(:)
  INTEGER(4) :: iCONTR
  REAL(4)    :: i4SKEWNESS1D
  REAL(4)    :: moment2,moment3,arrayMEAN

  arrayMEAN=MEAN(inMAT)
  moment2=0.0
  moment3=0.0
  DO iCONTR=1,SIZE(inMAT)
   moment2=moment2+(inMAT(iCONTR)-arrayMEAN)**2
   moment3=moment3+(inMAT(iCONTR)-arrayMEAN)**3
  END DO
  i4SKEWNESS1D=(moment3/SIZE(inMAT))/(moment2/SIZE(inMAT))**(3/2)
  RETURN
 END FUNCTION i4SKEWNESS1D

 FUNCTION r8SKEWNESS2D(inMAT)
  IMPLICIT NONE
  REAL(8)    :: r8SKEWNESS2D,inMAT(:,:)
  REAL(8)    :: moment2,moment3,arrayMEAN
  INTEGER(4) :: iD1,iD2
  INTEGER(4) :: MATDIMS(2)

  MATDIMS=SHAPE(inMAT)
  arrayMEAN=MEAN(inMAT)
  moment2=0.0d0
  moment3=0.0d0
  DO iD1=1,MATDIMS(1)
   DO iD2=1,MATDIMS(2)
    moment2=moment2+(inMAT(iD1,iD2)-arrayMEAN)**2
    moment3=moment3+(inMAT(iD1,iD2)-arrayMEAN)**3
   END DO
  END DO
  r8SKEWNESS2D=(moment3/(MATDIMS(1)*MATDIMS(2)))/(moment2/(MATDIMS(1)*MATDIMS(2)))**(3/2)
  RETURN
 END FUNCTION r8SKEWNESS2D

 FUNCTION r4SKEWNESS2D(inMAT)
  IMPLICIT NONE
  REAL(4)    :: r4SKEWNESS2D,inMAT(:,:)
  REAL(4)    :: moment2,moment3,arrayMEAN
  INTEGER(4) :: iD1,iD2
  INTEGER(4) :: MATDIMS(2)

  MATDIMS=SHAPE(inMAT)
  arrayMEAN=MEAN(inMAT)
  moment2=0.0d0
  moment3=0.0d0
  DO iD1=1,MATDIMS(1)
   DO iD2=1,MATDIMS(2)
    moment2=moment2+(inMAT(iD1,iD2)-arrayMEAN)**2
    moment3=moment3+(inMAT(iD1,iD2)-arrayMEAN)**3
   END DO
  END DO
  r4SKEWNESS2D=(moment3/(MATDIMS(1)*MATDIMS(2)))/(moment2/(MATDIMS(1)*MATDIMS(2)))**(3/2)
  RETURN
 END FUNCTION r4SKEWNESS2D

 FUNCTION i8SKEWNESS2D(inMAT)
  IMPLICIT NONE
  INTEGER(8) :: inMAT(:,:)
  INTEGER(4) :: iD1,iD2
  INTEGER(4) :: MATDIMS(2)
  REAL(8)    :: i8SKEWNESS2D
  REAL(8)    :: moment2,moment3,arrayMEAN

  MATDIMS=SHAPE(inMAT)
  arrayMEAN=MEAN(inMAT)
  moment2=0.0d0
  moment3=0.0d0
  DO iD1=1,MATDIMS(1)
   DO iD2=1,MATDIMS(2)
    moment2=moment2+(inMAT(iD1,iD2)-arrayMEAN)**2
    moment3=moment3+(inMAT(iD1,iD2)-arrayMEAN)**3
   END DO
  END DO
  i8SKEWNESS2D=(moment3/(MATDIMS(1)*MATDIMS(2)))/(moment2/(MATDIMS(1)*MATDIMS(2)))**(3/2)
  RETURN
 END FUNCTION i8SKEWNESS2D

 FUNCTION i4SKEWNESS2D(inMAT)
  IMPLICIT NONE
  INTEGER(4) :: inMAT(:,:)
  INTEGER(4) :: iD1,iD2
  INTEGER(4) :: MATDIMS(2)
  REAL(4)    :: i4SKEWNESS2D
  REAL(4)    :: moment2,moment3,arrayMEAN

  MATDIMS=SHAPE(inMAT)
  arrayMEAN=MEAN(inMAT)
  moment2=0.0d0
  moment3=0.0d0
  DO iD1=1,MATDIMS(1)
   DO iD2=1,MATDIMS(2)
    moment2=moment2+(inMAT(iD1,iD2)-arrayMEAN)**2
    moment3=moment3+(inMAT(iD1,iD2)-arrayMEAN)**3
   END DO
  END DO
  i4SKEWNESS2D=(moment3/(MATDIMS(1)*MATDIMS(2)))/(moment2/(MATDIMS(1)*MATDIMS(2)))**(3/2)
  RETURN
 END FUNCTION i4SKEWNESS2D

!**********************************************
!*************** KURTOSIS VALUE ***************
!**********************************************
 FUNCTION r8KURTOSIS1D(inMAT)
  IMPLICIT NONE
  REAL(8)    :: r8KURTOSIS1D,inMAT(:)
  REAL(8)    :: moment2,moment4,arrayMEAN
  INTEGER(4) :: iCONTR

  arrayMEAN=MEAN(inMAT)
  moment2=0.0d0
  moment4=0.0d0
  DO iCONTR=1,SIZE(inMAT)
   moment2=moment2+(inMAT(iCONTR)-arrayMEAN)**2
   moment4=moment4+(inMAT(iCONTR)-arrayMEAN)**4
  END DO
  r8KURTOSIS1D=(moment4/SIZE(inMAT))/(moment2/SIZE(inMAT))**2
  RETURN
 END FUNCTION r8KURTOSIS1D

 FUNCTION r4KURTOSIS1D(inMAT)
  IMPLICIT NONE
  REAL(4)    :: r4KURTOSIS1D,inMAT(:)
  REAL(4)    :: moment2,moment4,arrayMEAN
  INTEGER(4) :: iCONTR

  arrayMEAN=MEAN(inMAT)
  moment2=0.0
  moment4=0.0
  DO iCONTR=1,SIZE(inMAT)
   moment2=moment2+(inMAT(iCONTR)-arrayMEAN)**2
   moment4=moment4+(inMAT(iCONTR)-arrayMEAN)**4
  END DO
  r4KURTOSIS1D=(moment4/SIZE(inMAT))/(moment2/SIZE(inMAT))**2
  RETURN
 END FUNCTION r4KURTOSIS1D

 FUNCTION i8KURTOSIS1D(inMAT)
  IMPLICIT NONE
  INTEGER(8) :: inMAT(:)
  INTEGER(4) :: iCONTR
  REAL(8)    :: i8KURTOSIS1D
  REAL(8)    :: moment2,moment4,arrayMEAN

  arrayMEAN=MEAN(inMAT)
  moment2=0.0d0
  moment4=0.0d0
  DO iCONTR=1,SIZE(inMAT)
   moment2=moment2+(inMAT(iCONTR)-arrayMEAN)**2
   moment4=moment4+(inMAT(iCONTR)-arrayMEAN)**4
  END DO
  i8KURTOSIS1D=(moment4/SIZE(inMAT))/(moment2/SIZE(inMAT))**2
  RETURN
 END FUNCTION i8KURTOSIS1D

 FUNCTION i4KURTOSIS1D(inMAT)
  IMPLICIT NONE
  INTEGER(4) :: inMAT(:)
  INTEGER(4) :: iCONTR
  REAL(4)    :: i4KURTOSIS1D
  REAL(4)    :: moment2,moment4,arrayMEAN

  arrayMEAN=MEAN(inMAT)
  moment2=0.0
  moment4=0.0
  DO iCONTR=1,SIZE(inMAT)
   moment2=moment2+(inMAT(iCONTR)-arrayMEAN)**2
   moment4=moment4+(inMAT(iCONTR)-arrayMEAN)**4
  END DO
  i4KURTOSIS1D=(moment4/SIZE(inMAT))/(moment2/SIZE(inMAT))**2
  RETURN
 END FUNCTION i4KURTOSIS1D

 FUNCTION r8KURTOSIS2D(inMAT)
  IMPLICIT NONE
  REAL(8)    :: r8KURTOSIS2D,inMAT(:,:)
  REAL(8)    :: moment2,moment4,arrayMEAN
  INTEGER(4) :: iD1,iD2
  INTEGER(4) :: MATDIMS(2)

  MATDIMS=SHAPE(inMAT)
  arrayMEAN=MEAN(inMAT)
  moment2=0.0d0
  moment4=0.0d0
  DO iD1=1,MATDIMS(1)
   DO iD2=1,MATDIMS(2)
    moment2=moment2+(inMAT(iD1,iD2)-arrayMEAN)**2
    moment4=moment4+(inMAT(iD1,iD2)-arrayMEAN)**4
   END DO
  END DO
  r8KURTOSIS2D=(moment4/(MATDIMS(1)*MATDIMS(2)))/(moment2/(MATDIMS(1)*MATDIMS(2)))**2
  RETURN
 END FUNCTION r8KURTOSIS2D

 FUNCTION r4KURTOSIS2D(inMAT)
  IMPLICIT NONE
  REAL(4)    :: r4KURTOSIS2D,inMAT(:,:)
  REAL(4)    :: moment2,moment4,arrayMEAN
  INTEGER(4) :: iD1,iD2
  INTEGER(4) :: MATDIMS(2)

  MATDIMS=SHAPE(inMAT)
  arrayMEAN=MEAN(inMAT)
  moment2=0.0d0
  moment4=0.0d0
  DO iD1=1,MATDIMS(1)
   DO iD2=1,MATDIMS(2)
    moment2=moment2+(inMAT(iD1,iD2)-arrayMEAN)**2
    moment4=moment4+(inMAT(iD1,iD2)-arrayMEAN)**4
   END DO
  END DO
  r4KURTOSIS2D=(moment4/(MATDIMS(1)*MATDIMS(2)))/(moment2/(MATDIMS(1)*MATDIMS(2)))**2
  RETURN
 END FUNCTION r4KURTOSIS2D

 FUNCTION i8KURTOSIS2D(inMAT)
  IMPLICIT NONE
  INTEGER(8) :: inMAT(:,:)
  INTEGER(4) :: iD1,iD2
  INTEGER(4) :: MATDIMS(2)
  REAL(8)    :: i8KURTOSIS2D
  REAL(8)    :: moment2,moment4,arrayMEAN

  MATDIMS=SHAPE(inMAT)
  arrayMEAN=MEAN(inMAT)
  moment2=0.0d0
  moment4=0.0d0
  DO iD1=1,MATDIMS(1)
   DO iD2=1,MATDIMS(2)
    moment2=moment2+(inMAT(iD1,iD2)-arrayMEAN)**2
    moment4=moment4+(inMAT(iD1,iD2)-arrayMEAN)**4
   END DO
  END DO
  i8KURTOSIS2D=(moment4/(MATDIMS(1)*MATDIMS(2)))/(moment2/(MATDIMS(1)*MATDIMS(2)))**2
  RETURN
 END FUNCTION i8KURTOSIS2D

 FUNCTION i4KURTOSIS2D(inMAT)
  IMPLICIT NONE
  INTEGER(4) :: inMAT(:,:)
  INTEGER(4) :: iD1,iD2
  INTEGER(4) :: MATDIMS(2)
  REAL(4)    :: i4KURTOSIS2D
  REAL(4)    :: moment2,moment4,arrayMEAN

  MATDIMS=SHAPE(inMAT)
  arrayMEAN=MEAN(inMAT)
  moment2=0.0d0
  moment4=0.0d0
  DO iD1=1,MATDIMS(1)
   DO iD2=1,MATDIMS(2)
    moment2=moment2+(inMAT(iD1,iD2)-arrayMEAN)**2
    moment4=moment4+(inMAT(iD1,iD2)-arrayMEAN)**3
   END DO
  END DO
  i4KURTOSIS2D=(moment4/(MATDIMS(1)*MATDIMS(2)))/(moment2/(MATDIMS(1)*MATDIMS(2)))**2
  RETURN
 END FUNCTION i4KURTOSIS2D

!**********************************************
!*************** DEG2RAD **********************
!**********************************************
 FUNCTION R8DEG2RAD(ANGLE)
  IMPLICIT NONE
  REAL(8) :: R8DEG2RAD,ANGLE
  REAL(8), PARAMETER :: PI=4.0d0*ATAN(1.0d0)

  R8DEG2RAD=ANGLE*(PI/180.0d0)
 END FUNCTION R8DEG2RAD

 FUNCTION R4DEG2RAD(ANGLE)
  IMPLICIT NONE
  REAL(4) :: R4DEG2RAD,ANGLE
  REAL(4), PARAMETER :: PI=4.0d0*ATAN(1.0d0)

  R4DEG2RAD=ANGLE*(PI/180.0)
 END FUNCTION R4DEG2RAD

!**********************************************
!*************** RAD2DEG **********************
!**********************************************
 FUNCTION R8RAD2DEG(ANGLE)
  IMPLICIT NONE
  REAL(8) :: R8RAD2DEG,ANGLE
  REAL(8), PARAMETER :: PI=4.0d0*ATAN(1.0d0)

  R8RAD2DEG=ANGLE*(180.0d0/PI)
 END FUNCTION R8RAD2DEG

 FUNCTION R4RAD2DEG(ANGLE)
  IMPLICIT NONE
  REAL(4) :: R4RAD2DEG,ANGLE
  REAL(4), PARAMETER :: PI=4.0d0*ATAN(1.0d0)

  R4RAD2DEG=ANGLE*(180.0/PI)
 END FUNCTION R4RAD2DEG

!*************************************************
!**************** ASHIN **************************
!*************************************************
 FUNCTION R8ASINH(Z)
  IMPLICIT NONE
  REAL(8) :: Z,R8ASINH

  R8ASINH=LOG(Z+SQRT(1+Z**2))
 END FUNCTION R8ASINH

 FUNCTION R4ASINH(Z)
  IMPLICIT NONE
  REAL :: Z,R4ASINH

  R4ASINH=LOG(Z+SQRT(1+Z**2))
 END FUNCTION R4ASINH

!**********************************************************************
! SUBROUTINE TO CREATE KRONICAL MATRIX K FROM TWO MATRICIES A AND B
!**********************************************************************
 SUBROUTINE r4KRON(A,B,K)
    IMPLICIT NONE
    REAL(4), INTENT(IN)  :: A(:,:), B(:,:)
    REAL(4), INTENT(INOUT) :: K(:,:)
    INTEGER :: I, J, MA, NA, MB, NB
    MA = UBOUND(A, 1)
    NA = UBOUND(A, 2)
    MB = UBOUND(B, 1)
    NB = UBOUND(B, 2)
    IF (SIZE(K,1).NE.MA*MB.OR.SIZE(K,2).NE.NA*NB) THEN
        WRITE(*,*) 'K has invalid size'
        CALL ABORT
    END IF
    FORALL(I=1:MA, J=1:NA)
        K(MB*(I-1)+1:MB*I,NB*(J-1)+1:NB*J) = A(I,J)*B
    END FORALL
 END SUBROUTINE r4KRON

 SUBROUTINE r8KRON(A,B,K)
    IMPLICIT NONE
    REAL(8), INTENT(IN)  :: A(:,:), B(:,:)
    REAL(8), INTENT(INOUT) :: K(:,:)
    INTEGER :: I, J, MA, NA, MB, NB
    MA = UBOUND(A, 1)
    NA = UBOUND(A, 2)
    MB = UBOUND(B, 1)
    NB = UBOUND(B, 2)
    IF (SIZE(K,1).NE.MA*MB.OR.SIZE(K,2).NE.NA*NB) THEN
        WRITE(*,*) 'K has invalid size'
        CALL ABORT
    END IF
    FORALL(I=1:MA, J=1:NA)
        K(MB*(I-1)+1:MB*I,NB*(J-1)+1:NB*J) = A(I,J)*B
    END FORALL
 END SUBROUTINE r8KRON

!**********************************************************************
!             RETURN THE 90-CLOCKWISE-ROTATION OF A MATRIX A
!**********************************************************************
 FUNCTION R4ROTCW902D(A)
  IMPLICIT NONE
  REAL(4)::A(:,:)
  REAL(4),ALLOCATABLE::R4ROTCW902D(:,:)
  INTEGER::MATDIMS(2)
  INTEGER::I

  MATDIMS=SHAPE(A)
  ALLOCATE(R4ROTCW902D(MATDIMS(2),MATDIMS(1)))
  DO I=1,MATDIMS(1)
   R4ROTCW902D(:,MATDIMS(1)+1-I)=A(I,:)
  END DO

 END FUNCTION R4ROTCW902D

 FUNCTION R8ROTCW902D(A)
  IMPLICIT NONE
  REAL(8)::A(:,:)
  REAL(8),ALLOCATABLE::R8ROTCW902D(:,:)
  INTEGER::MATDIMS(2)
  INTEGER::I

  MATDIMS=SHAPE(A)
  ALLOCATE(R8ROTCW902D(MATDIMS(2),MATDIMS(1)))
  DO I=1,MATDIMS(1)
   R8ROTCW902D(:,MATDIMS(1)+1-I)=A(I,:)
  END DO

 END FUNCTION R8ROTCW902D

 FUNCTION C8ROTCW902D(A)
  IMPLICIT NONE
  COMPLEX(8)::A(:,:)
  COMPLEX(8),ALLOCATABLE::C8ROTCW902D(:,:)
  INTEGER::MATDIMS(2)
  INTEGER::I

  MATDIMS=SHAPE(A)
  ALLOCATE(C8ROTCW902D(MATDIMS(2),MATDIMS(1)))
  DO I=1,MATDIMS(1)
    C8ROTCW902D(:,MATDIMS(1)+1-I)=A(I,:)
  END DO

 END FUNCTION C8ROTCW902D

 FUNCTION C4ROTCW902D(A)
  IMPLICIT NONE
  COMPLEX(4)::A(:,:)
  COMPLEX(4),ALLOCATABLE::C4ROTCW902D(:,:)
  INTEGER::MATDIMS(2)
  INTEGER::I

  MATDIMS=SHAPE(A)
  ALLOCATE(C4ROTCW902D(MATDIMS(2),MATDIMS(1)))
  DO I=1,MATDIMS(1)
    C4ROTCW902D(:,MATDIMS(1)+1-I)=A(I,:)
  END DO

 END FUNCTION C4ROTCW902D

!**********************************************************************
!        RETURN THE 90-COUNTER-CLOCKWISE-ROTATION OF A MATRIX A
!**********************************************************************
 FUNCTION R8ROTCCW902D(A)
  IMPLICIT NONE
  REAL(8)::A(:,:)
  REAL(8),ALLOCATABLE::R8ROTCCW902D(:,:)
  INTEGER::MATDIMS(2)

  MATDIMS=SHAPE(A)
  ALLOCATE(R8ROTCCW902D(MATDIMS(1),MATDIMS(2)))
  R8ROTCCW902D=ROTCW90(ROT180(A))

 END FUNCTION R8ROTCCW902D

 FUNCTION C8ROTCCW902D(A)
  IMPLICIT NONE
  COMPLEX(8)::A(:,:)
  COMPLEX(8),ALLOCATABLE::C8ROTCCW902D(:,:)
  INTEGER::MATDIMS(2)

  MATDIMS=SHAPE(A)
  ALLOCATE(C8ROTCCW902D(MATDIMS(1),MATDIMS(2)))
  C8ROTCCW902D=ROTCW90(ROT180(A))

 END FUNCTION C8ROTCCW902D

!**********************************************************************
!             RETURN THE 180-ROTATION OF A MATRIX A
!**********************************************************************
 FUNCTION R4ROT1801D(A)
  IMPLICIT NONE
  REAL(4) :: A(:)
  REAL(4),ALLOCATABLE :: R4ROT1801D(:)
  INTEGER :: N,I

  N=SIZE(A)
  IF(ALLOCATED(R4ROT1801D)) DEALLOCATE(R4ROT1801D)
  ALLOCATE(R4ROT1801D(N))
  DO I=1,N
    R4ROT1801D(N-(I-1))=A(I)
  END DO

 END FUNCTION R4ROT1801D

 FUNCTION R8ROT1801D(A)
  IMPLICIT NONE
  REAL(8) :: A(:)
  REAL(8),ALLOCATABLE :: R8ROT1801D(:)
  INTEGER :: N,I

  N=SIZE(A)
  IF(ALLOCATED(R8ROT1801D)) DEALLOCATE(R8ROT1801D)
  ALLOCATE(R8ROT1801D(N))
  DO I=1,N
    R8ROT1801D(N-(I-1))=A(I)
  END DO

 END FUNCTION R8ROT1801D

 FUNCTION C8ROT1801D(A)
  IMPLICIT NONE
  COMPLEX(8) :: A(:)
  COMPLEX(8),ALLOCATABLE :: C8ROT1801D(:)
  INTEGER :: N,I

  N=SIZE(A)
  IF(ALLOCATED(C8ROT1801D)) DEALLOCATE(C8ROT1801D)
  ALLOCATE(C8ROT1801D(N))
  DO I=1,N
    C8ROT1801D(N-(I-1))=A(I)
  END DO

 END FUNCTION C8ROT1801D

 FUNCTION C4ROT1801D(A)
  IMPLICIT NONE
  COMPLEX(4) :: A(:)
  COMPLEX(4),ALLOCATABLE :: C4ROT1801D(:)
  INTEGER :: N,I

  N=SIZE(A)
  IF(ALLOCATED(C4ROT1801D)) DEALLOCATE(C4ROT1801D)
  ALLOCATE(C4ROT1801D(N))
  DO I=1,N
    C4ROT1801D(N-(I-1))=A(I)
  END DO

 END FUNCTION C4ROT1801D

 FUNCTION R8ROT1802D(A)
  IMPLICIT NONE
  REAL(8)::A(:,:)
  REAL(8),ALLOCATABLE::R8ROT1802D(:,:)
  INTEGER::MATDIMS(2)

  MATDIMS=SHAPE(A)
  ALLOCATE(R8ROT1802D(MATDIMS(1),MATDIMS(2)))
  R8ROT1802D=ROTCW90(ROTCW90(A))

 END FUNCTION R8ROT1802D

 FUNCTION R4ROT1802D(A)
  IMPLICIT NONE
  REAL(4)::A(:,:)
  REAL(4),ALLOCATABLE::R4ROT1802D(:,:)
  INTEGER::MATDIMS(2)

  MATDIMS=SHAPE(A)
  ALLOCATE(R4ROT1802D(MATDIMS(1),MATDIMS(2)))
  R4ROT1802D=ROTCW90(ROTCW90(A))

 END FUNCTION R4ROT1802D

 FUNCTION C8ROT1802D(A)
  IMPLICIT NONE
  COMPLEX(8)::A(:,:)
  COMPLEX(8),ALLOCATABLE::C8ROT1802D(:,:)
  INTEGER::MATDIMS(2)

  MATDIMS=SHAPE(A)
  ALLOCATE(C8ROT1802D(MATDIMS(1),MATDIMS(2)))
  C8ROT1802D=ROTCW90(ROTCW90(A))

 END FUNCTION C8ROT1802D

 FUNCTION C4ROT1802D(A)
  IMPLICIT NONE
  COMPLEX(4)::A(:,:)
  COMPLEX(4),ALLOCATABLE::C4ROT1802D(:,:)
  INTEGER::MATDIMS(2)

  MATDIMS=SHAPE(A)
  ALLOCATE(C4ROT1802D(MATDIMS(1),MATDIMS(2)))
  C4ROT1802D=ROTCW90(ROTCW90(A))

 END FUNCTION C4ROT1802D

!****************************************************************
!                 RETURN AN IDENTITY MATRIX
!****************************************************************
 SUBROUTINE I4IDMAT2D(IDMT)
  IMPLICIT NONE
  INTEGER(4) :: MATDIMS(2)
  INTEGER(4) :: IDMT(:,:)
  INTEGER(4) :: I,J

  MATDIMS=SHAPE(IDMT)
  IDMT=0.0d0
  DO I=1,MATDIMS(1)
    DO J=1,MATDIMS(2)
      IF(I.EQ.J) IDMT(I,J)=1.0d0
    END DO
  END DO

  RETURN
 END SUBROUTINE I4IDMAT2D

 SUBROUTINE R4IDMAT2D(IDMT)
  IMPLICIT NONE
  INTEGER(4) :: MATDIMS(2)
  REAL(4)    :: IDMT(:,:)
  INTEGER(4) :: I,J

  MATDIMS=SHAPE(IDMT)
  IDMT=0.0d0
  DO I=1,MATDIMS(1)
    DO J=1,MATDIMS(2)
      IF(I.EQ.J) IDMT(I,J)=1.0d0
    END DO
  END DO

  RETURN
 END SUBROUTINE R4IDMAT2D

 SUBROUTINE R8IDMAT2D(IDMT)
  IMPLICIT NONE
  INTEGER(4) :: MATDIMS(2)
  REAL(8)    :: IDMT(:,:)
  INTEGER(4) :: I,J

  MATDIMS=SHAPE(IDMT)
  IDMT=0.0d0
  DO I=1,MATDIMS(1)
    DO J=1,MATDIMS(2)
      IF(I.EQ.J) IDMT(I,J)=1.0d0
    END DO
  END DO

  RETURN
 END SUBROUTINE R8IDMAT2D

 SUBROUTINE C4IDMAT2D(IDMT)
  IMPLICIT NONE
  INTEGER(4) :: MATDIMS(2)
  COMPLEX(4) :: IDMT(:,:)
  INTEGER(4) :: I,J

  MATDIMS=SHAPE(IDMT)
  IDMT=CMPLX(0.0,0.0)
  DO I=1,MATDIMS(1)
    DO J=1,MATDIMS(2)
      IF(I.EQ.J) IDMT(I,J)=CMPLX(0.0,1.0)
    END DO
  END DO

  RETURN
 END SUBROUTINE C4IDMAT2D

 SUBROUTINE C8IDMAT2D(IDMT)
  IMPLICIT NONE
  INTEGER(4) :: MATDIMS(2)
  COMPLEX(8) :: IDMT(:,:)
  INTEGER(4) :: I,J

  MATDIMS=SHAPE(IDMT)
  IDMT=CMPLX(0.0d0,0.0d0)
  DO I=1,MATDIMS(1)
    DO J=1,MATDIMS(2)
      IF(I.EQ.J) IDMT(I,J)=CMPLX(0.0d0,1.0d0)
    END DO
  END DO

  RETURN
 END SUBROUTINE C8IDMAT2D

!****************************************************************
!        RETURN A ARRAY WITH ALL ITS ELEMETS ARE ZEROS
!****************************************************************
 FUNCTION ZEROS(M,N)
  IMPLICIT NONE
  INTEGER(4),INTENT(IN) :: M,N
  INTEGER(4):: ZEROS(M,N)

  ZEROS=0
  RETURN
 END FUNCTION ZEROS

!****************************************************************
!        RETURN A ARRAY WITH ALL ITS ELEMETS ARE ONES
!****************************************************************
 FUNCTION I4ONES1D(N)
  IMPLICIT NONE
  INTEGER(4),INTENT(IN) :: N
  INTEGER(4):: I4ONES1D(N)

  I4ONES1D=1
  RETURN
 END FUNCTION I4ONES1D

 FUNCTION I4ONES2D(M,N)
  IMPLICIT NONE
  INTEGER(4),INTENT(IN) :: M,N
  INTEGER(4):: I4ONES2D(M,N)

  I4ONES2D=1
  RETURN
 END FUNCTION I4ONES2D

 FUNCTION I4ONES3D(L,M,N)
  IMPLICIT NONE
  INTEGER(4),INTENT(IN) :: L,M,N
  INTEGER(4):: I4ONES3D(L,M,N)

  I4ONES3D=1
  RETURN
 END FUNCTION I4ONES3D

!****************************************************************
!                 RETURNS THE SECH OF A MATRIX
!****************************************************************
 FUNCTION R4SECH1D(X)
  IMPLICIT NONE
  REAL(4),ALLOCATABLE :: R4SECH1D(:)
  REAL(4) :: X(:)
  INTEGER(4) :: MATDIMS(1)

  MATDIMS=SIZE(X)
  IF(ALLOCATED(R4SECH1D)) DEALLOCATE(R4SECH1D)
  ALLOCATE(R4SECH1D(MATDIMS(1)))
  R4SECH1D=2.0d0/(EXP(X)+EXP(-X))
  RETURN
 END FUNCTION R4SECH1D

 FUNCTION R8SECH1D(X)
  IMPLICIT NONE
  REAL(8),ALLOCATABLE :: R8SECH1D(:)
  REAL(8) :: X(:)
  INTEGER(4) :: MATDIMS(1)

  MATDIMS=SIZE(X)
  IF(ALLOCATED(R8SECH1D)) DEALLOCATE(R8SECH1D)
  ALLOCATE(R8SECH1D(MATDIMS(1)))
  R8SECH1D=2.0d0/(EXP(X)+EXP(-X))
  RETURN
 END FUNCTION R8SECH1D

 FUNCTION R4SECH2D(X)
  IMPLICIT NONE
  REAL(4),ALLOCATABLE :: R4SECH2D(:,:)
  REAL(4) :: X(:,:)
  INTEGER(4) :: MATDIMS(2)

  MATDIMS=SHAPE(X)
  IF(ALLOCATED(R4SECH2D)) DEALLOCATE(R4SECH2D)
  ALLOCATE(R4SECH2D(MATDIMS(1),MATDIMS(2)))
  R4SECH2D=2.0d0/(EXP(X)+EXP(-X))
  RETURN
 END FUNCTION R4SECH2D

 FUNCTION R8SECH2D(X)
  IMPLICIT NONE
  REAL(8),ALLOCATABLE :: R8SECH2D(:,:)
  REAL(8) :: X(:,:)
  INTEGER(4) :: MATDIMS(2)

  MATDIMS=SHAPE(X)
  IF(ALLOCATED(R8SECH2D)) DEALLOCATE(R8SECH2D)
  ALLOCATE(R8SECH2D(MATDIMS(1),MATDIMS(2)))
  R8SECH2D=2.0d0/(EXP(X)+EXP(-X))
  RETURN
 END FUNCTION R8SECH2D

!****************************************************************
!               RETURNS THE INVERSE OF A MATRUX
!****************************************************************
 SUBROUTINE c4MATINV(MAT,SNGERR,RCND)
  IMPLICIT NONE
  REAL(4),   INTENT(OUT),OPTIONAL :: RCND
  INTEGER(4),INTENT(OUT),OPTIONAL :: SNGERR ! SINGULARITY ERROR
  COMPLEX(4),INTENT(INOUT)        :: MAT(:,:)

  REAL(4) :: RCOND
  COMPLEX(4) :: DET(2)
  INTEGER(4),ALLOCATABLE :: IPVT(:)
  COMPLEX(4),ALLOCATABLE :: WORK(:)
  INTEGER(4) :: MATDIMS(2)

  MATDIMS=SHAPE(MAT)
  ALLOCATE(IPVT(MATDIMS(2)),WORK(MATDIMS(2)))
  CALL CGECO(MAT,MATDIMS(1),MATDIMS(2),IPVT,RCOND,WORK)
  IF(RCOND.EQ.0.0) THEN
    MAT=CMPLX(0.0,0.0)
    IF(PRESENT(SNGERR)) SNGERR=1
    IF(PRESENT(RCND))   RCND=RCOND
    RETURN
  ELSE IF(RCOND.LT.1.0E-20) THEN
    MAT=CMPLX(0.0,0.0)
    IF(PRESENT(SNGERR)) SNGERR=1
    IF(PRESENT(RCND))   RCND=RCOND
    RETURN
  ELSE
    IF(PRESENT(SNGERR)) SNGERR=0
    IF(PRESENT(RCND))   RCND=RCOND
  END IF
  CALL CGEDI(MAT,MATDIMS(1),MATDIMS(2),IPVT,DET,WORK,1)
 END SUBROUTINE C4MATINV

 SUBROUTINE r8MATINV(MAT,SNGERR,RCND)
  IMPLICIT NONE
  REAL(8),   INTENT(INOUT)        :: MAT(:,:)
  REAL(8),   INTENT(OUT),OPTIONAL :: RCND
  INTEGER(4),INTENT(OUT),OPTIONAL :: SNGERR ! SINULARITY ERROR

  REAL(8) :: RCOND
  REAL(8) :: DET(2)
  INTEGER(4),ALLOCATABLE :: IPVT(:)
  REAL(8),ALLOCATABLE :: WORK(:)
  INTEGER(4) :: MATDIMS(2)

  MATDIMS=SHAPE(MAT)
  ALLOCATE(IPVT(MATDIMS(2)),WORK(MATDIMS(2)))
  CALL DGECO(MAT,MATDIMS(1),MATDIMS(2),IPVT,RCOND,WORK)

  IF(RCOND.EQ.0.0) THEN
    MAT=CMPLX(0.0,0.0)
    IF(PRESENT(SNGERR)) SNGERR=1
    IF(PRESENT(RCND))   RCND=RCOND
    RETURN
  ELSE IF(RCOND.LT.1.0E-20) THEN
    MAT=CMPLX(0.0,0.0)
    IF(PRESENT(SNGERR)) SNGERR=2
    IF(PRESENT(RCND))   RCND=RCOND
    RETURN
  ELSE
    IF(PRESENT(SNGERR)) SNGERR=0
    IF(PRESENT(RCND))   RCND=RCOND
  END IF
  CALL DGEDI(MAT,MATDIMS(1),MATDIMS(2),IPVT,DET,WORK,1)
 END SUBROUTINE R8MATINV

!****************************************************************
!              SOLVE A LINEAR SYSTEM OF EQUATION
!****************************************************************
 SUBROUTINE R8SLVLINSYS(NNMAT,INVEC,OUTVEC)
  IMPLICIT NONE

  REAL(8) :: RCOND,DET(2)
  REAL(8) :: NNMAT(:,:),INVEC(:),OUTVEC(:)
  INTEGER(4),ALLOCATABLE :: IPVT(:)
  REAL(8),ALLOCATABLE    :: WORK(:)
  INTEGER :: N,MATDIMS(2)

  MATDIMS=SHAPE(NNMAT)
  ALLOCATE(IPVT(MATDIMS(2)),WORK(MATDIMS(2)))
  CALL DGECO(NNMAT,MATDIMS(1),MATDIMS(2),IPVT,RCOND,WORK)
  IF(RCOND.LT.1.0E-12) THEN
    WRITE(*,*) RCOND
    WRITE(*,*) "YOUR MATRIX HAS A SINGULARITY"
    NNMAT=0.0d0
    RETURN
  END IF
  OUTVEC=INVEC
  N=MATDIMS(2)
  CALL DGESL(NNMAT,N,N,IPVT,OUTVEC,0)
  RETURN

 END SUBROUTINE R8SLVLINSYS

!****************************************************************
!            CHECK IF A VALUE IS POSITIVE OF NEGATIVE
!****************************************************************
 FUNCTION I4ISPOSTV(VARVALUE)  ! 1 IS POSITIVE & 0 IS NEGATIVE
  IMPLICIT NONE
  INTEGER(4) :: VARVALUE
  INTEGER(4) :: I4ISPOSTV

  IF(VARVALUE.LT.0) THEN
   I4ISPOSTV=0
  ELSE
   I4ISPOSTV=1
  END IF
 END FUNCTION I4ISPOSTV

 FUNCTION I8ISPOSTV(VARVALUE)  ! 1 IS POSITIVE & 0 IS NEGATIVE
  IMPLICIT NONE
  INTEGER(8) :: VARVALUE
  INTEGER(4) :: I8ISPOSTV

  IF(VARVALUE.LT.0) THEN
   I8ISPOSTV=0
  ELSE
   I8ISPOSTV=1
  END IF
 END FUNCTION I8ISPOSTV

 FUNCTION R4ISPOSTV(VARVALUE)  ! 1 IS POSITIVE & 0 IS NEGATIVE
  IMPLICIT NONE
  REAL(4) :: VARVALUE
  INTEGER(4) :: R4ISPOSTV

  IF(VARVALUE.LT.0.0) THEN
   R4ISPOSTV=0
  ELSE
   R4ISPOSTV=1
  END IF
 END FUNCTION R4ISPOSTV

 FUNCTION R8ISPOSTV(VARVALUE)  ! 1 IS POSITIVE & 0 IS NEGATIVE
  IMPLICIT NONE
  REAL(8) :: VARVALUE
  INTEGER(4) :: R8ISPOSTV

  IF(VARVALUE.LT.0.0d0) THEN
   R8ISPOSTV=0
  ELSE
   R8ISPOSTV=1
  END IF
 END FUNCTION R8ISPOSTV

!****************************************************************
!    FIND THE ORDER FOR A NUMBER HAS A FORMAT  [1X10^(ORDER)]
!****************************************************************
 FUNCTION ORDEROF(VARVALUE)
  IMPLICIT NONE
  REAL(4)    :: VARVALUE,CALCVAL
  INTEGER(4) :: ORDEROF

  CALCVAL=VARVALUE
  ORDEROF=0
  IF(ABS(VARVALUE).EQ.0.0) RETURN
  IF(ABS(VARVALUE).GT.1.0) THEN
   DO WHILE(ABS(CALCVAL).GT.10.0)
    CALCVAL=CALCVAL/10.0
    ORDEROF=ORDEROF+1
   END DO
!  ORDEROF=ORDEROF-1
  END IF
  IF(ABS(VARVALUE).LT.1.0) THEN
   DO WHILE(ABS(CALCVAL).LT.1.0)
    CALCVAL=CALCVAL*10.0
    ORDEROF=ORDEROF-1
   END DO
  END IF
 END FUNCTION ORDEROF

!***********************************************************
!      SUBROUTINE TO ADD RANDOM NOISE TO ARRAY DATA
!***********************************************************
 SUBROUTINE R4ADDNOISETO1D(X1D,noiseSCALE,NX1D)
  IMPLICIT NONE
  REAL(4) :: X1D(:),NX1D(:)
  REAL(4) :: noiseSCALE
  REAL(4), ALLOCATABLE :: noiseVAR(:)

  IF(ALLOCATED(noiseVAR)) DEALLOCATE(noiseVAR)
  ALLOCATE(noiseVAR(SIZE(X1D)))

  CALL RANDOM_SEED
  CALL RANDOM_NUMBER(noiseVAR)
  NX1D=X1D+X1D*noiseVAR*noiseSCALE

  RETURN
 END SUBROUTINE R4ADDNOISETO1D

 SUBROUTINE R8ADDNOISETO1D(X1D,noiseSCALE,NX1D)
  IMPLICIT NONE
  REAL(8) :: X1D(:),NX1D(:)
  REAL(4) :: noiseSCALE
  REAL(8), ALLOCATABLE :: noiseVAR(:)

  IF(ALLOCATED(noiseVAR)) DEALLOCATE(noiseVAR)
  ALLOCATE(noiseVAR(SIZE(X1D)))

  CALL RANDOM_SEED
  CALL RANDOM_NUMBER(noiseVAR)
  NX1D=X1D+X1D*noiseVAR*noiseSCALE

  RETURN
 END SUBROUTINE R8ADDNOISETO1D

 SUBROUTINE R4ADDNOISETO2D(X2D,noiseSCALE,NX2D)
  IMPLICIT NONE
  REAL(4) :: X2D(:,:),NX2D(:,:)
  REAL(4) :: noiseSCALE
  REAL(4), ALLOCATABLE :: noiseVAR(:,:)
  INTEGER(4) :: iD,MATDIMS(2)

  MATDIMS=SHAPE(X2D)
  IF(ALLOCATED(noiseVAR)) DEALLOCATE(noiseVAR)
  ALLOCATE(noiseVAR(MATDIMS(1),MATDIMS(2)))

  CALL RANDOM_SEED
  CALL RANDOM_NUMBER(noiseVAR)
  NX2D=X2D+X2D*noiseVAR*noiseSCALE

  RETURN
 END SUBROUTINE R4ADDNOISETO2D

 SUBROUTINE R8ADDNOISETO2D(X2D,noiseSCALE,NX2D)
  IMPLICIT NONE
  REAL(8) :: X2D(:,:),NX2D(:,:)
  REAL(4) :: noiseSCALE
  REAL(8), ALLOCATABLE :: noiseVAR(:,:)
  INTEGER(4) :: iD,MATDIMS(2)

  MATDIMS=SHAPE(X2D)
  IF(ALLOCATED(noiseVAR)) DEALLOCATE(noiseVAR)
  ALLOCATE(noiseVAR(MATDIMS(1),MATDIMS(2)))

  CALL RANDOM_SEED
  CALL RANDOM_NUMBER(noiseVAR)
  NX2D=X2D+X2D*noiseVAR*noiseSCALE

  RETURN
 END SUBROUTINE R8ADDNOISETO2D

 SUBROUTINE R4ADDNOISETO3D(X3D,noiseSCALE,NX3D)
  IMPLICIT NONE
  REAL(4) :: X3D(:,:,:),NX3D(:,:,:)
  REAL(4) :: noiseSCALE
  REAL(4), ALLOCATABLE :: noiseVAR(:,:,:)
  INTEGER(4) :: iD,MATDIMS(3)

  MATDIMS=SHAPE(X3D)
  IF(ALLOCATED(noiseVAR)) DEALLOCATE(noiseVAR)
  ALLOCATE(noiseVAR(MATDIMS(1),MATDIMS(2),MATDIMS(3)))

  CALL RANDOM_SEED
  CALL RANDOM_NUMBER(noiseVAR)
  NX3D=X3D+X3D*noiseVAR*noiseSCALE

  RETURN
 END SUBROUTINE R4ADDNOISETO3D

 SUBROUTINE R8ADDNOISETO3D(X3D,noiseSCALE,NX3D)
  IMPLICIT NONE
  REAL(8) :: X3D(:,:,:),NX3D(:,:,:)
  REAL(4) :: noiseSCALE
  REAL(8), ALLOCATABLE :: noiseVAR(:,:,:)
  INTEGER(4) :: iD,MATDIMS(3)

  MATDIMS=SHAPE(X3D)
  IF(ALLOCATED(noiseVAR)) DEALLOCATE(noiseVAR)
  ALLOCATE(noiseVAR(MATDIMS(1),MATDIMS(2),MATDIMS(3)))

  CALL RANDOM_SEED
  CALL RANDOM_NUMBER(noiseVAR)
  NX3D=X3D+X3D*noiseVAR*noiseSCALE

  RETURN
 END SUBROUTINE R8ADDNOISETO3D

!***********************************************************
!     SUBROUTINE TO MAP DATA MATRIX INTO A NEW RANGE
!***********************************************************
 SUBROUTINE r4DATAMAPPING1D(OLDDATA,NEWDATAMIN,NEWDATAMAX,NEWDATA)
  IMPLICIT NONE
  REAL(4), INTENT(IN)     :: OLDDATA(:)
  REAL(4), INTENT(OUT)    :: NEWDATA(:)
  REAL(4), INTENT(IN)     :: NEWDATAMAX,NEWDATAMIN
  REAL(4)                 :: OLDDATAMAX,OLDDATAMIN

  INTEGER(4)              :: MATDIMS1D(1)
  INTEGER(4)              :: iD1

  MATDIMS1D=SIZE(OLDDATA)

  OLDDATAMIN=MINVAL(OLDDATA)
  OLDDATAMAX=MAXVAL(OLDDATA)

  DO iD1=1,MATDIMS1D(1)
   NEWDATA(iD1)=NEWDATAMIN+(NEWDATAMAX-NEWDATAMIN)*((OLDDATA(iD1)-OLDDATAMIN)/(OLDDATAMAX-OLDDATAMIN))
  END DO

  RETURN
 END SUBROUTINE r4DATAMAPPING1D

 SUBROUTINE r8DATAMAPPING1D(OLDDATA,NEWDATAMIN,NEWDATAMAX,NEWDATA)
  IMPLICIT NONE
  REAL(8), INTENT(IN)     :: OLDDATA(:)
  REAL(8), INTENT(OUT)    :: NEWDATA(:)
  REAL(8), INTENT(IN)     :: NEWDATAMAX,NEWDATAMIN
  REAL(8)                 :: OLDDATAMAX,OLDDATAMIN

  INTEGER(4)              :: MATDIMS1D(1)
  INTEGER(4)              :: iD1

  MATDIMS1D=SIZE(OLDDATA)

  OLDDATAMIN=MINVAL(OLDDATA)
  OLDDATAMAX=MAXVAL(OLDDATA)

  DO iD1=1,MATDIMS1D(1)
   NEWDATA(iD1)=NEWDATAMIN+(NEWDATAMAX-NEWDATAMIN)*((OLDDATA(iD1)-OLDDATAMIN)/(OLDDATAMAX-OLDDATAMIN))
  END DO

  RETURN
 END SUBROUTINE r8DATAMAPPING1D

 SUBROUTINE r4DATAMAPPING2D(OLDDATA,NEWDATAMIN,NEWDATAMAX,NEWDATA)
  IMPLICIT NONE
  REAL(4), INTENT(IN)     :: OLDDATA(:,:)
  REAL(4), INTENT(OUT)    :: NEWDATA(:,:)
  REAL(4), INTENT(IN)     :: NEWDATAMAX,NEWDATAMIN
  REAL(4)                 :: OLDDATAMAX,OLDDATAMIN

  INTEGER(4)              :: MATDIMS2D(2)
  INTEGER(4)              :: iD1,iD2

  MATDIMS2D=SHAPE(OLDDATA)

  OLDDATAMIN=MINVAL(OLDDATA)
  OLDDATAMAX=MAXVAL(OLDDATA)

  DO iD1=1,MATDIMS2D(1)
   DO iD2=1,MATDIMS2D(2)
    NEWDATA(iD1,iD2)=NEWDATAMIN+(NEWDATAMAX-NEWDATAMIN)*((OLDDATA(iD1,iD2)-OLDDATAMIN)/(OLDDATAMAX-OLDDATAMIN))
   END DO
  END DO

  RETURN
 END SUBROUTINE r4DATAMAPPING2D

 SUBROUTINE r8DATAMAPPING2D(OLDDATA,NEWDATAMIN,NEWDATAMAX,NEWDATA)
  IMPLICIT NONE
  REAL(8), INTENT(IN)     :: OLDDATA(:,:)
  REAL(8), INTENT(OUT)    :: NEWDATA(:,:)
  REAL(8), INTENT(IN)     :: NEWDATAMAX,NEWDATAMIN
  REAL(8)                 :: OLDDATAMAX,OLDDATAMIN

  INTEGER(4)              :: MATDIMS2D(2)
  INTEGER(4)              :: iD1,iD2

  MATDIMS2D=SHAPE(OLDDATA)

  OLDDATAMIN=MINVAL(OLDDATA)
  OLDDATAMAX=MAXVAL(OLDDATA)

  DO iD1=1,MATDIMS2D(1)
   DO iD2=1,MATDIMS2D(2)
    NEWDATA(iD1,iD2)=NEWDATAMIN+(NEWDATAMAX-NEWDATAMIN)*((OLDDATA(iD1,iD2)-OLDDATAMIN)/(OLDDATAMAX-OLDDATAMIN))
   END DO
  END DO

  RETURN
 END SUBROUTINE r8DATAMAPPING2D

 SUBROUTINE r4DATAMAPPING3D(OLDDATA,NEWDATAMIN,NEWDATAMAX,NEWDATA)
  IMPLICIT NONE
  REAL(4), INTENT(IN)     :: OLDDATA(:,:,:)
  REAL(4), INTENT(OUT)    :: NEWDATA(:,:,:)
  REAL(4), INTENT(IN)     :: NEWDATAMAX,NEWDATAMIN
  REAL(4)                 :: OLDDATAMAX,OLDDATAMIN

  INTEGER(4)              :: MATDIMS3D(3)
  INTEGER(4)              :: iD1,iD2,iD3

  MATDIMS3D=SHAPE(OLDDATA)

  OLDDATAMIN=MINVAL(OLDDATA)
  OLDDATAMAX=MAXVAL(OLDDATA)

  DO iD1=1,MATDIMS3D(1)
   DO iD2=1,MATDIMS3D(2)
    DO iD3=1,MATDIMS3D(3)
     NEWDATA(iD1,iD2,iD3)=NEWDATAMIN+(NEWDATAMAX-NEWDATAMIN)*((OLDDATA(iD1,iD2,iD3)-OLDDATAMIN)/(OLDDATAMAX-OLDDATAMIN))
    END DO
   END DO
  END DO

  RETURN
 END SUBROUTINE r4DATAMAPPING3D

 SUBROUTINE r8DATAMAPPING3D(OLDDATA,NEWDATAMIN,NEWDATAMAX,NEWDATA)
  IMPLICIT NONE
  REAL(8), INTENT(IN)     :: OLDDATA(:,:,:)
  REAL(8), INTENT(OUT)    :: NEWDATA(:,:,:)
  REAL(8), INTENT(IN)     :: NEWDATAMAX,NEWDATAMIN
  REAL(8)                 :: OLDDATAMAX,OLDDATAMIN

  INTEGER(4)              :: MATDIMS3D(3)
  INTEGER(4)              :: iD1,iD2,iD3

  MATDIMS3D=SHAPE(OLDDATA)

  OLDDATAMIN=MINVAL(OLDDATA)
  OLDDATAMAX=MAXVAL(OLDDATA)

  DO iD1=1,MATDIMS3D(1)
   DO iD2=1,MATDIMS3D(2)
    DO iD3=1,MATDIMS3D(3)
     NEWDATA(iD1,iD2,iD3)=NEWDATAMIN+(NEWDATAMAX-NEWDATAMIN)*((OLDDATA(iD1,iD2,iD3)-OLDDATAMIN)/(OLDDATAMAX-OLDDATAMIN))
    END DO
   END DO
  END DO

  RETURN
 END SUBROUTINE r8DATAMAPPING3D

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! COLLECTION OF SOME IMPORTED SUBROUTINES FROM OTHER SOURCES AND LIBRARIES
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

 subroutine cg ( nm, n, ar, ai, wr, wi, matz, zr, zi, ierr )
!
!*******************************************************************************
!
!! CG gets eigenvalues and eigenvectors of a complex general matrix.
!
!
!  Discussion:
!
!    This subroutine calls the recommended sequence of EISPACK subroutines
!    to find the eigenvalues and eigenvectors (if desired)
!    of a complex general matrix.
!
!  Modified:
!
!    20 March 2002
!
!  Reference:
!
!    J H Wilkinson and C Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer Verlag, 1971.
!
!    B Smith, J Boyle, J Dongarra, B Garbow, Y Ikebe, V Klema, C Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976.
!
!  Parameters:
!
!    Input, integer NM, the leading dimension of the arrays, which must
!    be at least N.
!
!    Input, integer N, the order of the matrix.
!
!    Input/output, real AR(NM,N), AI(NM,N).  On input, the real and
!    imaginary parts of the complex matrix.  On output, AR and AI
!    have been overwritten by other information.
!
!    Output, real WR(N), WI(N), the real and imaginary parts
!    of the eigenvalues.
!
!    Input, integer MATZ, is 0 if only eigenvalues are desired, and
!    nonzero if both eigenvalues and eigenvectors are to be computed.
!
!    Output, real ZR(NM,N), ZI(NM,N), the real and imaginary parts,
!    respectively, of the eigenvectors, if MATZ is not zero.
!
!    Output, integer IERR, an error completion code described in the
!    documentation for COMQR and COMQR2.  The normal completion code is zero.
!
  implicit none
!
  integer n
  integer nm
!
  real ai(nm,n)
  real ar(nm,n)
  real fv1(n)
  real fv2(n)
  real fv3(n)
  integer ierr
  integer is1
  integer is2
  integer matz
  real wi(n)
  real wr(n)
  real zi(nm,n)
  real zr(nm,n)
!
  if ( n > nm ) then
    ierr = 10 * n
    return
  end if

  call cbal ( nm, n, ar, ai, is1, is2, fv1 )

  call corth ( nm, n, is1, is2, ar, ai, fv2, fv3 )

  if ( matz == 0 ) then

    call comqr ( nm, n, is1, is2, ar, ai, wr, wi, ierr )

    if ( ierr /= 0 ) then
      return
    end if

  else

    call comqr2 ( nm, n, is1, is2, fv2, fv3, ar, ai, wr, wi, zr, zi, ierr )

    if ( ierr /= 0 ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CG - Fatal error!'
      write ( *, '(a)' ) '  Nonzero error return from COMQR2.'
      return
    end if

    call cbabk2 ( nm, n, is1, is2, fv1, n, zr, zi )

  end if

  return
 end subroutine cg

 subroutine corth ( nm, n, low, igh, ar, ai, ortr, orti )
!
!*******************************************************************************
!
!! CORTH transforms a complex general matrix to upper Hessenberg form.
!
!
!  Discussion:
!
!    Given a complex general matrix, this subroutine
!    reduces a submatrix situated in rows and columns
!    LOW through IGH to upper Hessenberg form by
!    unitary similarity transformations.
!
!  Modified:
!
!    20 March 2002
!
!  Reference:
!
!    J H Wilkinson and C Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer Verlag, 1971.
!
!    B Smith, J Boyle, J Dongarra, B Garbow, Y Ikebe, V Klema, C Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976.
!
!  Parameters:
!
!    Input, integer NM, the leading dimension of the two-dimensional arrays.
!
!    Input, integer N, the order of the matrix.
!
!    Input, integer LOW, IGH, are determined by the balancing routine CBAL.
!    If CBAL is not used, set LOW = 1 and IGH = N.
!
!    Input/output, real AR(NM,N), AI(NM,N).  On input, the real and imaginary
!    parts of the complex input matrix.  On output, the real and imaginary
!    parts of the Hessenberg matrix.  Information about the unitary
!    transformations used in the reduction is stored in the remaining
!    triangles under the Hessenberg matrix.
!
!    Output, real ORTR(IGH), ORTI(IGH), further information about the
!    transformations.
!
  implicit none
!
  integer igh
  integer n
  integer nm
!
  real ai(nm,n)
  real ar(nm,n)
  real f
  real fi
  real fr
  real g
  real h
  integer i
  integer ii
  integer j
  integer jj
  integer la
  integer m,mp,low
  real orti(igh)
  real ortr(igh)
! real pythag
  real scale
!
  la = igh - 1

  if ( igh - 1 < low + 1 ) then
    return
  end if

  do m = low + 1, la

    h = 0.0E+00
    ortr(m) = 0.0E+00
    orti(m) = 0.0E+00
    scale = 0.0E+00
!
!  Scale column.
!
    do i = m, igh
      scale = scale + abs ( ar(i,m-1) ) + abs ( ai(i,m-1) )
    end do

    if ( scale == 0.0E+00 ) then
      cycle
    end if

    mp = m + igh

    do ii = m, igh
      i = mp - ii
      ortr(i) = ar(i,m-1) / scale
      orti(i) = ai(i,m-1) / scale
      h = h + ortr(i) * ortr(i) + orti(i) * orti(i)
    end do

    g = sqrt ( h )
    f = pythag ( ortr(m), orti(m) )

    if ( f /= 0.0E+00 ) then
      h = h + f * g
      g = g / f
      ortr(m) = ( 1.0E+00 + g ) * ortr(m)
      orti(m) = ( 1.0E+00 + g ) * orti(m)
    else
      ortr(m) = g
      ar(m,m-1) = scale
    end if
!
!  Form (I-(U*Ut)/h) * A.
!
    do j = m, n

      fr = 0.0E+00
      fi = 0.0E+00

      do ii = m, igh
        i = mp - ii
        fr = fr + ortr(i) * ar(i,j) + orti(i) * ai(i,j)
        fi = fi + ortr(i) * ai(i,j) - orti(i) * ar(i,j)
      end do

      fr = fr / h
      fi = fi / h

      ar(m:igh,j) = ar(m:igh,j) - fr * ortr(m:igh) + fi * orti(m:igh)
      ai(m:igh,j) = ai(m:igh,j) - fr * orti(m:igh) - fi * ortr(m:igh)

    end do
!
!  Form (I-(U*Ut)/h) * A * (I-(U*Ut)/h)
!
    do i = 1, igh

      fr = 0.0E+00
      fi = 0.0E+00

      do jj = m, igh
        j = mp - jj
        fr = fr + ortr(j) * ar(i,j) - orti(j) * ai(i,j)
        fi = fi + ortr(j) * ai(i,j) + orti(j) * ar(i,j)
      end do

      fr = fr / h
      fi = fi / h

      ar(i,m:igh) = ar(i,m:igh) - fr * ortr(m:igh) - fi * orti(m:igh)
      ai(i,m:igh) = ai(i,m:igh) + fr * orti(m:igh) - fi * ortr(m:igh)

    end do

    ortr(m) = scale * ortr(m)
    orti(m) = scale * orti(m)
    ar(m,m-1) = - g * ar(m,m-1)
    ai(m,m-1) = - g * ai(m,m-1)

  end do

  return
 end subroutine corth

 subroutine cbal ( nm, n, ar, ai, low, igh, scale )
!
!*******************************************************************************
!
!! CBAL balances a complex matrix before eigenvalue calculations.
!
!
!  Discussion:
!
!    This subroutine balances a complex matrix and isolates
!    eigenvalues whenever possible.
!
!    Suppose that the principal submatrix in rows low through igh
!    has been balanced, that P(J) denotes the index interchanged
!    with J during the permutation step, and that the elements
!    of the diagonal matrix used are denoted by D(I,J).  Then
!      SCALE(J) = P(J),    for J = 1,...,LOW-1
!               = D(J,J)       J = LOW,...,IGH
!               = P(J)         J = IGH+1,...,N.
!    The order in which the interchanges are made is N to IGH+1,
!    then 1 to LOW-1.
!
!    Note that 1 is returned for IGH if IGH is zero formally.
!
!  Modified:
!
!    20 March 2002
!
!  Reference:
!
!    J H Wilkinson and C Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer Verlag, 1971.
!
!    B Smith, J Boyle, J Dongarra, B Garbow, Y Ikebe, V Klema, C Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976.
!
!  Parameters:
!
!    Input, integer NM, the leading dimension of AR and AI, which must
!    be at least N.
!
!    Input, integer N, the order of the matrix.
!
!    Input/output, real AR(NM,N), AI(NM,N).  On input, the real and
!    imaginary parts of the complex matrix to be balanced.  On output,
!    the real and imaginary parts of the balanced matrix.
!
!    Output, integer LOW, IGH, are values such that AR(I,J) and AI(I,J)
!    are zero if I is greater than J and either J=1,...,LOW-1 or
!    I=IGH+1,...,N.
!
!    Output, real SCALE(N), information determining the
!    permutations and scaling factors used.
!
  implicit none
!
  integer n
  integer nm
!
  real ai(nm,n)
  real ar(nm,n)
  real b2
  real c
  real f
  real g
  integer i
  integer iexc
  integer igh
  integer j
  integer jj
  integer k
  integer l
  integer low
  integer m
  logical noconv
  real r
  real radix
  real s
  real scale(n)
!
  radix = 16.0E+00

  iexc = 0
  j = 0
  m = 0

  b2 = radix * radix
  k = 1
  l = n
  go to 100

20 continue

  scale(m) = j

  if ( j /= m ) then

    do i = 1, l
      call r_swap ( ar(i,j), ar(i,m) )
      call r_swap ( ai(i,j), ai(i,m) )
    end do

    do i = k, n
      call r_swap ( ar(j,i), ar(m,i) )
      call r_swap ( ai(j,i), ai(m,i) )
    end do

  end if

  if ( iexc == 2 ) then
    go to 130
  end if
!
!  Search for rows isolating an eigenvalue and push them down.
!
80 continue

  if ( l == 1 ) go to 280
  l = l - 1

100 continue

  do jj = 1, l

     j = l + 1 - jj

     do i = 1, l
       if ( i /= j ) then
         if ( ar(j,i) /= 0.0E+00 .or. ai(j,i) /= 0.0E+00 ) go to 120
       end if
     end do

     m = l
     iexc = 1
     go to 20

120  continue

  end do

  go to 140
!
!  Search for columns isolating an eigenvalue and push them left.
!
130 continue

  k = k + 1

140 continue

   do j = k, l

     do i = k, l
       if ( i /= j ) then
         if ( ar(i,j) /= 0.0E+00 .or. ai(i,j) /= 0.0E+00 ) go to 170
       end if
     end do

     m = k
     iexc = 2
     go to 20
170  continue

  end do
!
!  Now balance the submatrix in rows k to l.
!
  scale(k:l) = 1.0E+00
!
!  Iterative loop for norm reduction.
!
190 continue

  noconv = .false.

  do i = k, l

    c = 0.0E+00
    r = 0.0E+00

    do j = k, l
      if ( j /= i ) then
        c = c + abs ( ar(j,i) ) + abs ( ai(j,i) )
        r = r + abs ( ar(i,j) ) + abs ( ai(i,j) )
      end if
    end do
!
!  Guard against zero C or R due to underflow.
!
     if ( c == 0.0E+00 .or. r == 0.0E+00 ) go to 270

     g = r / radix
     f = 1.0E+00
     s = c + r

     do while ( c < g )
       f = f * radix
       c = c * b2
     end do

     g = r * radix

     do while  ( c >= g )
       f = f / radix
       c = c / b2
     end do
!
!  Now balance.
!
     if ( ( c + r ) / f < 0.95E+00 * s ) then

       g = 1.0E+00 / f
       scale(i) = scale(i) * f
       noconv = .true.

       ar(i,k:n) = ar(i,k:n) * g
       ai(i,k:n) = ai(i,k:n) * g

       ar(1:l,i) = ar(1:l,i) * f
       ai(1:l,i) = ai(1:l,i) * f

     end if

270  continue

  end do

  if ( noconv ) go to 190

  280 continue

  low = k
  igh = l

  return
 end subroutine cbal

 subroutine comqr ( nm, n, low, igh, hr, hi, wr, wi, ierr )
!
!*******************************************************************************
!
!! COMQR gets eigenvalues of a complex upper Hessenberg matrix.
!
!
!  Discussion:
!
!    This subroutine finds the eigenvalues of a complex
!    upper Hessenberg matrix by the QR method.
!
!  Modified:
!
!    20 March 2002
!
!  Reference:
!
!    J H Wilkinson and C Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer Verlag, 1971.
!
!    B Smith, J Boyle, J Dongarra, B Garbow, Y Ikebe, V Klema, C Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976.
!
!  Parameters:
!
!    Input, integer NM, the leading dimension of the two-dimensional arrays.
!
!    Input, integer N, the order of the matrix.
!
!    Input, integer LOW, IGH, are determined by the balancing routine CBAL.
!    If CBAL is not used, set LOW = 1 and IGH = N.
!
!    Input/output, real HR(NM,N), HI(NM,N).  On input, the real and imaginary
!    parts of the complex upper Hessenberg matrix.  Their lower triangles
!    below the subdiagonal contain information about the unitary
!    transformations used in the reduction by CORTH, if performed.  On output,
!    the upper Hessenberg portions of HR and HI have been destroyed.
!    Therefore, they must be saved before calling COMQR if subsequent
!    calculation of eigenvectors is to be performed.
!
!    Output, real WR(N), WI(N), the real and imaginary parts of the
!    eigenvalues.  If an error exit is made, the eigenvalues should be
!    correct for indices IERR+1,...,N.
!
!    Output, integer IERR, error flag.
!    0, for normal return,
!    J, if the limit of 30*N iterations is exhausted while the J-th
!       eigenvalue is being sought.
!
  implicit none
!
  integer n
  integer nm
!
  integer en
  integer enm1
  real hi(nm,n)
  real hr(nm,n)
  integer i
  integer ierr
  integer igh
  integer itn
  integer its
  integer j
  integer l
  integer ll
  integer low
  real norm
! real pythag
  real si
  real sr
  real ti
  real tr
  real tst1
  real tst2
  real wi(n)
  real wr(n)
  real xi
  real xr
  real yi
  real yr
  real zzi
  real zzr
!
  ierr = 0
!
!  Create real subdiagonal elements.
!
  l = low + 1

  do i = l, igh

     ll = min ( i+1, igh )

     if ( hi(i,i-1) /= 0.0E+00 ) then

     norm = pythag ( hr(i,i-1), hi(i,i-1) )
     yr = hr(i,i-1) / norm
     yi = hi(i,i-1) / norm
     hr(i,i-1) = norm
     hi(i,i-1) = 0.0E+00

     do j = i, igh
       si = yr * hi(i,j) - yi * hr(i,j)
       hr(i,j) = yr * hr(i,j) + yi * hi(i,j)
       hi(i,j) = si
     end do

     do j = low, ll
       si = yr * hi(j,i) + yi * hr(j,i)
       hr(j,i) = yr * hr(j,i) - yi * hi(j,i)
       hi(j,i) = si
     end do

    end if

  end do
!
!  Store roots isolated by CBAL.
!
  do i = 1, n
    if ( i < low .or. i > igh ) then
      wr(i) = hr(i,i)
      wi(i) = hi(i,i)
    end if
  end do

  en = igh
  tr = 0.0E+00
  ti = 0.0E+00
  itn = 30 * n
!
!  Search for next eigenvalue.
!
  220 continue

  if ( en < low ) then
    return
  end if

  its = 0
  enm1 = en - 1
!
!  Look for single small sub-diagonal element.
!
  240 continue

  do ll = low, en
    l = en + low - ll
    if ( l == low ) then
      exit
    end if
    tst1 = abs ( hr(l-1,l-1) ) + abs ( hi(l-1,l-1) ) + abs ( hr(l,l) ) &
      + abs ( hi(l,l) )
    tst2 = tst1 + abs ( hr(l,l-1) )
    if ( tst2 == tst1 ) then
      exit
    end if
  end do
!
!  Form shift.
!
  if ( l == en ) go to 660

  if ( itn == 0 ) go to 1000

  if ( its == 10 .or. its == 20 ) go to 320
  sr = hr(en,en)
  si = hi(en,en)
  xr = hr(enm1,en) * hr(en,enm1)
  xi = hi(enm1,en) * hr(en,enm1)
  if ( xr == 0.0E+00 .and. xi == 0.0E+00 ) go to 340
  yr = (hr(enm1,enm1) - sr) / 2.0E+00
  yi = (hi(enm1,enm1) - si) / 2.0E+00

  call csroot ( yr**2-yi**2+xr, 2.0E+00*yr*yi+xi, zzr, zzi )

  if ( yr * zzr + yi * zzi < 0.0E+00 ) then
    zzr = -zzr
    zzi = -zzi
  end if

  call cdiv ( xr, xi, yr+zzr, yi+zzi, xr, xi )
  sr = sr - xr
  si = si - xi
  go to 340
!
!  Form exceptional shift.
!
320 continue

  sr = abs ( hr(en,enm1) ) + abs ( hr(enm1,en-2) )
  si = 0.0E+00

340 continue

  do i = low, en
    hr(i,i) = hr(i,i) - sr
    hi(i,i) = hi(i,i) - si
  end do

  tr = tr + sr
  ti = ti + si
  its = its + 1
  itn = itn - 1
!
!  Reduce to triangle (rows).
!
  do i = l+1, en

     sr = hr(i,i-1)
     hr(i,i-1) = 0.0E+00
     norm = pythag ( pythag ( hr(i-1,i-1), hi(i-1,i-1) ), sr )
     xr = hr(i-1,i-1) / norm
     wr(i-1) = xr
     xi = hi(i-1,i-1) / norm
     wi(i-1) = xi
     hr(i-1,i-1) = norm
     hi(i-1,i-1) = 0.0E+00
     hi(i,i-1) = sr / norm

     do j = i, en
        yr = hr(i-1,j)
        yi = hi(i-1,j)
        zzr = hr(i,j)
        zzi = hi(i,j)
        hr(i-1,j) = xr * yr + xi * yi + hi(i,i-1) * zzr
        hi(i-1,j) = xr * yi - xi * yr + hi(i,i-1) * zzi
        hr(i,j) = xr * zzr - xi * zzi - hi(i,i-1) * yr
        hi(i,j) = xr * zzi + xi * zzr - hi(i,i-1) * yi
    end do

  end do

  si = hi(en,en)

  if ( si /= 0.0E+00 ) then
    norm = pythag ( hr(en,en), si )
    sr = hr(en,en) / norm
    si = si / norm
    hr(en,en) = norm
    hi(en,en) = 0.0E+00
  end if
!
!  Inverse operation (columns).
!
  do j = l+1, en

     xr = wr(j-1)
     xi = wi(j-1)

     do i = l, j

        yr = hr(i,j-1)
        yi = 0.0E+00
        zzr = hr(i,j)
        zzi = hi(i,j)
        if ( i /= j ) then
          yi = hi(i,j-1)
          hi(i,j-1) = xr * yi + xi * yr + hi(j,j-1) * zzi
        end if
        hr(i,j-1) = xr * yr - xi * yi + hi(j,j-1) * zzr
        hr(i,j) = xr * zzr + xi * zzi - hi(j,j-1) * yr
        hi(i,j) = xr * zzi - xi * zzr - hi(j,j-1) * yi

     end do

  end do

  if ( si /= 0.0E+00 ) then

    do i = l, en
      yr = hr(i,en)
      yi = hi(i,en)
      hr(i,en) = sr * yr - si * yi
      hi(i,en) = sr * yi + si * yr
    end do

  end if

  go to 240
!
!  A root found.
!
660 continue

  wr(en) = hr(en,en) + tr
  wi(en) = hi(en,en) + ti
  en = enm1
  go to 220
!
!  Set error: all eigenvalues have not converged after 30*n iterations.
!
1000 continue

  ierr = en
  return
 end subroutine comqr

 subroutine comqr2 ( nm, n, low, igh, ortr, orti, hr, hi, wr, wi, zr, zi, ierr )
!
!*******************************************************************************
!
!! COMQR2 gets eigenvalues/vectors of a complex upper Hessenberg matrix.
!
!
!  Discussion:
!
!    This subroutine finds the eigenvalues and eigenvectors
!    of a complex upper Hessenberg matrix by the QR
!    method.  The eigenvectors of a complex general matrix
!    can also be found if CORTH has been used to reduce
!    this general matrix to Hessenberg form.
!
!  Modified:
!
!    20 March 2002
!
!  Reference:
!
!    J H Wilkinson and C Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer Verlag, 1971.
!
!    B Smith, J Boyle, J Dongarra, B Garbow, Y Ikebe, V Klema, C Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976.
!
!  Parameters:
!
!    Input, integer NM, the leading dimension of the two-dimensional arrays.
!
!    Input, integer N, the order of the matrix.
!
!    Input, integer LOW, IGH, are determined by the balancing routine CBAL.
!    If CBAL is not used, set LOW = 1 and IGH = N.
!
!    Input/output, real ORTR(N), ORTI(N).  On input, information about the
!    unitary transformations used in the reduction by CORTH, if performed.
!    If the eigenvectors of the Hessenberg matrix are desired, set ORTR(J) and
!    ORTI(J) to 0.0E+00 for these elements.  On output, these arrays
!    have been overwritten.
!
!    Input/output, real HR(NM,N), HI(NM,N).  On input, the real and imaginary
!    parts of the complex upper Hessenberg matrix.  Their lower triangles
!    below the subdiagonal contain further information about the
!    transformations which were used in the reduction by CORTH, if performed.
!    If the eigenvectors of the Hessenberg matrix are desired, these elements
!    may be arbitrary.
!
!    Output, real WR(N), WI(N), the real and imaginary parts of the
!    eigenvalues.  If an error exit is made, the eigenvalues should be
!    correct for indices IERR+1,...,N.
!
!    Output, real ZR(NM,N), ZI(NM,N), the real and imaginary parts of the
!    eigenvectors.  The eigenvectors are unnormalized.  If an error exit
!    is made, none of the eigenvectors has been found.
!
!    Output, integer IERR, error flag.
!    0, for normal return,
!    J, if the limit of 30*N iterations is exhausted while the J-th
!      eigenvalue is being sought.
!
  implicit none
!
  integer igh
  integer n
  integer nm
!
  integer en
  integer enm1
  real hi(nm,n)
  real hr(nm,n)
  integer i
  integer iend
  integer ierr
  integer ii
  integer itn
  integer its
  integer j
  integer jj
  integer k
  integer l
  integer ll
  integer low
  integer m
  integer nn
  real norm
  real orti(igh)
  real ortr(igh)
! real pythag
  real si
  real sr
  real ti
  real tr
  real tst1
  real tst2
  real wi(n)
  real wr(n)
  real xi
  real xr
  real yi
  real yr
  real zi(nm,n)
  real zr(nm,n)
  real zzi
  real zzr
!
  ierr = 0
!
!  Initialize eigenvector matrix.
!
  call rmat_ident ( nm, n, zr )

  zi(1:n,1:n) = 0.0E+00
!
!  Form the matrix of accumulated transformations from the information
!  left by CORTH.
!
  iend = igh - low - 1
  if ( iend ) 180, 150, 105

105 continue

  do ii = 1, iend

     i = igh - ii
     if ( ortr(i) == 0.0E+00 .and. orti(i) == 0.0E+00 ) go to 140
     if ( hr(i,i-1) == 0.0E+00 .and. hi(i,i-1) == 0.0E+00 ) go to 140
!
!  Norm below is negative of H formed in CORTH.
!
     norm = hr(i,i-1) * ortr(i) + hi(i,i-1) * orti(i)

     do k = i+1, igh
       ortr(k) = hr(k,i-1)
       orti(k) = hi(k,i-1)
     end do

     do j = i, igh

        sr = 0.0E+00
        si = 0.0E+00

        do k = i, igh
          sr = sr + ortr(k) * zr(k,j) + orti(k) * zi(k,j)
          si = si + ortr(k) * zi(k,j) - orti(k) * zr(k,j)
        end do

        sr = sr / norm
        si = si / norm

        do k = i, igh
          zr(k,j) = zr(k,j) + sr * ortr(k) - si * orti(k)
          zi(k,j) = zi(k,j) + sr * orti(k) + si * ortr(k)
        end do

      end do

140 continue

  end do
!
!  Create real subdiagonal elements.
!
150 continue

  l = low + 1

  do i = l, igh

     ll = min ( i+1, igh )

     if ( hi(i,i-1) == 0.0E+00 ) go to 170

     norm = pythag ( hr(i,i-1), hi(i,i-1) )
     yr = hr(i,i-1) / norm
     yi = hi(i,i-1) / norm
     hr(i,i-1) = norm
     hi(i,i-1) = 0.0E+00

     do j = i, n
       si = yr * hi(i,j) - yi * hr(i,j)
       hr(i,j) = yr * hr(i,j) + yi * hi(i,j)
       hi(i,j) = si
     end do

     do j = 1, ll
       si = yr * hi(j,i) + yi * hr(j,i)
       hr(j,i) = yr * hr(j,i) - yi * hi(j,i)
       hi(j,i) = si
     end do

     do j = low, igh
       si = yr * zi(j,i) + yi * zr(j,i)
       zr(j,i) = yr * zr(j,i) - yi * zi(j,i)
       zi(j,i) = si
     end do

170 continue

  end do
!
!  Store roots isolated by CBAL.
!
180 continue

  do i = 1, n
    if ( i < low .or. i > igh) then
      wr(i) = hr(i,i)
      wi(i) = hi(i,i)
    end if
  end do

  en = igh
  tr = 0.0E+00
  ti = 0.0E+00
  itn = 30 * n
!
!  Search for next eigenvalue.
!
220 continue

  if ( en < low ) go to 680
  its = 0
  enm1 = en - 1
!
!  Look for single small sub-diagonal element.
!
240 continue

  do ll = low, en
    l = en + low - ll
    if ( l == low ) then
      exit
    end if
    tst1 = abs ( hr(l-1,l-1) ) + abs ( hi(l-1,l-1) ) + abs ( hr(l,l) ) &
      + abs ( hi(l,l) )
    tst2 = tst1 + abs ( hr(l,l-1) )
    if ( tst2 == tst1 ) then
      exit
    end if
  end do
!
!  Form shift.
!
  if ( l == en ) go to 660
  if ( itn == 0 ) go to 1000
  if ( its == 10 .or. its == 20 ) go to 320
  sr = hr(en,en)
  si = hi(en,en)
  xr = hr(enm1,en) * hr(en,enm1)
  xi = hi(enm1,en) * hr(en,enm1)
  if ( xr == 0.0E+00 .and. xi == 0.0E+00 ) go to 340
  yr = ( hr(enm1,enm1) - sr ) / 2.0E+00
  yi = ( hi(enm1,enm1) - si ) / 2.0E+00

  call csroot ( yr**2-yi**2+xr, 2.0E+00*yr*yi+xi, zzr, zzi )

  if ( yr * zzr + yi * zzi < 0.0E+00 ) then
    zzr = -zzr
    zzi = -zzi
  end if

  call cdiv ( xr, xi, yr+zzr, yi+zzi, xr, xi )
  sr = sr - xr
  si = si - xi
  go to 340
!
!  Form exceptional shift.
!
320 continue

  sr = abs ( hr(en,enm1) ) + abs ( hr(enm1,en-2) )
  si = 0.0E+00

340 continue

  do i = low, en
    hr(i,i) = hr(i,i) - sr
    hi(i,i) = hi(i,i) - si
  end do

  tr = tr + sr
  ti = ti + si
  its = its + 1
  itn = itn - 1
!
!  Reduce to triangle (rows).
!
  do i = l+1, en

     sr = hr(i,i-1)
     hr(i,i-1) = 0.0E+00
     norm = pythag ( pythag ( hr(i-1,i-1), hi(i-1,i-1) ), sr )
     xr = hr(i-1,i-1) / norm
     wr(i-1) = xr
     xi = hi(i-1,i-1) / norm
     wi(i-1) = xi
     hr(i-1,i-1) = norm
     hi(i-1,i-1) = 0.0E+00
     hi(i,i-1) = sr / norm

     do j = i, n
        yr = hr(i-1,j)
        yi = hi(i-1,j)
        zzr = hr(i,j)
        zzi = hi(i,j)
        hr(i-1,j) = xr * yr + xi * yi + hi(i,i-1) * zzr
        hi(i-1,j) = xr * yi - xi * yr + hi(i,i-1) * zzi
        hr(i,j) = xr * zzr - xi * zzi - hi(i,i-1) * yr
        hi(i,j) = xr * zzi + xi * zzr - hi(i,i-1) * yi
     end do

  end do

  si = hi(en,en)

  if ( si /= 0.0E+00 ) then

    norm = pythag ( hr(en,en), si )
    sr = hr(en,en) / norm
    si = si / norm
    hr(en,en) = norm
    hi(en,en) = 0.0E+00

    do j = en+1, n
      yr = hr(en,j)
      yi = hi(en,j)
      hr(en,j) = sr * yr + si * yi
      hi(en,j) = sr * yi - si * yr
    end do

  end if
!
!  Inverse operation (columns).
!
  do j = l+1, en

     xr = wr(j-1)
     xi = wi(j-1)

     do i = 1, j

       yr = hr(i,j-1)
       yi = 0.0E+00
       zzr = hr(i,j)
       zzi = hi(i,j)

       if ( i /= j ) then
         yi = hi(i,j-1)
         hi(i,j-1) = xr * yi + xi * yr + hi(j,j-1) * zzi
       end if

       hr(i,j-1) = xr * yr - xi * yi + hi(j,j-1) * zzr
       hr(i,j) = xr * zzr + xi * zzi - hi(j,j-1) * yr
       hi(i,j) = xr * zzi - xi * zzr - hi(j,j-1) * yi

     end do

     do i = low, igh
       yr = zr(i,j-1)
       yi = zi(i,j-1)
       zzr = zr(i,j)
       zzi = zi(i,j)
       zr(i,j-1) = xr * yr - xi * yi + hi(j,j-1) * zzr
       zi(i,j-1) = xr * yi + xi * yr + hi(j,j-1) * zzi
       zr(i,j) = xr * zzr + xi * zzi - hi(j,j-1) * yr
       zi(i,j) = xr * zzi - xi * zzr - hi(j,j-1) * yi
     end do

  end do

  if ( si /= 0.0E+00 ) then

    do i = 1, en
      yr = hr(i,en)
      yi = hi(i,en)
      hr(i,en) = sr * yr - si * yi
      hi(i,en) = sr * yi + si * yr
    end do

    do i = low, igh
      yr = zr(i,en)
      yi = zi(i,en)
      zr(i,en) = sr * yr - si * yi
      zi(i,en) = sr * yi + si * yr
    end do

  end if

  go to 240
!
!  A root found.
!
660 continue

  hr(en,en) = hr(en,en) + tr
  wr(en) = hr(en,en)
  hi(en,en) = hi(en,en) + ti
  wi(en) = hi(en,en)
  en = enm1
  go to 220
!
!  All roots found.
!  Backsubstitute to find vectors of upper triangular form.
!
680 continue

  norm = 0.0E+00

  do i = 1, n
    do j = i, n
      tr = abs ( hr(i,j) ) + abs ( hi(i,j) )
      norm = max ( norm, tr )
    end do
  end do

  if ( n == 1 ) then
    return
  end if

  if ( norm == 0.0E+00 ) then
    return
  end if

  do nn = 2, n

     en = n + 2 - nn
     xr = wr(en)
     xi = wi(en)
     hr(en,en) = 1.0E+00
     hi(en,en) = 0.0E+00
     enm1 = en - 1

     do ii = 1, enm1

        i = en - ii
        zzr = 0.0E+00
        zzi = 0.0E+00

        do j = i+1, en
          zzr = zzr + hr(i,j) * hr(j,en) - hi(i,j) * hi(j,en)
          zzi = zzi + hr(i,j) * hi(j,en) + hi(i,j) * hr(j,en)
        end do

        yr = xr - wr(i)
        yi = xi - wi(i)

        if ( yr == 0.0E+00 .and. yi == 0.0E+00 ) then

           tst1 = norm
           yr = tst1
           do
             yr = 0.01E+00 * yr
             tst2 = norm + yr
             if ( tst2 <= tst1 ) then
               exit
             end if
           end do

        end if

        call cdiv ( zzr, zzi, yr, yi, hr(i,en), hi(i,en) )
!
!  Overflow control.
!
        tr = abs ( hr(i,en) ) + abs ( hi(i,en) )

        if ( tr /= 0.0E+00 ) then

          tst1 = tr
          tst2 = tst1 + 1.0E+00 / tst1

          if ( tst2 <= tst1 ) then

            do j = i, en
              hr(j,en) = hr(j,en)/tr
              hi(j,en) = hi(j,en)/tr
            end do

          end if

       end if

     end do

  end do
!
!  End backsubstitution.
!
  enm1 = n - 1
!
!  Vectors of isolated roots.
!
  do i = 1, n - 1

    if ( i < low .or. i > igh ) then

      do j = i+1, n
        zr(i,j) = hr(i,j)
        zi(i,j) = hi(i,j)
      end do

    end if

  end do
!
!  Multiply by transformation matrix to give vectors of original full matrix.
!
  do jj = low, n - 1

     j = n + low - jj
     m = min ( j, igh )

     do i = low, igh

        zzr = 0.0E+00
        zzi = 0.0E+00
        do k = low, m
          zzr = zzr + zr(i,k) * hr(k,j) - zi(i,k) * hi(k,j)
          zzi = zzi + zr(i,k) * hi(k,j) + zi(i,k) * hr(k,j)
        end do

        zr(i,j) = zzr
        zi(i,j) = zzi

      end do

  end do

  return
!
!  Set error: all eigenvalues have not converged after 30*n iterations.
!
1000 continue

  ierr = en
  return
 end subroutine comqr2

 subroutine cbabk2 ( nm, n, low, igh, scale, m, zr, zi )
!
!*******************************************************************************
!
!! CBABK2 finds eigenvectors by undoing the CBAL transformation.
!
!
!  Discussion:
!
!    This subroutine forms the eigenvectors of a complex general
!    matrix by back transforming those of the corresponding
!    balanced matrix determined by CBAL.
!
!  Modified:
!
!    20 March 2002
!
!  Reference:
!
!    J H Wilkinson and C Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer Verlag, 1971.
!
!    B Smith, J Boyle, J Dongarra, B Garbow, Y Ikebe, V Klema, C Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976.
!
!  Parameters:
!
!    Input, integer NM, the leading dimension of ZI and ZR, which must
!    be at least N.
!
!    Input, integer N, the order of the matrix.
!
!    Input, integer LOW, IGH, values determined by CBAL.
!
!    Input, real SCALE(N), information determining the permutations
!    and scaling factors used by CBAL.
!
!    Input, integer M, the number of eigenvectors to be back transformed.
!
!    Input/output, real ZR(NM,M), ZI(NM,M).  On input, the real and imaginary
!    parts, respectively, of the eigenvectors to be back transformed in
!    their first M columns.  On output, the transformed eigenvectors.
!
  implicit none
!
  integer m
  integer n
  integer nm
!
  integer i
  integer igh
  integer ii
  integer j
  integer k
  integer low
  real s
  real scale(n)
  real zi(nm,m)
  real zr(nm,m)
!
  if ( m == 0 ) then
    return
  end if

  if ( igh /= low ) then

    do i = low, igh

      s = scale(i)

      zr(i,1:m) = zr(i,1:m) * s
      zi(i,1:m) = zi(i,1:m) * s

    end do

  end if

  do ii = 1, n

    i = ii

    if ( i < low .or. i > igh ) then

      if ( i < low ) then
        i = low - ii
      end if

      k = scale(i)

      if ( k /= i ) then

        do j = 1, m
          call r_swap ( zr(i,j), zr(k,j) )
          call r_swap ( zi(i,j), zi(k,j) )
        end do

      end if

    end if

  end do

  return
 end subroutine cbabk2

 subroutine r_swap ( x, y )
!
!*******************************************************************************
!
!! R_SWAP switches two real values.
!
!
!  Modified:
!
!    30 November 1998
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, real X, Y.  On output, the values of X and
!    Y have been interchanged.
!
  implicit none
!
  real x
  real y
  real z
!
  z = x
  x = y
  y = z

  return
end subroutine r_swap

 subroutine cdiv ( ar, ai, br, bi, cr, ci )
!
!*******************************************************************************
!
!! CDIV emulates complex division, using real arithmetic.
!
!
!  Discussion:
!
!    This routine performs complex division:
!
!      (CR,CI) = (AR,AI) / (BR,BI)
!
!  Modified:
!
!    20 March 2002
!
!  Reference:
!
!    J H Wilkinson and C Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer Verlag, 1971.
!
!    B Smith, J Boyle, J Dongarra, B Garbow, Y Ikebe, V Klema, C Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976.
!
!  Parameters:
!
!    Input, real AR, AI, the real and imaginary parts of the numerator.
!
!    Input, real BR, BI, the real and imaginary parts of the denominator.
!
!    Output, real CR, CI, the real and imaginary parts of the result.
!
  implicit none
!
  real ai
  real ais
  real ar
  real ars
  real bi
  real bis
  real br
  real brs
  real ci
  real cr
  real s
!
  s = abs ( br ) + abs ( bi )

  ars = ar / s
  ais = ai / s
  brs = br / s
  bis = bi / s

  s = brs**2 + bis**2
  cr = ( ars * brs + ais * bis ) / s
  ci = ( ais * brs - ars * bis ) / s

  return
 end subroutine cdiv

 subroutine csroot ( xr, xi, yr, yi )
!
!*******************************************************************************
!
!! CSROOT computes the complex square root of a complex quantity.
!
!
!  Discussion:
!
!    The branch of the square function is chosen so that
!      YR >= 0.0E+00
!    and
!      sign ( YI ) == sign ( XI )
!
!  Modified:
!
!    20 March 2002
!
!  Reference:
!
!    J H Wilkinson and C Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer Verlag, 1971.
!
!    B Smith, J Boyle, J Dongarra, B Garbow, Y Ikebe, V Klema, C Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976.
!
!  Parameters:
!
!    Input, real XR, XI, the real and imaginary parts of the quantity
!    whose square root is desired.
!
!    Output, real YR, YI, the real and imaginary parts of the square root.
!
  implicit none
!
! real pythag
  real s
  real ti
  real tr
  real xi
  real xr
  real yi
  real yr
!
  tr = xr
  ti = xi
  s = sqrt ( 0.5E+00 * ( pythag ( tr, ti ) + abs ( tr ) ) )

  if ( tr >= 0.0E+00 ) yr = s
  if ( ti < 0.0E+00 ) s = -s
  if ( tr <= 0.0E+00 ) yi = s

  if ( tr < 0.0E+00 ) then
    yr = 0.5E+00 * ( ti / yi )
  else if ( tr > 0.0E+00 ) then
    yi = 0.5E+00 * ( ti / yr )
  end if

  return
 end subroutine csroot

 subroutine rmat_ident ( lda, n, a )
!
!*******************************************************************************
!
!! RMAT_IDENT sets the square matrix A to the identity.
!
!
!  Modified:
!
!    24 March 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer LDA, the leading dimension of A.
!
!    Input, integer N, the order of A.
!
!    Output, real A(LDA,N), the matrix which has been
!    set to the identity.
!
  implicit none
!
  integer lda
  integer n
!
  real a(lda,n)
  integer i
  integer j
!
  do i = 1, n
    do j = 1, n
      if ( i == j ) then
        a(i,j) = 1.0E+00
      else
        a(i,j) = 0.0E+00
      end if
    end do
  end do

  return
 end subroutine rmat_ident

subroutine DGECO (A, LDA, N, IPVT, RCOND, Z)
!
!! DGECO factors a matrix using Gaussian elimination and estimate ...
!            the condition number of the matrix.
!
!***LIBRARY   SLATEC (LINPACK)
!***CATEGORY  D2A1
!***TYPE      DOUBLE PRECISION (SGECO-S, DGECO-D, CGECO-C)
!***KEYWORDS  CONDITION NUMBER, GENERAL MATRIX, LINEAR ALGEBRA, LINPACK,
!             MATRIX FACTORIZATION
!***AUTHOR  Moler, C. B., (U. of New Mexico)
!***DESCRIPTION
!
!     DGECO factors a double precision matrix by Gaussian elimination
!     and estimates the condition of the matrix.
!
!     If  RCOND  is not needed, DGEFA is slightly faster.
!     To solve  A*X = B , follow DGECO by DGESL.
!     To compute  INVERSE(A)*C , follow DGECO by DGESL.
!     To compute  DETERMINANT(A) , follow DGECO by DGEDI.
!     To compute  INVERSE(A) , follow DGECO by DGEDI.
!
!     On Entry
!
!        A       DOUBLE PRECISION(LDA, N)
!                the matrix to be factored.
!
!        LDA     INTEGER
!                the leading dimension of the array  A .
!
!        N       INTEGER
!                the order of the matrix  A .
!
!     On Return
!
!        A       an upper triangular matrix and the multipliers
!                which were used to obtain it.
!                The factorization can be written  A = L*U  where
!                L  is a product of permutation and unit lower
!                triangular matrices and  U  is upper triangular.
!
!        IPVT    INTEGER(N)
!                an INTEGER vector of pivot indices.
!
!        RCOND   DOUBLE PRECISION
!                an estimate of the reciprocal condition of  A .
!                For the system  A*X = B , relative perturbations
!                in  A  and  B  of size  EPSILON  may cause
!                relative perturbations in  X  of size  EPSILON/RCOND .
!                If  RCOND  is so small that the logical expression
!                           1.0 + RCOND  ==  1.0
!                is true, then  A  may be singular to working
!                precision.  In particular,  RCOND  is zero  if
!                exact singularity is detected or the estimate
!                underflows.
!
!        Z       DOUBLE PRECISION(N)
!                a work vector whose contents are usually unimportant.
!                If  A  is close to a singular matrix, then  Z  is
!                an approximate null vector in the sense that
!                NORM(A*Z) = RCOND*NORM(A)*NORM(Z) .
!
!***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
!                 Stewart, LINPACK Users' Guide, SIAM, 1979.
!***ROUTINES CALLED  DASUM, DAXPY, DDOT, DGEFA, DSCAL
!***REVISION HISTORY  (YYMMDD)
!   780814  DATE WRITTEN
!   890531  Changed all specific intrinsics to generic.  (WRB)
!   890831  Modified array declarations.  (WRB)
!   890831  REVISION DATE from Version 3.2
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!   900326  Removed duplicate information from DESCRIPTION section.
!           (WRB)
!   920501  Reformatted the REFERENCES section.  (WRB)
!***END PROLOGUE  DGECO
  INTEGER LDA,N,IPVT(*)
  DOUBLE PRECISION A(LDA,*),Z(*)
  DOUBLE PRECISION RCOND
!
! DOUBLE PRECISION DDOT,EK,T,WK,WKM
! DOUBLE PRECISION ANORM,S,DASUM,SM,YNORM
  DOUBLE PRECISION EK,T,WK,WKM
  DOUBLE PRECISION ANORM,S,SM,YNORM
  INTEGER INFO,J,K,KB,KP1,L
!
!     COMPUTE 1-NORM OF A
!
!***FIRST EXECUTABLE STATEMENT  DGECO
  ANORM = 0.0D0
  DO 10 J = 1, N
     ANORM = MAX(ANORM,DASUM(N,A(1,J),1))
   10 CONTINUE
!
!     FACTOR
!
  call DGEFA(A,LDA,N,IPVT,INFO)
!
!     RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) .
!     ESTIMATE = NORM(Z)/NORM(Y) WHERE  A*Z = Y  AND  TRANS(A)*Y = E .
!     TRANS(A)  IS THE TRANSPOSE OF A .  THE COMPONENTS OF  E  ARE
!     CHOSEN TO CAUSE MAXIMUM LOCAL GROWTH IN THE ELEMENTS OF W  WHERE
!     TRANS(U)*W = E .  THE VECTORS ARE FREQUENTLY RESCALED TO AVOID
!     OVERFLOW.
!
!     SOLVE TRANS(U)*W = E
!
  EK = 1.0D0
  DO 20 J = 1, N
     Z(J) = 0.0D0
   20 CONTINUE
  DO 100 K = 1, N
     if (Z(K)  /=  0.0D0) EK = SIGN(EK,-Z(K))
     if (ABS(EK-Z(K))  <=  ABS(A(K,K))) go to 30
        S = ABS(A(K,K))/ABS(EK-Z(K))
        call DSCAL(N,S,Z,1)
        EK = S*EK
   30    CONTINUE
     WK = EK - Z(K)
     WKM = -EK - Z(K)
     S = ABS(WK)
     SM = ABS(WKM)
     if (A(K,K)  ==  0.0D0) go to 40
        WK = WK/A(K,K)
        WKM = WKM/A(K,K)
     go to 50
   40    CONTINUE
        WK = 1.0D0
        WKM = 1.0D0
   50    CONTINUE
     KP1 = K + 1
     if (KP1  >  N) go to 90
        DO 60 J = KP1, N
           SM = SM + ABS(Z(J)+WKM*A(K,J))
           Z(J) = Z(J) + WK*A(K,J)
           S = S + ABS(Z(J))
   60       CONTINUE
        if (S  >=  SM) go to 80
           T = WKM - WK
           WK = WKM
           DO 70 J = KP1, N
              Z(J) = Z(J) + T*A(K,J)
   70          CONTINUE
   80       CONTINUE
   90    CONTINUE
     Z(K) = WK
  100 CONTINUE
  S = 1.0D0/DASUM(N,Z,1)
  call DSCAL(N,S,Z,1)
!
!     SOLVE TRANS(L)*Y = W
!
  DO 120 KB = 1, N
     K = N + 1 - KB
     if (K  <  N) Z(K) = Z(K) + DDOT(N-K,A(K+1,K),1,Z(K+1),1)
     if (ABS(Z(K))  <=  1.0D0) go to 110
        S = 1.0D0/ABS(Z(K))
        call DSCAL(N,S,Z,1)
  110    CONTINUE
     L = IPVT(K)
     T = Z(L)
     Z(L) = Z(K)
     Z(K) = T
  120 CONTINUE
  S = 1.0D0/DASUM(N,Z,1)
  call DSCAL(N,S,Z,1)
!
  YNORM = 1.0D0
!
!     SOLVE L*V = Y
!
  DO 140 K = 1, N
     L = IPVT(K)
     T = Z(L)
     Z(L) = Z(K)
     Z(K) = T
     if (K  <  N) call DAXPY(N-K,T,A(K+1,K),1,Z(K+1),1)
     if (ABS(Z(K))  <=  1.0D0) go to 130
        S = 1.0D0/ABS(Z(K))
        call DSCAL(N,S,Z,1)
        YNORM = S*YNORM
  130    CONTINUE
  140 CONTINUE
  S = 1.0D0/DASUM(N,Z,1)
  call DSCAL(N,S,Z,1)
  YNORM = S*YNORM
!
!     SOLVE  U*Z = V
!
  DO 160 KB = 1, N
     K = N + 1 - KB
     if (ABS(Z(K))  <=  ABS(A(K,K))) go to 150
        S = ABS(A(K,K))/ABS(Z(K))
        call DSCAL(N,S,Z,1)
        YNORM = S*YNORM
  150    CONTINUE
     if (A(K,K)  /=  0.0D0) Z(K) = Z(K)/A(K,K)
     if (A(K,K)  ==  0.0D0) Z(K) = 1.0D0
     T = -Z(K)
     call DAXPY(K-1,T,A(1,K),1,Z(1),1)
  160 CONTINUE
!     MAKE ZNORM = 1.0
  S = 1.0D0/DASUM(N,Z,1)
  call DSCAL(N,S,Z,1)
  YNORM = S*YNORM
!
  if (ANORM  /=  0.0D0) RCOND = YNORM/ANORM
  if (ANORM  ==  0.0D0) RCOND = 0.0D0
  return
end subroutine DGECO

subroutine DGEDI (A, LDA, N, IPVT, DET, WORK, JOB)
!
!! DGEDI computes the determinant and inverse of a matrix using the ...
!            factors computed by DGECO or DGEFA.
!
!***LIBRARY   SLATEC (LINPACK)
!***CATEGORY  D3A1, D2A1
!***TYPE      DOUBLE PRECISION (SGEDI-S, DGEDI-D, CGEDI-C)
!***KEYWORDS  DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX
!***AUTHOR  Moler, C. B., (U. of New Mexico)
!***DESCRIPTION
!
!     DGEDI computes the determinant and inverse of a matrix
!     using the factors computed by DGECO or DGEFA.
!
!     On Entry
!
!        A       DOUBLE PRECISION(LDA, N)
!                the output from DGECO or DGEFA.
!
!        LDA     INTEGER
!                the leading dimension of the array  A .
!
!        N       INTEGER
!                the order of the matrix  A .
!
!        IPVT    INTEGER(N)
!                the pivot vector from DGECO or DGEFA.
!
!        WORK    DOUBLE PRECISION(N)
!                work vector.  Contents destroyed.
!
!        JOB     INTEGER
!                = 11   both determinant and inverse.
!                = 01   inverse only.
!                = 10   determinant only.
!
!     On Return
!
!        A       inverse of original matrix if requested.
!                Otherwise unchanged.
!
!        DET     DOUBLE PRECISION(2)
!                determinant of original matrix if requested.
!                Otherwise not referenced.
!                Determinant = DET(1) * 10.0**DET(2)
!                with  1.0  <=  ABS(DET(1))  <  10.0
!                or  DET(1)  ==  0.0 .
!
!     Error Condition
!
!        A division by zero will occur if the input factor contains
!        a zero on the diagonal and the inverse is requested.
!        It will not occur if the subroutines are called correctly
!        and if DGECO has set RCOND  >  0.0 or DGEFA has set
!        INFO  ==  0 .
!
!***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
!                 Stewart, LINPACK Users' Guide, SIAM, 1979.
!***ROUTINES CALLED  DAXPY, DSCAL, DSWAP
!***REVISION HISTORY  (YYMMDD)
!   780814  DATE WRITTEN
!   890531  Changed all specific intrinsics to generic.  (WRB)
!   890831  Modified array declarations.  (WRB)
!   890831  REVISION DATE from Version 3.2
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!   900326  Removed duplicate information from DESCRIPTION section.
!           (WRB)
!   920501  Reformatted the REFERENCES section.  (WRB)
!***END PROLOGUE  DGEDI
  INTEGER LDA,N,IPVT(*),JOB
  DOUBLE PRECISION A(LDA,*),DET(2),WORK(*)
!
  DOUBLE PRECISION T
  DOUBLE PRECISION TEN
  INTEGER I,J,K,KB,KP1,L,NM1
!***FIRST EXECUTABLE STATEMENT  DGEDI
!
!     COMPUTE DETERMINANT
!
  if (JOB/10  ==  0) go to 70
     DET(1) = 1.0D0
     DET(2) = 0.0D0
     TEN = 10.0D0
     DO 50 I = 1, N
        if (IPVT(I)  /=  I) DET(1) = -DET(1)
        DET(1) = A(I,I)*DET(1)
        if (DET(1)  ==  0.0D0) go to 60
   10       if (ABS(DET(1))  >=  1.0D0) go to 20
           DET(1) = TEN*DET(1)
           DET(2) = DET(2) - 1.0D0
        go to 10
   20       CONTINUE
   30       if (ABS(DET(1))  <  TEN) go to 40
           DET(1) = DET(1)/TEN
           DET(2) = DET(2) + 1.0D0
        go to 30
   40       CONTINUE
   50    CONTINUE
   60    CONTINUE
   70 CONTINUE
!
!     COMPUTE INVERSE(U)
!
  if (MOD(JOB,10)  ==  0) go to 150
     DO 100 K = 1, N
        A(K,K) = 1.0D0/A(K,K)
        T = -A(K,K)
        call DSCAL(K-1,T,A(1,K),1)
        KP1 = K + 1
        if (N  <  KP1) go to 90
        DO 80 J = KP1, N
           T = A(K,J)
           A(K,J) = 0.0D0
           call DAXPY(K,T,A(1,K),1,A(1,J),1)
   80       CONTINUE
   90       CONTINUE
  100    CONTINUE
!
!        FORM INVERSE(U)*INVERSE(L)
!
     NM1 = N - 1
     if (NM1  <  1) go to 140
     DO 130 KB = 1, NM1
        K = N - KB
        KP1 = K + 1
        DO 110 I = KP1, N
           WORK(I) = A(I,K)
           A(I,K) = 0.0D0
  110       CONTINUE
        DO 120 J = KP1, N
           T = WORK(J)
           call DAXPY(N,T,A(1,J),1,A(1,K),1)
  120       CONTINUE
        L = IPVT(K)
        if (L  /=  K) call DSWAP(N,A(1,K),1,A(1,L),1)
  130    CONTINUE
  140    CONTINUE
  150 CONTINUE
  return
end subroutine DGEDI

subroutine DGEFA (A, LDA, N, IPVT, INFO)
!
!! DGEFA factors a matrix using Gaussian elimination.
!
!***LIBRARY   SLATEC (LINPACK)
!***CATEGORY  D2A1
!***TYPE      DOUBLE PRECISION (SGEFA-S, DGEFA-D, CGEFA-C)
!***KEYWORDS  GENERAL MATRIX, LINEAR ALGEBRA, LINPACK,
!             MATRIX FACTORIZATION
!***AUTHOR  Moler, C. B., (U. of New Mexico)
!***DESCRIPTION
!
!     DGEFA factors a double precision matrix by Gaussian elimination.
!
!     DGEFA is usually called by DGECO, but it can be called
!     directly with a saving in time if  RCOND  is not needed.
!     (Time for DGECO) = (1 + 9/N)*(Time for DGEFA) .
!
!     On Entry
!
!        A       DOUBLE PRECISION(LDA, N)
!                the matrix to be factored.
!
!        LDA     INTEGER
!                the leading dimension of the array  A .
!
!        N       INTEGER
!                the order of the matrix  A .
!
!     On Return
!
!        A       an upper triangular matrix and the multipliers
!                which were used to obtain it.
!                The factorization can be written  A = L*U  where
!                L  is a product of permutation and unit lower
!                triangular matrices and  U  is upper triangular.
!
!        IPVT    INTEGER(N)
!                an integer vector of pivot indices.
!
!        INFO    INTEGER
!                = 0  normal value.
!                = K  if  U(K,K)  ==  0.0 .  This is not an error
!                     condition for this subroutine, but it does
!                     indicate that DGESL or DGEDI will divide by zero
!                     if called.  Use  RCOND  in DGECO for a reliable
!                     indication of singularity.
!
!***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
!                 Stewart, LINPACK Users' Guide, SIAM, 1979.
!***ROUTINES CALLED  DAXPY, DSCAL, IDAMAX
!***REVISION HISTORY  (YYMMDD)
!   780814  DATE WRITTEN
!   890831  Modified array declarations.  (WRB)
!   890831  REVISION DATE from Version 3.2
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!   900326  Removed duplicate information from DESCRIPTION section.
!           (WRB)
!   920501  Reformatted the REFERENCES section.  (WRB)
!***END PROLOGUE  DGEFA
  INTEGER LDA,N,IPVT(*),INFO
  DOUBLE PRECISION A(LDA,*)
!
  DOUBLE PRECISION T
! INTEGER IDAMAX,J,K,KP1,L,NM1
  INTEGER J,K,KP1,L,NM1
!
!     GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING
!
!***FIRST EXECUTABLE STATEMENT  DGEFA
  INFO = 0
  NM1 = N - 1
  if (NM1  <  1) go to 70
  DO 60 K = 1, NM1
     KP1 = K + 1
!
!        FIND L = PIVOT INDEX
!
     L = IDAMAX(N-K+1,A(K,K),1) + K - 1
     IPVT(K) = L
!
!        ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED
!
     if (A(L,K)  ==  0.0D0) go to 40
!
!           INTERCHANGE if NECESSARY
!
        if (L  ==  K) go to 10
           T = A(L,K)
           A(L,K) = A(K,K)
           A(K,K) = T
   10       CONTINUE
!
!           COMPUTE MULTIPLIERS
!
        T = -1.0D0/A(K,K)
        call DSCAL(N-K,T,A(K+1,K),1)
!
!           ROW ELIMINATION WITH COLUMN INDEXING
!
        DO 30 J = KP1, N
           T = A(L,J)
           if (L  ==  K) go to 20
              A(L,J) = A(K,J)
              A(K,J) = T
   20          CONTINUE
           call DAXPY(N-K,T,A(K+1,K),1,A(K+1,J),1)
   30       CONTINUE
     go to 50
   40    CONTINUE
        INFO = K
   50    CONTINUE
   60 CONTINUE
   70 CONTINUE
  IPVT(N) = N
  if (A(N,N)  ==  0.0D0) INFO = N
  return
end subroutine DGEFA

 subroutine cgedi ( a, lda, n, ipvt, det, work, job )
!*****************************************************************************
!! CGEDI computes the determinant and inverse of a matrix.
!
!  Discussion:
!    The matrix must have been factored by CGECO or CGEFA.
!    A division by zero will occur if the input factor contains
!    a zero on the diagonal and the inverse is requested.
!    It will not occur if the subroutines are called correctly
!    and if CGECO has set 0.0 < RCOND or CGEFA has set
!    INFO == 0.
!
!  Licensing:
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!    29 April 2007
!
!  Author:
!    FORTRAN90 version by John Burkardt
!
!  Reference:
!    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
!    LINPACK User's Guide,
!    SIAM, 1979,
!    ISBN13: 978-0-898711-72-1,
!    LC: QA214.L56.
!
!  Parameters:
!    Input/output, complex ( kind = 4 ) A(LDA,N); on input, the factor information
!    from CGECO or CGEFA.  On output, the inverse matrix, if it
!    was requested,
!    Input, integer ( kind = 4 ) LDA, the leading dimension of A.
!    Input, integer ( kind = 4 ) N, the order of the matrix.
!    Input, integer ( kind = 4 ) IPVT(N), the pivot vector from CGECO or CGEFA.
!    Output, complex ( kind = 4 ) DET(2), the determinant of the original matrix,
!    if requested.  Otherwise not referenced.
!    Determinant = DET(1) * 10.0**DET(2) with
!    1.0 <= cabs1 ( DET(1) ) < 10.0 or DET(1) == 0.0.
!    Also, DET(2) is strictly real.
!
!    Workspace, complex WORK(N).
!    Input, integer ( kind = 4 ) JOB.
!    11, both determinant and inverse.
!    01, inverse only.
!    10, determinant only.
!
  implicit none

  integer ( kind = 4 ) lda
  integer ( kind = 4 ) n

  complex ( kind = 4 ) a(lda,n)
! real    ( kind = 4 ) cabs1
  complex ( kind = 4 ) det(2)
  integer ( kind = 4 ) i
  integer ( kind = 4 ) ipvt(n)
  integer ( kind = 4 ) j
  integer ( kind = 4 ) job
  integer ( kind = 4 ) k
  integer ( kind = 4 ) l
  complex ( kind = 4 ) t
  complex ( kind = 4 ) work(n)
!
!  Compute the determinant.
!
  if ( job / 10 /= 0 ) then
    det(1) = cmplx ( 1.0E+00, 0.0E+00 )
    det(2) = cmplx ( 0.0E+00, 0.0E+00 )
    do i = 1, n
      if ( ipvt(i) /= i ) then
        det(1) = -det(1)
      end if
      det(1) = det(1) * a(i,i)
      if ( cabs1 ( det(1) ) == 0.0E+00 ) then
        exit
      end if
      do while ( cabs1 ( det(1) ) < 1.0E+00 )
        det(1) = det(1) * cmplx ( 10.0E+00, 0.0E+00 )
        det(2) = det(2) - cmplx ( 1.0E+00, 0.0E+00 )
      end do
      do while ( 10.0E+00 <= cabs1 ( det(1) ) )
        det(1) = det(1) / cmplx ( 10.0E+00, 0.0E+00 )
        det(2) = det(2) + cmplx ( 1.0E+00, 0.0E+00 )
      end do
    end do
  end if
!
!  Compute inverse(U).
!
  if ( mod ( job, 10 ) /= 0 ) then
    do k = 1, n
      a(k,k) = cmplx ( 1.0E+00, 0.0E+00 ) / a(k,k)
      t = -a(k,k)
      a(1:k-1,k) = a(1:k-1,k) * t
      do j = k+1, n
        t = a(k,j)
        a(k,j) = cmplx ( 0.0E+00, 0.0E+00 )
        a(1:k,j) = a(1:k,j) + t * a(1:k,k)
      end do
    end do
!
!  Form inverse(U) * inverse(L).
!
    do k = n-1, 1, -1
      work(k+1:n) = a(k+1:n,k)
      a(k+1:n,k) = cmplx ( 0.0E+00, 0.0E+00 )
      do j = k+1, n
        t = work(j)
        a(1:n,k) = a(1:n,k) + t * a(1:n,j)
      end do
      l = ipvt(k)
      if ( l /= k ) then
        work(1:n) = a(1:n,k)
        a(1:n,k)  = a(1:n,l)
        a(1:n,l)  = work(1:n)
      end if
    end do
  end if

  return
 end subroutine cgedi

 subroutine cgefa ( a, lda, n, ipvt, info )
!*****************************************************************************80
!! CGEFA factors a complex matrix by Gaussian elimination.
!
!  Licensing:
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!    07 May 2006
!
!  Author:
!    FORTRAN90 version by John Burkardt
!
!  Reference:
!    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
!    LINPACK User's Guide,
!    SIAM, 1979,
!    ISBN13: 978-0-898711-72-1,
!    LC: QA214.L56.
!
!  Parameters:
!    Input/output, complex ( kind = 4 ) A(LDA,N); on input, the matrix to be factored.
!    On output, an upper triangular matrix and the multipliers which were
!    used to obtain it.  The factorization can be written A = L*U where
!    L is a product of permutation and unit lower triangular matrices and
!    U is upper triangular.
!    Input, integer ( kind = 4 ) LDA, the leading dimension of A.
!    Input, integer ( kind = 4 ) N, the order of the matrix.
!    Output, integer ( kind = 4 ) IPVT(N), the pivot indices.
!    Output, integer ( kind = 4 ) INFO,
!    0, normal value.
!    K, if U(K,K) == 0.0.  This is not an error condition for this
!    subroutine, but it does indicate that CGESL or CGEDI will divide by zero
!    if called.  Use RCOND in CGECO for a reliable indication of singularity.
!
  implicit none

  integer ( kind = 4 ) lda
  integer ( kind = 4 ) n

  complex ( kind = 4 ) a(lda,n)
! real    ( kind = 4 ) cabs1
! integer ( kind = 4 ) icamax
  integer ( kind = 4 ) info
  integer ( kind = 4 ) ipvt(n)
  integer ( kind = 4 ) j
  integer ( kind = 4 ) k
  integer ( kind = 4 ) l
  complex ( kind = 4 ) t
!
!  Gaussian elimination with partial pivoting.
!
  info = 0

  do k = 1, n - 1
!
!  Find L = pivot index.
!
    l = icamax ( n-k+1, a(k:n,k), 1 ) + k - 1
    ipvt(k) = l
!
!  Zero pivot implies this column already triangularized.
!
    if ( cabs1 ( a(l,k) ) == 0.0E+00 ) then
      info = k
      cycle
    end if
!
!  Interchange if necessary.
!
    if ( l /= k ) then
      t      = a(l,k)
      a(l,k) = a(k,k)
      a(k,k) = t
    end if
!
!  Compute multipliers
!
    t = - cmplx ( 1.0E+00, 0.0E+00 ) / a(k,k)
    a(k+1:n,k) = a(k+1:n,k) * t
!
!  Row elimination with column indexing
!
    do j = k+1, n
      t = a(l,j)
      if ( l /= k ) then
        a(l,j) = a(k,j)
        a(k,j) = t
      end if
      a(k+1:n,j) = a(k+1:n,j) + t * a(k+1:n,k)
    end do
  end do

  ipvt(n) = n

  if ( cabs1 ( a(n,n) ) == 0.0E+00 ) then
    info = n
  end if

  return
 end subroutine cgefa

 subroutine cgeco ( a, lda, n, ipvt, rcond, z )
!*****************************************************************************80
!! CGECO factors a complex matrix and estimates its condition.
!
!  Discussion:
!    If RCOND is not needed, CGEFA is slightly faster.
!    To solve A*X = B, follow CGECO by CGESL.
!    To compute inverse(A)*C, follow CGECO by CGESL.
!    To compute determinant(A), follow CGECO by CGEDI.
!    To compute inverse(A), follow CGECO by CGEDI.
!
!  Licensing:
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!    07 May 2006
!
!  Author:
!    FORTRAN90 version by John Burkardt
!
!  Reference:
!    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
!    LINPACK User's Guide,
!    SIAM, 1979,
!    ISBN13: 978-0-898711-72-1,
!    LC: QA214.L56.
!
!  Parameters:
!    Input/output, complex ( kind = 4 )A(LDA,N), on input, the matrix to be factored.
!    On output, an upper triangular matrix and the multipliers which were
!    used to obtain it.  The factorization can be written A = L*U where
!    L is a product of permutation and unit lower triangular matrices
!    and U is upper triangular.
!    Input, integer ( kind = 4 ) LDA, the leading dimension of A.
!    Input, integer ( kind = 4 ) N, the order of the matrix.
!    Output, integer ( kind = 4 ) IPVT(N), the pivot indices.
!    Output, real ( kind = 4 ) RCOND, an estimate of the reciprocal condition of A.
!    For the system A*X = B, relative perturbations in A and B of size
!    EPSILON may cause relative perturbations in X of size (EPSILON/RCOND).
!    If RCOND is so small that the logical expression
!      1.0 + RCOND == 1.0
!    is true, then A may be singular to working precision.  In particular,
!    RCOND is zero if exact singularity is detected or the estimate
!    underflows.
!
!    Workspace, complex Z(N), a work vector whose contents are usually
!    unimportant.  If A is close to a singular matrix, then Z is
!    an approximate null vector in the sense that
!      norm ( A * Z ) = RCOND * norm ( A ) * norm ( Z ).
!
  implicit none

  integer ( kind = 4 ) lda
  integer ( kind = 4 ) n

  complex ( kind = 4 ) a(lda,n)
  real    ( kind = 4 ) anorm
! real    ( kind = 4 ) cabs1
  complex ( kind = 4 ) cdotc
! complex ( kind = 4 ) csign1
  complex ( kind = 4 ) ek
  integer ( kind = 4 ) info
  integer ( kind = 4 ) ipvt(n)
  integer ( kind = 4 ) j
  integer ( kind = 4 ) k
  integer ( kind = 4 ) l
  real    ( kind = 4 ) rcond
  real    ( kind = 4 ) s
! real    ( kind = 4 ) scasum
  real    ( kind = 4 ) sm
  complex ( kind = 4 ) t
  complex ( kind = 4 ) wk
  complex ( kind = 4 ) wkm
  real    ( kind = 4 ) ynorm
  complex ( kind = 4 ) z(n)
!
!  Compute the 1-norm of A.
!
  anorm = 0.0E+00
  do j = 1, n
    anorm = max ( anorm, scasum ( n, a(1:n,j), 1 ) )
  end do
!
!  Factor.
!
  call cgefa ( a, lda, n, ipvt, info )
!
!  RCOND = 1/(norm(A)*(estimate of norm(inverse(A)))).
!  Estimate = norm(Z)/norm(Y) where A*Z = Y and hermitian(A)*Y = E.
!  Hermitian(A) is the conjugate transpose of A.
!  The components of E are chosen to cause maximum local
!  growth in the elements of W where hermitian(U)*W = E.
!  The vectors are frequently rescaled to avoid overflow.
!  Solve hermitian(U)*W = E.
!
  ek = cmplx ( 1.0E+00, 0.0E+00 )
  z(1:n) = cmplx ( 0.0E+00, 0.0E+00 )

  do k = 1, n
    if ( cabs1 ( z(k) ) /= 0.0E+00 ) then
      ek = csign1 ( ek, -z(k) )
    end if
    if ( cabs1 ( a(k,k) ) < cabs1 ( ek - z(k) ) ) then
      s = cabs1 ( a(k,k) ) / cabs1 ( ek - z(k) )
      z(1:n) = z(1:n) * s
      ek = cmplx ( s, 0.0E+00 ) * ek
    end if
    wk = ek - z(k)
    wkm = -ek - z(k)
    s = cabs1 ( wk )
    sm = cabs1 ( wkm )
    if ( cabs1 ( a(k,k) ) /= 0.0E+00 ) then
      wk = wk / conjg ( a(k,k) )
      wkm = wkm / conjg ( a(k,k) )
    else
      wk = cmplx ( 1.0E+00, 0.0E+00 )
      wkm = cmplx ( 1.0E+00, 0.0E+00 )
    end if
    do j = k+1, n
      sm = sm + cabs1 ( z(j) + wkm * conjg ( a(k,j) ) )
      z(j) = z(j) + wk * conjg ( a(k,j) )
      s = s + cabs1 ( z(j) )
    end do
    if ( s < sm ) then
      t = wkm - wk
      wk = wkm
      z(k+1:n) = z(k+1:n) + t * conjg ( a(k,k+1:n) )
    end if
    z(k) = wk
  end do

  s = 1.0E+00 / scasum ( n, z, 1 )
  z(1:n) = z(1:n) * s
!
!  Solve hermitian(L) * Y = W.
!
  do k = n, 1, -1
    if ( k < n ) then
!     z(k) = z(k) + cdotc ( n-k, a(k+1:n,k), 1, z(k+1:n), 1 )
      z(k) = z(k) + dot_product ( a(k+1:n,k), z(k+1:n) )
    end if
    if ( 1.0E+00 < cabs1 ( z(k) ) ) then
      s = 1.0E+00 / cabs1 ( z(k) )
      z(1:n) = z(1:n) * s
    end if
    l = ipvt(k)
    t    = z(l)
    z(l) = z(k)
    z(k) = t
  end do

  s = 1.0E+00 / scasum ( n, z, 1 )
  z(1:n) = z(1:n) * s
  ynorm = 1.0E+00
!
!  Solve L * V = Y.
!
  do k = 1, n
    l = ipvt(k)
    t = z(l)
    z(l) = z(k)
    z(k) = t
    if ( k < n ) then
      z(k+1:n) = z(k+1:n) + t * a(k+1:n,k)
    end if
    if ( 1.0E+00 < cabs1 ( z(k) ) ) then
      s = 1.0E+00 / cabs1 ( z(k) )
      z(1:n) = z(1:n) * s
      ynorm = s * ynorm
    end if
  end do

  s = 1.0E+00 / scasum ( n, z, 1 )
  z(1:n) = z(1:n) * s
  ynorm = s * ynorm
!
!  Solve U * Z = V.
!
  do k = n, 1, -1
    if ( cabs1 ( a(k,k) ) < cabs1 ( z(k) ) ) then
      s = cabs1 ( a(k,k) ) / cabs1 ( z(k) )
      z(1:n) = z(1:n) * s
      ynorm = s * ynorm
    end if
    if ( cabs1 ( a(k,k) ) /= 0.0E+00 ) then
      z(k) = z(k) / a(k,k)
    else
      z(k) = cmplx ( 1.0E+00, 0.0E+00 )
    end if
    t = -z(k)
    z(1:k-1) = z(1:k-1) + t * a(1:k-1,k)
  end do
!
!  Make ZNORM = 1.
!
  s = 1.0E+00 / scasum ( n, z, 1 )
  z(1:n) = z(1:n) * s
  ynorm = s * ynorm

  if ( anorm /= 0.0E+00 ) then
    rcond = ynorm / anorm
  else
    rcond = 0.0E+00
  end if

  return
 end subroutine cgeco

 function pythag ( a, b )
!
!*******************************************************************************
!
!! PYTHAG computes SQRT ( A**2 + B**2 ) carefully.
!
!
!  Discussion:
!
!    The formula
!
!      PYTHAG = sqrt ( A**2 + B**2 )
!
!    is reasonably accurate, but can fail if, for example, A**2 is larger
!    than the machine overflow.  The formula can lose most of its accuracy
!    if the sum of the squares is very large or very small.
!
!  Modified:
!
!    20 March 2002
!
!  Reference:
!
!    J H Wilkinson and C Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer Verlag, 1971.
!
!    B Smith, J Boyle, J Dongarra, B Garbow, Y Ikebe, V Klema, C Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976.
!
!  Modified:
!
!    02 March 2000
!
!  Parameters:
!
!    Input, real A, B, the two legs of a right triangle.
!
!    Output, real PYTHAG, the length of the hypotenuse.
!
  implicit none
!
  real a
  real b
  real p
  real pythag
  real r
  real s
  real t
  real u
!
  p = max ( abs ( a ), abs ( b ) )

  if ( p /= 0.0E+00 ) then

    r = ( min ( abs ( a ), abs ( b ) ) / p )**2

    do

      t = 4.0E+00 + r

      if ( t == 4.0E+00 ) then
        exit
      end if

      s = r / t
      u = 1.0E+00 + 2.0E+00 * s
      p = u * p
      r = ( s / u )**2 * r

    end do

  end if

  pythag = p

  return
 end function pythag

 function cabs1 ( z )
!*****************************************************************************80
!! CABS1 returns the L1 norm of a single precision complex number.
!
!  Discussion:
!    The L1 norm of a complex number is the sum of the absolute values
!    of the real and imaginary components.
!    CABS1 ( Z ) = abs ( real ( Z ) ) + abs ( imaginary ( Z ) )
!
!  Licensing:
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!    22 May 2002
!
!  Author:
!    FORTRAN90 version by John Burkardt
!
!  Reference:
!    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
!    LINPACK User's Guide,
!    SIAM, 1979,
!    ISBN13: 978-0-898711-72-1,
!    LC: QA214.L56.
!
!    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
!    Basic Linear Algebra Subprograms for FORTRAN usage,
!    ACM Transactions on Mathematical Software,
!    Volume 5, Number 3, pages 308-323, 1979.
!
!  Parameters:
!    Input, complex ( kind = 4 ) Z, the number whose norm is desired.
!    Output, real ( kind = 4 ) CABS1, the L1 norm of Z.
!
  implicit none

  real ( kind = 4 ) cabs1
  complex ( kind = 4 ) z

  cabs1 = abs ( real ( z ) ) + abs ( aimag ( z ) )

  return
 end function cabs1

 function cabs2 ( z )
!*****************************************************************************80
!! CABS2 returns the L2 norm of a single precision complex number.
!
!  Discussion:
!    The L2 norm of a complex number is the square root of the sum
!    of the squares of the real and imaginary components.
!    CABS2 ( Z ) = sqrt ( ( real ( Z ) )**2 + ( imaginary ( Z ) )**2 )
!
!  Licensing:
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!    19 March 2006
!
!  Author:
!    FORTRAN90 version by John Burkardt
!
!  Reference:
!    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
!    LINPACK User's Guide,
!    SIAM, 1979,
!    ISBN13: 978-0-898711-72-1,
!    LC: QA214.L56.
!
!    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
!    Basic Linear Algebra Subprograms for FORTRAN usage,
!    ACM Transactions on Mathematical Software,
!    Volume 5, Number 3, pages 308-323, 1979.
!
!  Parameters:
!    Input, complex ( kind = 4 ) Z, the number whose norm is desired.
!    Output, real ( kind = 4 ) CABS2, the L2 norm of Z.
!
  implicit none

  real ( kind = 4 ) cabs2
  complex ( kind = 4 ) z

  cabs2 = sqrt ( ( real ( z ) )**2 + ( aimag ( z ) )**2 )

  return
 end function cabs2

 function icamax ( n, x, incx )
!*****************************************************************************80
!! ICAMAX indexes the vector element of maximum absolute value.
!
!  Discussion:
!    This routine uses single precision complex arithmetic.
!
!  Licensing:
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!    11 April 2006
!
!  Author:
!    FORTRAN90 version by John Burkardt
!
!  Reference:
!    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
!    LINPACK User's Guide,
!    SIAM, 1979,
!    ISBN13: 978-0-898711-72-1,
!    LC: QA214.L56.
!
!    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
!    Basic Linear Algebra Subprograms for FORTRAN usage,
!    ACM Transactions on Mathematical Software,
!    Volume 5, Number 3, pages 308-323, 1979.
!
!  Parameters:
!    Input, integer ( kind = 4 ) N, the number of entries in the vector.
!    Input, complex ( kind = 4 ) X(*), the vector.
!    Input, integer ( kind = 4 ) INCX, the increment between successive
!    entries of X.
!    Output, integer ( kind = 4 ) ICAMAX, the index of the element of maximum
!    absolute value.
!
  implicit none

! real ( kind = 4 ) cabs1
  integer ( kind = 4 ) i
  integer ( kind = 4 ) icamax
  integer ( kind = 4 ) incx
  integer ( kind = 4 ) ix
  integer ( kind = 4 ) n
  real ( kind = 4 ) smax
  complex ( kind = 4 ) x(*)

  icamax = 0
  if ( n < 1 .or. incx  <=  0 ) then
    return
  end if

  icamax = 1

  if ( n == 1 ) then
    return
  end if

  if ( incx /= 1 ) then
    ix = 1
    smax = cabs1 ( x(1) )
    ix = ix + incx
    do i = 2, n
      if ( smax < cabs1 ( x(ix) ) ) then
        icamax = i
        smax = cabs1 ( x(ix) )
      end if
      ix = ix + incx
    end do
  else
    smax = cabs1 ( x(1) )
    do i = 2, n
      if ( smax < cabs1 ( x(i) ) ) then
        icamax = i
        smax = cabs1 ( x(i) )
      end if
    end do
  end if

  return
 end function icamax

 function csign1 ( z1, z2 )
!*****************************************************************************80
!! CSIGN1 is a single precision complex transfer-of-sign function.
!
!  Discussion:
!    The L1 norm is used.
!
!  Licensing:
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!    14 May 2004
!
!  Author:
!    FORTRAN90 version by John Burkardt
!
!  Parameters:
!    Input, complex ( kind = 4 ) Z1, Z2, the arguments.
!    Output, complex ( kind = 4 ) CSIGN1,  a complex value, with the magnitude of
!    Z1, and the argument of Z2.
!
  implicit none

! real ( kind = 4 ) cabs1
  complex ( kind = 4 ) csign1
  complex ( kind = 4 ) z1
  complex ( kind = 4 ) z2

  if ( cabs1 ( z2 ) == 0.0E+00 ) then
    csign1 = cmplx ( 0.0E+00, 0.0E+00 )
  else
    csign1 = cabs1 ( z1 ) * ( z2 / cabs1 ( z2 ) )
  end if

  return
 end function csign1

 function csign2 ( z1, z2 )
!*****************************************************************************80
!! CSIGN2 is a single precision complex transfer-of-sign function.
!
!  Discussion:
!    The L2 norm is used.
!
!  Licensing:
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!    19 March 2006
!
!  Author:
!    FORTRAN90 version by John Burkardt
!
!  Parameters:
!    Input, complex ( kind = 4 ) Z1, Z2, the arguments.
!    Output, complex ( kind = 4 ) CSIGN2,  a complex value, with the magnitude of
!    Z1, and the argument of Z2.
!
  implicit none

! real ( kind = 4 ) cabs2
  complex ( kind = 4 ) csign2
  complex ( kind = 4 ) z1
  complex ( kind = 4 ) z2

  if ( cabs2 ( z2 ) == 0.0E+00 ) then
    csign2 = cmplx ( 0.0E+00, 0.0E+00 )
  else
    csign2 = cabs2 ( z1 ) * ( z2 / cabs2 ( z2 ) )
  end if

  return
 end function csign2

 function scasum ( n, x, incx )
!*****************************************************************************80
!! SCASUM takes the sum of the absolute values of a vector.
!
!  Discussion:
!    This routine uses single precision complex arithmetic.
!
!  Licensing:
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!    11 April 2006
!
!  Author:
!    FORTRAN90 version by John Burkardt
!
!  Reference:
!    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
!    LINPACK User's Guide,
!    SIAM, 1979,
!    ISBN13: 978-0-898711-72-1,
!    LC: QA214.L56.
!
!    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
!    Basic Linear Algebra Subprograms for FORTRAN usage,
!    ACM Transactions on Mathematical Software,
!    Volume 5, Number 3, pages 308-323, 1979.
!
!  Parameters:
!    Input, integer ( kind = 4 ) N, the number of entries in the vector.
!    Input, complex ( kind = 4 ) X(*), the vector.
!    Input, integer ( kind = 4 ) INCX, the increment between successive
!    entries of X.
!    Output, real ( kind = 4 ) SCASUM, the sum of the absolute values.
!
  implicit none

  integer ( kind = 4 ) incx
  integer ( kind = 4 ) n
  integer ( kind = 4 ) nincx
  real ( kind = 4 ) scasum
  complex ( kind = 4 ) x(*)

  scasum = 0.0E+00

  if ( n <= 0 .or. incx <= 0 ) then
    return
  end if

  if ( incx == 1 ) then
    scasum = sum ( abs ( real ( x(1:n) ) ) + abs ( aimag ( x(1:n) ) ) )
  else
    nincx = n * incx
    scasum = sum ( abs ( real ( x(1:nincx:incx) ) ) &
                 + abs ( aimag ( x(1:nincx:incx) ) ) )
  end if

  return
 end function scasum

  INTEGER FUNCTION IDAMAX (N, DX, INCX)
!
!! IDAMAX finds the smallest index of that component of a vector ...
!            having the maximum magnitude.
!
!***LIBRARY   SLATEC (BLAS)
!***CATEGORY  D1A2
!***TYPE      DOUBLE PRECISION (ISAMAX-S, IDAMAX-D, ICAMAX-C)
!***KEYWORDS  BLAS, LINEAR ALGEBRA, MAXIMUM COMPONENT, VECTOR
!***AUTHOR  Lawson, C. L., (JPL)
!           Hanson, R. J., (SNLA)
!           Kincaid, D. R., (U. of Texas)
!           Krogh, F. T., (JPL)
!***DESCRIPTION
!
!                B L A S  Subprogram
!    Description of Parameters
!
!     --Input--
!        N  number of elements in input vector(s)
!       DX  double precision vector with N elements
!     INCX  storage spacing between elements of DX
!
!     --Output--
!   IDAMAX  smallest index (zero if N  <=  0)
!
!     Find smallest index of maximum magnitude of double precision DX.
!     IDAMAX = first I, I = 1 to N, to maximize ABS(DX(IX+(I-1)*INCX)),
!     where IX = 1 if INCX  >=  0, else IX = 1+(1-N)*INCX.
!
!***REFERENCES  C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T.
!                 Krogh, Basic linear algebra subprograms for Fortran
!                 usage, Algorithm No. 539, Transactions on Mathematical
!                 Software 5, 3 (September 1979), pp. 308-323.
!***ROUTINES CALLED  (NONE)
!***REVISION HISTORY  (YYMMDD)
!   791001  DATE WRITTEN
!   890531  Changed all specific intrinsics to generic.  (WRB)
!   890531  REVISION DATE from Version 3.2
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!   900821  Modified to correct problem with a negative increment.
!           (WRB)
!   920501  Reformatted the REFERENCES section.  (WRB)
!***END PROLOGUE  IDAMAX
  DOUBLE PRECISION DX(*), DMAX, XMAG
  INTEGER I, INCX, IX, N
!***FIRST EXECUTABLE STATEMENT  IDAMAX
  IDAMAX = 0
  if (N  <=  0) RETURN
  IDAMAX = 1
  if (N  ==  1) RETURN
!
  if (INCX  ==  1) GOTO 20
!
!     Code for increments not equal to 1.
!
  IX = 1
  if (INCX  <  0) IX = (-N+1)*INCX + 1
  DMAX = ABS(DX(IX))
  IX = IX + INCX
  DO 10 I = 2,N
    XMAG = ABS(DX(IX))
    if (XMAG  >  DMAX) THEN
      IDAMAX = I
      DMAX = XMAG
    ENDIF
    IX = IX + INCX
   10 CONTINUE
  return
!
!     Code for increments equal to 1.
!
   20 DMAX = ABS(DX(1))
  DO 30 I = 2,N
    XMAG = ABS(DX(I))
    if (XMAG  >  DMAX) THEN
      IDAMAX = I
      DMAX = XMAG
    ENDIF
   30 CONTINUE
  return
end function IDAMAX

subroutine DSCAL (N, DA, DX, INCX)
!
!! DSCAL multiplies a vector by a constant.
!
!***LIBRARY   SLATEC (BLAS)
!***CATEGORY  D1A6
!***TYPE      DOUBLE PRECISION (SSCAL-S, DSCAL-D, CSCAL-C)
!***KEYWORDS  BLAS, LINEAR ALGEBRA, SCALE, VECTOR
!***AUTHOR  Lawson, C. L., (JPL)
!           Hanson, R. J., (SNLA)
!           Kincaid, D. R., (U. of Texas)
!           Krogh, F. T., (JPL)
!***DESCRIPTION
!
!                B L A S  Subprogram
!    Description of Parameters
!
!     --Input--
!        N  number of elements in input vector(s)
!       DA  double precision scale factor
!       DX  double precision vector with N elements
!     INCX  storage spacing between elements of DX
!
!     --Output--
!       DX  double precision result (unchanged if N <= 0)
!
!     Replace double precision DX by double precision DA*DX.
!     For I = 0 to N-1, replace DX(IX+I*INCX) with  DA * DX(IX+I*INCX),
!     where IX = 1 if INCX  >=  0, else IX = 1+(1-N)*INCX.
!
!***REFERENCES  C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T.
!                 Krogh, Basic linear algebra subprograms for Fortran
!                 usage, Algorithm No. 539, Transactions on Mathematical
!                 Software 5, 3 (September 1979), pp. 308-323.
!***ROUTINES CALLED  (NONE)
!***REVISION HISTORY  (YYMMDD)
!   791001  DATE WRITTEN
!   890831  Modified array declarations.  (WRB)
!   890831  REVISION DATE from Version 3.2
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!   900821  Modified to correct problem with a negative increment.
!           (WRB)
!   920501  Reformatted the REFERENCES section.  (WRB)
!***END PROLOGUE  DSCAL
  DOUBLE PRECISION DA, DX(*)
  INTEGER I, INCX, IX, M, MP1, N
!***FIRST EXECUTABLE STATEMENT  DSCAL
  if (N  <=  0) RETURN
  if (INCX  ==  1) GOTO 20
!
!     Code for increment not equal to 1.
!
  IX = 1
  if (INCX  <  0) IX = (-N+1)*INCX + 1
  DO 10 I = 1,N
    DX(IX) = DA*DX(IX)
    IX = IX + INCX
   10 CONTINUE
  return
!
!     Code for increment equal to 1.
!
!     Clean-up loop so remaining vector length is a multiple of 5.
!
   20 M = MOD(N,5)
  if (M  ==  0) GOTO 40
  DO 30 I = 1,M
    DX(I) = DA*DX(I)
   30 CONTINUE
  if (N  <  5) RETURN
   40 MP1 = M + 1
  DO 50 I = MP1,N,5
    DX(I) = DA*DX(I)
    DX(I+1) = DA*DX(I+1)
    DX(I+2) = DA*DX(I+2)
    DX(I+3) = DA*DX(I+3)
    DX(I+4) = DA*DX(I+4)
   50 CONTINUE
  return
end subroutine DSCAL

subroutine DAXPY (N, DA, DX, INCX, DY, INCY)
!
!! DAXPY computes a constant times a vector plus a vector.
!
!***LIBRARY   SLATEC (BLAS)
!***CATEGORY  D1A7
!***TYPE      DOUBLE PRECISION (SAXPY-S, DAXPY-D, CAXPY-C)
!***KEYWORDS  BLAS, LINEAR ALGEBRA, TRIAD, VECTOR
!***AUTHOR  Lawson, C. L., (JPL)
!           Hanson, R. J., (SNLA)
!           Kincaid, D. R., (U. of Texas)
!           Krogh, F. T., (JPL)
!***DESCRIPTION
!
!                B L A S  Subprogram
!    Description of Parameters
!
!     --Input--
!        N  number of elements in input vector(s)
!       DA  double precision scalar multiplier
!       DX  double precision vector with N elements
!     INCX  storage spacing between elements of DX
!       DY  double precision vector with N elements
!     INCY  storage spacing between elements of DY
!
!     --Output--
!       DY  double precision result (unchanged if N  <=  0)
!
!     Overwrite double precision DY with double precision DA*DX + DY.
!     For I = 0 to N-1, replace  DY(LY+I*INCY) with DA*DX(LX+I*INCX) +
!       DY(LY+I*INCY),
!     where LX = 1 if INCX  >=  0, else LX = 1+(1-N)*INCX, and LY is
!     defined in a similar way using INCY.
!
!***REFERENCES  C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T.
!                 Krogh, Basic linear algebra subprograms for Fortran
!                 usage, Algorithm No. 539, Transactions on Mathematical
!                 Software 5, 3 (September 1979), pp. 308-323.
!***ROUTINES CALLED  (NONE)
!***REVISION HISTORY  (YYMMDD)
!   791001  DATE WRITTEN
!   890831  Modified array declarations.  (WRB)
!   890831  REVISION DATE from Version 3.2
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!   920310  Corrected definition of LX in DESCRIPTION.  (WRB)
!   920501  Reformatted the REFERENCES section.  (WRB)
!***END PROLOGUE  DAXPY
  DOUBLE PRECISION DX(*), DY(*), DA
!***FIRST EXECUTABLE STATEMENT  DAXPY
  if (N <= 0 .OR. DA == 0.0D0) RETURN
  if (INCX  ==  INCY) IF (INCX-1) 5,20,60
!
!     Code for unequal or nonpositive increments.
!
    5 IX = 1
  IY = 1
  if (INCX  <  0) IX = (-N+1)*INCX + 1
  if (INCY  <  0) IY = (-N+1)*INCY + 1
  DO 10 I = 1,N
    DY(IY) = DY(IY) + DA*DX(IX)
    IX = IX + INCX
    IY = IY + INCY
   10 CONTINUE
  return
!
!     Code for both increments equal to 1.
!
!     Clean-up loop so remaining vector length is a multiple of 4.
!
   20 M = MOD(N,4)
  if (M  ==  0) go to 40
  DO 30 I = 1,M
    DY(I) = DY(I) + DA*DX(I)
   30 CONTINUE
  if (N  <  4) RETURN
   40 MP1 = M + 1
  DO 50 I = MP1,N,4
    DY(I) = DY(I) + DA*DX(I)
    DY(I+1) = DY(I+1) + DA*DX(I+1)
    DY(I+2) = DY(I+2) + DA*DX(I+2)
    DY(I+3) = DY(I+3) + DA*DX(I+3)
   50 CONTINUE
  return
!
!     Code for equal, positive, non-unit increments.
!
   60 NS = N*INCX
  DO 70 I = 1,NS,INCX
    DY(I) = DA*DX(I) + DY(I)
   70 CONTINUE
  return
end subroutine DAXPY

subroutine DSWAP (N, DX, INCX, DY, INCY)
!
!! DSWAP interchanges two vectors.
!
!***LIBRARY   SLATEC (BLAS)
!***CATEGORY  D1A5
!***TYPE      DOUBLE PRECISION (SSWAP-S, DSWAP-D, CSWAP-C, ISWAP-I)
!***KEYWORDS  BLAS, INTERCHANGE, LINEAR ALGEBRA, VECTOR
!***AUTHOR  Lawson, C. L., (JPL)
!           Hanson, R. J., (SNLA)
!           Kincaid, D. R., (U. of Texas)
!           Krogh, F. T., (JPL)
!***DESCRIPTION
!
!                B L A S  Subprogram
!    Description of Parameters
!
!     --Input--
!        N  number of elements in input vector(s)
!       DX  double precision vector with N elements
!     INCX  storage spacing between elements of DX
!       DY  double precision vector with N elements
!     INCY  storage spacing between elements of DY
!
!     --Output--
!       DX  input vector DY (unchanged if N  <=  0)
!       DY  input vector DX (unchanged if N  <=  0)
!
!     Interchange double precision DX and double precision DY.
!     For I = 0 to N-1, interchange  DX(LX+I*INCX) and DY(LY+I*INCY),
!     where LX = 1 if INCX  >=  0, else LX = 1+(1-N)*INCX, and LY is
!     defined in a similar way using INCY.
!
!***REFERENCES  C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T.
!                 Krogh, Basic linear algebra subprograms for Fortran
!                 usage, Algorithm No. 539, Transactions on Mathematical
!                 Software 5, 3 (September 1979), pp. 308-323.
!***ROUTINES CALLED  (NONE)
!***REVISION HISTORY  (YYMMDD)
!   791001  DATE WRITTEN
!   890831  Modified array declarations.  (WRB)
!   890831  REVISION DATE from Version 3.2
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!   920310  Corrected definition of LX in DESCRIPTION.  (WRB)
!   920501  Reformatted the REFERENCES section.  (WRB)
!***END PROLOGUE  DSWAP
  DOUBLE PRECISION DX(*), DY(*), DTEMP1, DTEMP2, DTEMP3
!***FIRST EXECUTABLE STATEMENT  DSWAP
  if (N  <=  0) RETURN
  if (INCX  ==  INCY) IF (INCX-1) 5,20,60
!
!     Code for unequal or nonpositive increments.
!
    5 IX = 1
  IY = 1
  if (INCX  <  0) IX = (-N+1)*INCX + 1
  if (INCY  <  0) IY = (-N+1)*INCY + 1
  DO 10 I = 1,N
    DTEMP1 = DX(IX)
    DX(IX) = DY(IY)
    DY(IY) = DTEMP1
    IX = IX + INCX
    IY = IY + INCY
   10 CONTINUE
  return
!
!     Code for both increments equal to 1.
!
!     Clean-up loop so remaining vector length is a multiple of 3.
!
   20 M = MOD(N,3)
  if (M  ==  0) go to 40
  DO 30 I = 1,M
    DTEMP1 = DX(I)
    DX(I) = DY(I)
    DY(I) = DTEMP1
   30 CONTINUE
  if (N  <  3) RETURN
   40 MP1 = M + 1
  DO 50 I = MP1,N,3
    DTEMP1 = DX(I)
    DTEMP2 = DX(I+1)
    DTEMP3 = DX(I+2)
    DX(I) = DY(I)
    DX(I+1) = DY(I+1)
    DX(I+2) = DY(I+2)
    DY(I) = DTEMP1
    DY(I+1) = DTEMP2
    DY(I+2) = DTEMP3
   50 CONTINUE
  return
!
!     Code for equal, positive, non-unit increments.
!
   60 NS = N*INCX
  DO 70 I = 1,NS,INCX
    DTEMP1 = DX(I)
    DX(I) = DY(I)
    DY(I) = DTEMP1
   70 CONTINUE
  return
end subroutine DSWAP

  DOUBLE PRECISION FUNCTION DDOT (N, DX, INCX, DY, INCY)
!
!! DDOT computes the inner product of two vectors.
!
!***LIBRARY   SLATEC (BLAS)
!***CATEGORY  D1A4
!***TYPE      DOUBLE PRECISION (SDOT-S, DDOT-D, CDOTU-C)
!***KEYWORDS  BLAS, INNER PRODUCT, LINEAR ALGEBRA, VECTOR
!***AUTHOR  Lawson, C. L., (JPL)
!           Hanson, R. J., (SNLA)
!           Kincaid, D. R., (U. of Texas)
!           Krogh, F. T., (JPL)
!***DESCRIPTION
!
!                B L A S  Subprogram
!    Description of Parameters
!
!     --Input--
!        N  number of elements in input vector(s)
!       DX  double precision vector with N elements
!     INCX  storage spacing between elements of DX
!       DY  double precision vector with N elements
!     INCY  storage spacing between elements of DY
!
!     --Output--
!     DDOT  double precision dot product (zero if N  <=  0)
!
!     Returns the dot product of double precision DX and DY.
!     DDOT = sum for I = 0 to N-1 of  DX(LX+I*INCX) * DY(LY+I*INCY),
!     where LX = 1 if INCX  >=  0, else LX = 1+(1-N)*INCX, and LY is
!     defined in a similar way using INCY.
!
!***REFERENCES  C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T.
!                 Krogh, Basic linear algebra subprograms for Fortran
!                 usage, Algorithm No. 539, Transactions on Mathematical
!                 Software 5, 3 (September 1979), pp. 308-323.
!***ROUTINES CALLED  (NONE)
!***REVISION HISTORY  (YYMMDD)
!   791001  DATE WRITTEN
!   890831  Modified array declarations.  (WRB)
!   890831  REVISION DATE from Version 3.2
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!   920310  Corrected definition of LX in DESCRIPTION.  (WRB)
!   920501  Reformatted the REFERENCES section.  (WRB)
!***END PROLOGUE  DDOT
  DOUBLE PRECISION DX(*), DY(*)
!***FIRST EXECUTABLE STATEMENT  DDOT
  DDOT = 0.0D0
  if (N  <=  0) RETURN
  if (INCX  ==  INCY) IF (INCX-1) 5,20,60
!
!     Code for unequal or nonpositive increments.
!
    5 IX = 1
  IY = 1
  if (INCX  <  0) IX = (-N+1)*INCX + 1
  if (INCY  <  0) IY = (-N+1)*INCY + 1
  DO 10 I = 1,N
    DDOT = DDOT + DX(IX)*DY(IY)
    IX = IX + INCX
    IY = IY + INCY
   10 CONTINUE
  return
!
!     Code for both increments equal to 1.
!
!     Clean-up loop so remaining vector length is a multiple of 5.
!
   20 M = MOD(N,5)
  if (M  ==  0) go to 40
  DO 30 I = 1,M
     DDOT = DDOT + DX(I)*DY(I)
   30 CONTINUE
  if (N  <  5) RETURN
   40 MP1 = M + 1
  DO 50 I = MP1,N,5
  DDOT = DDOT + DX(I)*DY(I) + DX(I+1)*DY(I+1) + DX(I+2)*DY(I+2) + &
                DX(I+3)*DY(I+3) + DX(I+4)*DY(I+4)
   50 CONTINUE
  return
!
!     Code for equal, positive, non-unit increments.
!
   60 NS = N*INCX
  DO 70 I = 1,NS,INCX
    DDOT = DDOT + DX(I)*DY(I)
   70 CONTINUE
  return
end function DDOT

DOUBLE PRECISION FUNCTION DASUM (N, DX, INCX)
!
!! DASUM sums the magnitudes of the elements of a vector.
!
!***LIBRARY   SLATEC (BLAS)
!***CATEGORY  D1A3A
!***TYPE      DOUBLE PRECISION (SASUM-S, DASUM-D, SCASUM-C)
!***KEYWORDS  BLAS, LINEAR ALGEBRA, SUM OF MAGNITUDES OF A VECTOR
!***AUTHOR  Lawson, C. L., (JPL)
!           Hanson, R. J., (SNLA)
!           Kincaid, D. R., (U. of Texas)
!           Krogh, F. T., (JPL)
!***DESCRIPTION
!
!                B L A S  Subprogram
!    Description of Parameters
!
!     --Input--
!        N  number of elements in input vector(s)
!       DX  double precision vector with N elements
!     INCX  storage spacing between elements of DX
!
!     --Output--
!    DASUM  double precision result (zero if N  <=  0)
!
!     Returns sum of magnitudes of double precision DX.
!     DASUM = sum from 0 to N-1 of ABS(DX(IX+I*INCX)),
!     where IX = 1 if INCX  >=  0, else IX = 1+(1-N)*INCX.
!
!***REFERENCES  C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T.
!                 Krogh, Basic linear algebra subprograms for Fortran
!                 usage, Algorithm No. 539, Transactions on Mathematical
!                 Software 5, 3 (September 1979), pp. 308-323.
!***ROUTINES CALLED  (NONE)
!***REVISION HISTORY  (YYMMDD)
!   791001  DATE WRITTEN
!   890531  Changed all specific intrinsics to generic.  (WRB)
!   890831  Modified array declarations.  (WRB)
!   890831  REVISION DATE from Version 3.2
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!   900821  Modified to correct problem with a negative increment.
!           (WRB)
!   920501  Reformatted the REFERENCES section.  (WRB)
!***END PROLOGUE  DASUM
  DOUBLE PRECISION DX(*)
  INTEGER I, INCX, IX, M, MP1, N
!***FIRST EXECUTABLE STATEMENT  DASUM
  DASUM = 0.0D0
  if (N  <=  0) RETURN
!
  if (INCX  ==  1) GOTO 20
!
!     Code for increment not equal to 1.
!
  IX = 1
  if (INCX  <  0) IX = (-N+1)*INCX + 1
  DO 10 I = 1,N
    DASUM = DASUM + ABS(DX(IX))
    IX = IX + INCX
   10 CONTINUE
  return
!
!     Code for increment equal to 1.
!
!     Clean-up loop so remaining vector length is a multiple of 6.
!
   20 M = MOD(N,6)
  if (M  ==  0) GOTO 40
  DO 30 I = 1,M
    DASUM = DASUM + ABS(DX(I))
   30 CONTINUE
  if (N  <  6) RETURN
   40 MP1 = M + 1
  DO 50 I = MP1,N,6
    DASUM = DASUM + ABS(DX(I)) + ABS(DX(I+1)) + ABS(DX(I+2)) + &
            ABS(DX(I+3)) + ABS(DX(I+4)) + ABS(DX(I+5))
   50 CONTINUE
  return
end function DASUM

subroutine DGESL (A, LDA, N, IPVT, B, JOB)
!
!! DGESL solves the real system A*X=B or TRANS(A)*X=B using the ...
!            factors computed by DGECO or DGEFA.
!
!***LIBRARY   SLATEC (LINPACK)
!***CATEGORY  D2A1
!***TYPE      DOUBLE PRECISION (SGESL-S, DGESL-D, CGESL-C)
!***KEYWORDS  LINEAR ALGEBRA, LINPACK, MATRIX, SOLVE
!***AUTHOR  Moler, C. B., (U. of New Mexico)
!***DESCRIPTION
!
!     DGESL solves the double precision system
!     A * X = B  or  TRANS(A) * X = B
!     using the factors computed by DGECO or DGEFA.
!
!     On Entry
!
!        A       DOUBLE PRECISION(LDA, N)
!                the output from DGECO or DGEFA.
!
!        LDA     INTEGER
!                the leading dimension of the array  A .
!
!        N       INTEGER
!                the order of the matrix  A .
!
!        IPVT    INTEGER(N)
!                the pivot vector from DGECO or DGEFA.
!
!        B       DOUBLE PRECISION(N)
!                the right hand side vector.
!
!        JOB     INTEGER
!                = 0         to solve  A*X = B ,
!                = nonzero   to solve  TRANS(A)*X = B  where
!                            TRANS(A)  is the transpose.
!
!     On Return
!
!        B       the solution vector  X .
!
!     Error Condition
!
!        A division by zero will occur if the input factor contains a
!        zero on the diagonal.  Technically this indicates singularity
!        but it is often caused by improper arguments or improper
!        setting of LDA .  It will not occur if the subroutines are
!        called correctly and if DGECO has set RCOND  >  0.0
!        or DGEFA has set INFO  ==  0 .
!
!     To compute  INVERSE(A) * C  where  C  is a matrix
!     with  P  columns
!           call DGECO(A,LDA,N,IPVT,RCOND,Z)
!           if (RCOND is too small) go to ...
!           DO 10 J = 1, P
!              call DGESL(A,LDA,N,IPVT,C(1,J),0)
!        10 CONTINUE
!
!***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
!                 Stewart, LINPACK Users' Guide, SIAM, 1979.
!***ROUTINES CALLED  DAXPY, DDOT
!***REVISION HISTORY  (YYMMDD)
!   780814  DATE WRITTEN
!   890831  Modified array declarations.  (WRB)
!   890831  REVISION DATE from Version 3.2
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!   900326  Removed duplicate information from DESCRIPTION section.
!           (WRB)
!   920501  Reformatted the REFERENCES section.  (WRB)
!***END PROLOGUE  DGESL
  INTEGER LDA,N,IPVT(*),JOB
  DOUBLE PRECISION A(LDA,*),B(*)
!
! DOUBLE PRECISION DDOT,T
  DOUBLE PRECISION T
  INTEGER K,KB,L,NM1
!***FIRST EXECUTABLE STATEMENT  DGESL
  NM1 = N - 1
  if (JOB  /=  0) go to 50
!
!        JOB = 0 , SOLVE  A * X = B
!        FIRST SOLVE  L*Y = B
!
     if (NM1  <  1) go to 30
     DO 20 K = 1, NM1
        L = IPVT(K)
        T = B(L)
        if (L  ==  K) go to 10
           B(L) = B(K)
           B(K) = T
   10       CONTINUE
        call DAXPY(N-K,T,A(K+1,K),1,B(K+1),1)
   20    CONTINUE
   30    CONTINUE
!
!        NOW SOLVE  U*X = Y
!
     DO 40 KB = 1, N
        K = N + 1 - KB
        B(K) = B(K)/A(K,K)
        T = -B(K)
        call DAXPY(K-1,T,A(1,K),1,B(1),1)
   40    CONTINUE
  go to 100
   50 CONTINUE
!
!        JOB = NONZERO, SOLVE  TRANS(A) * X = B
!        FIRST SOLVE  TRANS(U)*Y = B
!
     DO 60 K = 1, N
        T = DDOT(K-1,A(1,K),1,B(1),1)
        B(K) = (B(K) - T)/A(K,K)
   60    CONTINUE
!
!        NOW SOLVE TRANS(L)*X = Y
!
     if (NM1  <  1) go to 90
     DO 80 KB = 1, NM1
        K = N - KB
        B(K) = B(K) + DDOT(N-K,A(K+1,K),1,B(K+1),1)
        L = IPVT(K)
        if (L  ==  K) go to 70
           T = B(L)
           B(L) = B(K)
           B(K) = T
   70       CONTINUE
   80    CONTINUE
   90    CONTINUE
  100 CONTINUE
  return
end subroutine DGESL

END MODULE MATHSUBS