!!# USER MODULE: <USR_smatCSR>
MODULE USR_smatCSR

!!## PURPOSE
!! This module is part of SMLIB v. 1.1.  It contains the data-structure
!! and procedures for manipulating the CSR (compressed sparse row)
!! sparse matrix format.

!!## SOURCE
!!  Copyright (C) 1996 Ernst A. Meese
!!    Refer to the file copyright.doc for details and important disclaimer.
!
!! Created: 30.1.96 by Ernst A. Meese
!! Version 1.0b, validated by TESTS/CSR/tester 1.2.96
!! Version 1.0.1b, validated by TESTS/CSR/tester 3.9.97

!!## MODIFICATIONS
!! William Wieselquist - added overloading for two real types (single and double
!!                       precision as defined in module KND and reformatted.

!!## EXTERNAL KINDS
!! @ get the two kinds to use in this module
USE KND_IntrinsicTypes,ONLY: KIND_Rsp,KIND_Rdp,KIND_Csp,KIND_Cdp !!((01-A-KND_IntrinsicTypes.f90))

!!## EXTERNAL PARAMETERS
!! @ lengths of type-kinds
USE PAR_IntrinsicLengths,ONLY: LEN_Rsp,LEN_Rdp,LEN_Csp,LEN_Cdp   !!((02-A-PAR_IntrinsicLengths.f90))

!!## EXTERNAL PROCEDURES
USE FUN_NewUnit                                                  !!((04-B-FUN_NewUnit.f90))

!!## DEFAULT IMPLICIT
IMPLICIT NONE

!!## DEFAULT ACCESS
PRIVATE

!!## PARAMETERS
INTEGER,PARAMETER :: Block_Size = 50

!!## TYPE DEFINITIONS
!! @ single precision real
TYPE TYPE_smatCSR_Rsp
 INTEGER                :: N     =  0
 REAL(KIND_Rsp),POINTER :: A(:)  => NULL()
 INTEGER       ,POINTER :: IA(:) => NULL()
 INTEGER       ,POINTER :: JA(:) => NULL()
END TYPE
!! @ double precision real
TYPE TYPE_smatCSR_Rdp
 INTEGER                :: N     =  0
 REAL(KIND_Rdp),POINTER :: A(:)  => NULL()
 INTEGER       ,POINTER :: IA(:) => NULL()
 INTEGER       ,POINTER :: JA(:) => NULL()
END TYPE
!! @ single precision complex
TYPE TYPE_smatCSR_Csp
 INTEGER                  :: N     =  0
 COMPLEX(KIND_Csp),POINTER :: A(:)  => NULL()
 INTEGER         ,POINTER :: IA(:) => NULL()
 INTEGER         ,POINTER :: JA(:) => NULL()
END TYPE
!! @ double precision complex
TYPE TYPE_smatCSR_Cdp
 INTEGER                  :: N     =  0
 COMPLEX(KIND_Cdp),POINTER :: A(:)  => NULL()
 INTEGER         ,POINTER :: IA(:) => NULL()
 INTEGER         ,POINTER :: JA(:) => NULL()
END TYPE

!!## PROCEDURE OVERLOADING
!! @ allocation
INTERFACE ALLOCATE
 MODULE PROCEDURE ALLOCATE_smatCSR_Rsp
 MODULE PROCEDURE ALLOCATE_smatCSR_Rdp
 MODULE PROCEDURE ALLOCATE_smatCSR_Csp
 MODULE PROCEDURE ALLOCATE_smatCSR_Cdp
END INTERFACE
!! @ reallocation (involves memory copy)
INTERFACE REALLOCATE
 MODULE PROCEDURE REALLOCATE_smatCSR_Rsp
 MODULE PROCEDURE REALLOCATE_smatCSR_Rdp
 MODULE PROCEDURE REALLOCATE_smatCSR_Csp
 MODULE PROCEDURE REALLOCATE_smatCSR_Cdp
END INTERFACE
!! @ deallocation
INTERFACE DEALLOCATE
 MODULE PROCEDURE DEALLOCATE_smatCSR_Rsp
 MODULE PROCEDURE DEALLOCATE_smatCSR_Rdp
 MODULE PROCEDURE DEALLOCATE_smatCSR_Csp
 MODULE PROCEDURE DEALLOCATE_smatCSR_Cdp
END INTERFACE
!! @ nullify
INTERFACE NULLIFY
 MODULE PROCEDURE NULLIFY_smatCSR_Rsp
 MODULE PROCEDURE NULLIFY_smatCSR_Rdp
 MODULE PROCEDURE NULLIFY_smatCSR_Csp
 MODULE PROCEDURE NULLIFY_smatCSR_Cdp
END INTERFACE
!! @ allocated inquiry function
INTERFACE ALLOCATED
 MODULE PROCEDURE ALLOCATED_smatCSR_Rsp
 MODULE PROCEDURE ALLOCATED_smatCSR_Rdp
 MODULE PROCEDURE ALLOCATED_smatCSR_Csp
 MODULE PROCEDURE ALLOCATED_smatCSR_Cdp
END INTERFACE
!! @ entry retrieval
INTERFACE ENTRY
 MODULE PROCEDURE Entry_smatCSR_Rsp
 MODULE PROCEDURE Entry_smatCSR_Rdp
 MODULE PROCEDURE Entry_smatCSR_Csp
 MODULE PROCEDURE Entry_smatCSR_Cdp
END INTERFACE
!! @ set row
INTERFACE SetRow
 MODULE PROCEDURE SetRow_smatCSR_Rsp
 MODULE PROCEDURE SetRow_smatCSR_Rdp
 MODULE PROCEDURE SetRow_smatCSR_Csp
 MODULE PROCEDURE SetRow_smatCSR_Cdp
END INTERFACE
!! @ is lower triangular inquiry
INTERFACE IsLower
 MODULE PROCEDURE IsLower_smatCSR_Rsp
 MODULE PROCEDURE IsLower_smatCSR_Rdp
 MODULE PROCEDURE IsLower_smatCSR_Csp
 MODULE PROCEDURE IsLower_smatCSR_Cdp
END INTERFACE
!! @ is upper triangular inquiry
INTERFACE IsUpper
 MODULE PROCEDURE IsUpper_smatCSR_Rsp
 MODULE PROCEDURE IsUpper_smatCSR_Rdp
 MODULE PROCEDURE IsUpper_smatCSR_Csp
 MODULE PROCEDURE IsUpper_smatCSR_Cdp
END INTERFACE
!! @ check for structure correctness
INTERFACE IsOK
 MODULE PROCEDURE IsOK_smatCSR_Rsp
 MODULE PROCEDURE IsOK_smatCSR_Rdp
 MODULE PROCEDURE IsOK_smatCSR_Csp
 MODULE PROCEDURE IsOK_smatCSR_Cdp
END INTERFACE
!! @ set a value
INTERFACE SetVal
 MODULE PROCEDURE SetVal_smatCSR_Rsp
 MODULE PROCEDURE SetVal_smatCSR_Rdp
 MODULE PROCEDURE SetVal_smatCSR_Csp
 MODULE PROCEDURE SetVal_smatCSR_Cdp
END INTERFACE
!! @ add a value
INTERFACE AddVal
 MODULE PROCEDURE AddVal_smatCSR_Rsp
 MODULE PROCEDURE AddVal_smatCSR_Rdp
 MODULE PROCEDURE AddVal_smatCSR_Csp
 MODULE PROCEDURE AddVal_smatCSR_Cdp
END INTERFACE
!! @ sum of a row
INTERFACE RowSum
 MODULE PROCEDURE RowSum_smatCSR_Rsp
 MODULE PROCEDURE RowSum_smatCSR_Rdp
 MODULE PROCEDURE RowSum_smatCSR_Csp
 MODULE PROCEDURE RowSum_smatCSR_Cdp
END INTERFACE
!! @ save
INTERFACE SAVE
 MODULE PROCEDURE SAVE_smatCSR_Rsp
 MODULE PROCEDURE SAVE_smatCSR_Rdp
 MODULE PROCEDURE SAVE_smatCSR_Csp
 MODULE PROCEDURE SAVE_smatCSR_Cdp
END INTERFACE
!! @ number of nonzeros on a row
INTERFACE RowNNZ
 MODULE PROCEDURE RowNNZ_smatCSR_Rsp
 MODULE PROCEDURE RowNNZ_smatCSR_Rdp
 MODULE PROCEDURE RowNNZ_smatCSR_Csp
 MODULE PROCEDURE RowNNZ_smatCSR_Cdp
END INTERFACE
!! @ kind inquiry
INTERFACE KIND
 MODULE PROCEDURE KIND_smatCSR_Rsp
 MODULE PROCEDURE KIND_smatCSR_Rdp
 MODULE PROCEDURE KIND_smatCSR_Csp
 MODULE PROCEDURE KIND_smatCSR_Cdp
END INTERFACE
!! @ absolute value
INTERFACE ABS
 MODULE PROCEDURE ABS_smatCSR_Rsp
 MODULE PROCEDURE ABS_smatCSR_Rdp
 MODULE PROCEDURE ABS_smatCSR_Csp
 MODULE PROCEDURE ABS_smatCSR_Cdp
END INTERFACE
!! @ matrix multiplication function
INTERFACE MATMUL
 MODULE PROCEDURE MATMUL_smatCSR_dvec_Rsp
 MODULE PROCEDURE MATMUL_smatCSR_dvec_Rdp
 MODULE PROCEDURE MATMUL_smatCSR_dvec_Csp
 MODULE PROCEDURE MATMUL_smatCSR_dvec_Cdp
 MODULE PROCEDURE MATMUL_smatCSR_smatCSR_Rsp
 MODULE PROCEDURE MATMUL_smatCSR_smatCSR_Rdp
 MODULE PROCEDURE MATMUL_smatCSR_smatCSR_Csp
 MODULE PROCEDURE MATMUL_smatCSR_smatCSR_Cdp
END INTERFACE
!! @ matrix addition
INTERFACE ADD
 MODULE PROCEDURE ADD_smatCSR_smatCSR_Rsp
 MODULE PROCEDURE ADD_smatCSR_smatCSR_Rdp
 MODULE PROCEDURE ADD_smatCSR_smatCSR_Csp
 MODULE PROCEDURE ADD_smatCSR_smatCSR_Cdp
END INTERFACE
!! @ copy one matrix into another (first=second)
INTERFACE COPY
 MODULE PROCEDURE COPY_smatCSR_Rsp
 MODULE PROCEDURE COPY_smatCSR_Rdp
 MODULE PROCEDURE COPY_smatCSR_Csp
 MODULE PROCEDURE COPY_smatCSR_Cdp
END INTERFACE
!! @ identity matrix
INTERFACE Eye
 MODULE PROCEDURE Eye_smatCSR_Rsp
 MODULE PROCEDURE Eye_smatCSR_Rdp
 MODULE PROCEDURE Eye_smatCSR_Csp
 MODULE PROCEDURE Eye_smatCSR_Cdp
END INTERFACE

!!## OPERATOR DEFINITION
!! @ matrix multiplication operator
INTERFACE OPERATOR(*)
 MODULE PROCEDURE MUL_smatCSR_scalar_Rsp
 MODULE PROCEDURE MUL_smatCSR_scalar_Rdp
 MODULE PROCEDURE MUL_smatCSR_scalar_Csp
 MODULE PROCEDURE MUL_smatCSR_scalar_Cdp
 MODULE PROCEDURE MATMUL_smatCSR_dvec_Rsp
 MODULE PROCEDURE MATMUL_smatCSR_dvec_Rdp
 MODULE PROCEDURE MATMUL_smatCSR_dvec_Csp
 MODULE PROCEDURE MATMUL_smatCSR_dvec_Cdp
 MODULE PROCEDURE MATMUL_smatCSR_smatCSR_Rsp
 MODULE PROCEDURE MATMUL_smatCSR_smatCSR_Rdp
 MODULE PROCEDURE MATMUL_smatCSR_smatCSR_Csp
 MODULE PROCEDURE MATMUL_smatCSR_smatCSR_Cdp
END INTERFACE
!! @ dense matrix = CSR matrix
INTERFACE ASSIGNMENT(=)
 MODULE PROCEDURE EQUALS_dmat_smatCSR_Rsp
 MODULE PROCEDURE EQUALS_dmat_smatCSR_Rdp
 MODULE PROCEDURE EQUALS_dmat_smatCSR_Csp
 MODULE PROCEDURE EQUALS_dmat_smatCSR_Cdp
END INTERFACE
!! @ CSR matrix = dense matrix
INTERFACE ASSIGNMENT(=)
 MODULE PROCEDURE EQUALS_smatCSR_dmat_Rsp
 MODULE PROCEDURE EQUALS_smatCSR_dmat_Rdp
 MODULE PROCEDURE EQUALS_smatCSR_dmat_Csp
 MODULE PROCEDURE EQUALS_smatCSR_dmat_Cdp
END INTERFACE
!! @ CSR matrix = CSR matrix
INTERFACE ASSIGNMENT(=)
 MODULE PROCEDURE COPY_smatCSR_Rsp
 MODULE PROCEDURE COPY_smatCSR_Rdp
 MODULE PROCEDURE COPY_smatCSR_Csp
 MODULE PROCEDURE COPY_smatCSR_Cdp
END INTERFACE
!! @ matrix addition
INTERFACE OPERATOR(+)
 MODULE PROCEDURE ADD_smatCSR_smatCSR_Rsp
 MODULE PROCEDURE ADD_smatCSR_smatCSR_Rdp
 MODULE PROCEDURE ADD_smatCSR_smatCSR_Csp
 MODULE PROCEDURE ADD_smatCSR_smatCSR_Cdp
END INTERFACE

!!## PUBLIC ACCESS LIST
PUBLIC :: TYPE_smatCSR_Rsp
PUBLIC :: TYPE_smatCSR_Rdp
PUBLIC :: TYPE_smatCSR_Csp
PUBLIC :: TYPE_smatCSR_Cdp
PUBLIC :: OPERATOR(*),OPERATOR(+)
PUBLIC :: ASSIGNMENT(=)
PUBLIC :: ALLOCATE
PUBLIC :: REALLOCATE
PUBLIC :: DEALLOCATE
PUBLIC :: NULLIFY
PUBLIC :: ALLOCATED
PUBLIC :: entry
PUBLIC :: SetRow
PUBLIC :: IsLower
PUBLIC :: IsUpper
PUBLIC :: IsOK
PUBLIC :: SetVal
PUBLIC :: AddVal
PUBLIC :: RowSum
PUBLIC :: SAVE
PUBLIC :: RowNNZ
PUBLIC :: KIND
PUBLIC :: ABS
PUBLIC :: MATMUL
PUBLIC :: COPY
PUBLIC :: ADD
PUBLIC :: Eye

!!## MODULE PROCEDURES
CONTAINS

SUBROUTINE NULLIFY_smatCSR_Rsp (A)
!!#### REQUIRED INPUT/OUTPUT
TYPE(TYPE_smatCSR_Rsp),INTENT(INOUT) :: A
!!--begin--
INCLUDE "06-A-USR_smatCSR__NULLIFY.f90.bdy"
!!--end--
END SUBROUTINE

SUBROUTINE NULLIFY_smatCSR_Rdp (A)
!!#### REQUIRED INPUT/OUTPUT
TYPE(TYPE_smatCSR_Rdp),INTENT(INOUT) :: A
!!--begin--
INCLUDE "06-A-USR_smatCSR__NULLIFY.f90.bdy"
!!--end--
END SUBROUTINE

SUBROUTINE NULLIFY_smatCSR_Csp (A)
!!#### REQUIRED INPUT/OUTPUT
TYPE(TYPE_smatCSR_Csp),INTENT(INOUT) :: A
!!--begin--
INCLUDE "06-A-USR_smatCSR__NULLIFY.f90.bdy"
!!--end--
END SUBROUTINE

SUBROUTINE NULLIFY_smatCSR_Cdp (A)
!!#### REQUIRED INPUT/OUTPUT
TYPE(TYPE_smatCSR_Cdp),INTENT(INOUT) :: A
!!--begin--
INCLUDE "06-A-USR_smatCSR__NULLIFY.f90.bdy"
!!--end--
END SUBROUTINE

PURE FUNCTION KIND_smatCSR_Rsp( A ) RESULT(KIND)
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Rsp),INTENT(IN) :: A
!!#### REQUIRED OUTPUT
INTEGER :: KIND
!!--begin--
KIND = KIND_Rsp
!!--end--
END FUNCTION

PURE FUNCTION KIND_smatCSR_Rdp( A ) RESULT(KIND)
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Rdp),INTENT(IN) :: A
!!#### REQUIRED OUTPUT
INTEGER :: KIND
!!--begin--
KIND = KIND_Rdp
!!--end--
END FUNCTION

PURE FUNCTION KIND_smatCSR_Csp( A ) RESULT(KIND)
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Csp),INTENT(IN) :: A
!!#### REQUIRED OUTPUT
INTEGER :: KIND
!!--begin--
KIND = KIND_Csp
!!--end--
END FUNCTION

PURE FUNCTION KIND_smatCSR_Cdp( A ) RESULT(KIND)
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Cdp),INTENT(IN) :: A
!!#### REQUIRED OUTPUT
INTEGER :: KIND
!!--begin--
KIND = KIND_Cdp
!!--end--
END FUNCTION

PURE FUNCTION ABS_smatCSR_Rsp( A ) RESULT(B)
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Rsp),INTENT(IN) :: A
!!#### REQUIRED OUTPUT
TYPE(TYPE_smatCSR_Rsp) :: B
!!--begin--
INCLUDE "06-A-USR_smatCSR__ABS.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION ABS_smatCSR_Rdp( A ) RESULT(B)
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Rdp),INTENT(IN) :: A
!!#### REQUIRED OUTPUT
TYPE(TYPE_smatCSR_Rdp) :: B
!!--begin--
INCLUDE "06-A-USR_smatCSR__ABS.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION ABS_smatCSR_Csp( A ) RESULT(B)
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Csp),INTENT(IN) :: A
!!#### REQUIRED OUTPUT
TYPE(TYPE_smatCSR_Csp) :: B
!!--begin--
INCLUDE "06-A-USR_smatCSR__ABS.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION ABS_smatCSR_Cdp( A ) RESULT(B)
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Cdp),INTENT(IN) :: A
!!#### REQUIRED OUTPUT
TYPE(TYPE_smatCSR_Cdp) :: B
!!--begin--
INCLUDE "06-A-USR_smatCSR__ABS.f90.bdy"
!!--end--
END FUNCTION

PURE SUBROUTINE ALLOCATE_smatCSR_Rsp (A, N, NZMAX, InitDiag_scalar , InitDiag_dvec )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT/OUTPUT
TYPE (TYPE_smatCSR_Rsp),INTENT(INOUT) :: A
INCLUDE "06-A-USR_smatCSR__ALLOCATE_R.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__ALLOCATE.f90.bdy"
!!--end--
END SUBROUTINE

PURE SUBROUTINE ALLOCATE_smatCSR_Rdp (A, N, NZMAX, InitDiag_scalar , InitDiag_dvec )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT/OUTPUT
TYPE (TYPE_smatCSR_Rdp),INTENT(INOUT) :: A
INCLUDE "06-A-USR_smatCSR__ALLOCATE_R.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__ALLOCATE.f90.bdy"
!!--end--
END SUBROUTINE

PURE SUBROUTINE ALLOCATE_smatCSR_Csp (A, N, NZMAX, InitDiag_scalar , InitDiag_dvec )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_C=>KIND_Csp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT/OUTPUT
TYPE (TYPE_smatCSR_Csp),INTENT(INOUT) :: A
INCLUDE "06-A-USR_smatCSR__ALLOCATE_C.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__ALLOCATE.f90.bdy"
!!--end--
END SUBROUTINE

PURE SUBROUTINE ALLOCATE_smatCSR_Cdp (A, N, NZMAX , InitDiag_scalar , InitDiag_dvec )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_C=>KIND_Cdp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT/OUTPUT
TYPE (TYPE_smatCSR_Cdp),INTENT(INOUT) :: A
INCLUDE "06-A-USR_smatCSR__ALLOCATE_C.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__ALLOCATE.f90.bdy"
!!--end--
END SUBROUTINE

PURE SUBROUTINE REALLOCATE_smatCSR_Rsp (S, DELTA)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT/OUTPUT
TYPE(TYPE_smatCSR_Rsp),INTENT(INOUT) :: S
INCLUDE "06-A-USR_smatCSR__REALLOCATE_R.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__REALLOCATE.f90.bdy"
!!--end--
END SUBROUTINE

PURE SUBROUTINE REALLOCATE_smatCSR_Rdp (S, DELTA)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT/OUTPUT
TYPE(TYPE_smatCSR_Rdp),INTENT(INOUT) :: S
INCLUDE "06-A-USR_smatCSR__REALLOCATE_R.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__REALLOCATE.f90.bdy"
!!--end--
END SUBROUTINE

PURE SUBROUTINE REALLOCATE_smatCSR_Csp (S, DELTA)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_C=>KIND_Csp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT/OUTPUT
TYPE(TYPE_smatCSR_Csp),INTENT(INOUT) :: S
INCLUDE "06-A-USR_smatCSR__REALLOCATE_C.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__REALLOCATE.f90.bdy"
!!--end--
END SUBROUTINE

PURE SUBROUTINE REALLOCATE_smatCSR_Cdp (S, DELTA)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_C=>KIND_Cdp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT/OUTPUT
TYPE(TYPE_smatCSR_Cdp),INTENT(INOUT) :: S
INCLUDE "06-A-USR_smatCSR__REALLOCATE_C.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__REALLOCATE.f90.bdy"
!!--end--
END SUBROUTINE

PURE SUBROUTINE DEALLOCATE_smatCSR_Rsp (A)
!!#### REQUIRED INPUT/OUTPUT
TYPE (TYPE_smatCSR_Rsp),INTENT(INOUT) :: A
!!--begin--
INCLUDE "06-A-USR_smatCSR__DEALLOCATE.f90.bdy"
!!--end--
END SUBROUTINE

PURE SUBROUTINE DEALLOCATE_smatCSR_Rdp (A)
!!#### REQUIRED INPUT/OUTPUT
TYPE (TYPE_smatCSR_Rdp),INTENT(INOUT) :: A
!!--begin--
INCLUDE "06-A-USR_smatCSR__DEALLOCATE.f90.bdy"
!!--end--
END SUBROUTINE

PURE SUBROUTINE DEALLOCATE_smatCSR_Csp (A)
!!#### REQUIRED INPUT/OUTPUT
TYPE (TYPE_smatCSR_Csp),INTENT(INOUT) :: A
!!--begin--
INCLUDE "06-A-USR_smatCSR__DEALLOCATE.f90.bdy"
!!--end--
END SUBROUTINE

PURE SUBROUTINE DEALLOCATE_smatCSR_Cdp (A)
!!#### REQUIRED INPUT/OUTPUT
TYPE (TYPE_smatCSR_Cdp),INTENT(INOUT) :: A
!!--begin--
INCLUDE "06-A-USR_smatCSR__DEALLOCATE.f90.bdy"
!!--end--
END SUBROUTINE

PURE FUNCTION ALLOCATED_smatCSR_Rsp( A ) RESULT(ALLOCATED)
!!#### REQUIRED INPUT
TYPE (TYPE_smatCSR_Rsp),INTENT(IN) :: A
INCLUDE "06-A-USR_smatCSR__ALLOCATED.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__ALLOCATED.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION ALLOCATED_smatCSR_Rdp( A ) RESULT(ALLOCATED)
!!#### REQUIRED INPUT
TYPE (TYPE_smatCSR_Rdp),INTENT(IN) :: A
INCLUDE "06-A-USR_smatCSR__ALLOCATED.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__ALLOCATED.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION ALLOCATED_smatCSR_Csp( A ) RESULT(ALLOCATED)
!!#### REQUIRED INPUT
TYPE (TYPE_smatCSR_Csp),INTENT(IN) :: A
INCLUDE "06-A-USR_smatCSR__ALLOCATED.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__ALLOCATED.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION ALLOCATED_smatCSR_Cdp( A ) RESULT(ALLOCATED)
!!#### REQUIRED INPUT
TYPE (TYPE_smatCSR_Cdp),INTENT(IN) :: A
INCLUDE "06-A-USR_smatCSR__ALLOCATED.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__ALLOCATED.f90.bdy"
!!--end--
END FUNCTION

FUNCTION ENTRY_smatCSR_Rsp ( A , i , j ) RESULT(Entry)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Rsp),INTENT(IN) :: A
INCLUDE "06-A-USR_smatCSR__ENTRY_R.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__ENTRY.f90.bdy"
!!--end--
END FUNCTION

FUNCTION ENTRY_smatCSR_Rdp ( A , i , j ) RESULT(Entry)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Rdp),INTENT(IN) :: A
INCLUDE "06-A-USR_smatCSR__ENTRY_R.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__ENTRY.f90.bdy"
!!--end--
END FUNCTION

FUNCTION ENTRY_smatCSR_Csp ( A , i , j ) RESULT(Entry)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_C=>KIND_Csp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Csp),INTENT(IN) :: A
INCLUDE "06-A-USR_smatCSR__ENTRY_C.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__ENTRY.f90.bdy"
!!--end--
END FUNCTION

FUNCTION ENTRY_smatCSR_Cdp ( A , i , j ) RESULT(Entry)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_C=>KIND_Cdp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Cdp),INTENT(IN) :: A
INCLUDE "06-A-USR_smatCSR__ENTRY_C.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__ENTRY.f90.bdy"
!!--end--
END FUNCTION

PURE SUBROUTINE SetRow_smatCSR_Rsp( A , i , cols , vals )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT/OUTPUT
TYPE (TYPE_smatCSR_Rsp),INTENT(INOUT) :: A
INCLUDE "06-A-USR_smatCSR__SetRow_R.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__SetRow.f90.bdy"
!!--end--
END SUBROUTINE

PURE SUBROUTINE SetRow_smatCSR_Rdp( A , i , cols , vals )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT/OUTPUT
TYPE (TYPE_smatCSR_Rdp),INTENT(INOUT) :: A
INCLUDE "06-A-USR_smatCSR__SetRow_R.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__SetRow.f90.bdy"
!!--end--
END SUBROUTINE

PURE SUBROUTINE SetRow_smatCSR_Csp( A , i , cols , vals )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_C=>KIND_Csp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT/OUTPUT
TYPE (TYPE_smatCSR_Csp),INTENT(INOUT) :: A
INCLUDE "06-A-USR_smatCSR__SetRow_C.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__SetRow.f90.bdy"
!!--end--
END SUBROUTINE

PURE SUBROUTINE SetRow_smatCSR_Cdp( A , i , cols , vals )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_C=>KIND_Cdp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT/OUTPUT
TYPE (TYPE_smatCSR_Cdp),INTENT(INOUT) :: A
INCLUDE "06-A-USR_smatCSR__SetRow_C.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__SetRow.f90.bdy"
!!--end--
END SUBROUTINE

PURE FUNCTION MATMUL_smatCSR_dvec_Rsp( A , x ) RESULT(y)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Rsp),INTENT(IN) :: A
INCLUDE "06-A-USR_smatCSR__MATMUL_dvec_R.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__MATMUL_dvec.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION MATMUL_smatCSR_dvec_Rdp( A , x ) RESULT(y)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Rdp),INTENT(IN) :: A
INCLUDE "06-A-USR_smatCSR__MATMUL_dvec_R.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__MATMUL_dvec.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION MATMUL_smatCSR_dvec_Csp( A , x ) RESULT(y)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_C=>KIND_Csp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Csp),INTENT(IN) :: A
INCLUDE "06-A-USR_smatCSR__MATMUL_dvec_C.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__MATMUL_dvec.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION MATMUL_smatCSR_dvec_Cdp( A , x ) RESULT(y)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_C=>KIND_Cdp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Cdp),INTENT(IN) :: A
INCLUDE "06-A-USR_smatCSR__MATMUL_dvec_C.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__MATMUL_dvec.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION MUL_smatCSR_scalar_Rsp( A , x ) RESULT(B)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Rsp),INTENT(IN) :: A
!!#### REQUIRED OUTPUT
TYPE(TYPE_smatCSR_Rsp) :: B
INCLUDE "06-A-USR_smatCSR__MUL_scalar_R.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__MUL_scalar.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION MUL_smatCSR_scalar_Rdp( A , x ) RESULT(B)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Rdp),INTENT(IN) :: A
!!#### REQUIRED OUTPUT
TYPE(TYPE_smatCSR_Rdp) :: B
INCLUDE "06-A-USR_smatCSR__MUL_scalar_R.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__MUL_scalar.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION MUL_smatCSR_scalar_Csp( A , x ) RESULT(B)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_C=>KIND_Csp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Csp),INTENT(IN) :: A
!!#### REQUIRED OUTPUT
TYPE(TYPE_smatCSR_Csp) :: B
INCLUDE "06-A-USR_smatCSR__MUL_scalar_C.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__MUL_scalar.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION MUL_smatCSR_scalar_Cdp( A , x ) RESULT(B)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_C=>KIND_Cdp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Cdp),INTENT(IN) :: A
!!#### REQUIRED OUTPUT
TYPE(TYPE_smatCSR_Cdp) :: B
INCLUDE "06-A-USR_smatCSR__MUL_scalar_C.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__MUL_scalar.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION MATMUL_smatCSR_smatCSR_Rsp( A , B ) RESULT(C)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Rsp),INTENT(IN) :: A
TYPE(TYPE_smatCSR_Rsp),INTENT(IN) :: B
!!#### REQUIRED OUTPUT
TYPE(TYPE_smatCSR_Rsp) :: C
INCLUDE "06-A-USR_smatCSR__MATMUL_smatCSR_R.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__MATMUL_smatCSR.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION MATMUL_smatCSR_smatCSR_Rdp( A , B ) RESULT(C)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Rdp),INTENT(IN) :: A
TYPE(TYPE_smatCSR_Rdp),INTENT(IN) :: B
!!#### REQUIRED OUTPUT
TYPE(TYPE_smatCSR_Rdp) :: C
INCLUDE "06-A-USR_smatCSR__MATMUL_smatCSR_R.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__MATMUL_smatCSR.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION MATMUL_smatCSR_smatCSR_Csp( A , B ) RESULT(C)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_C=>KIND_Csp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Csp),INTENT(IN) :: A
TYPE(TYPE_smatCSR_Csp),INTENT(IN) :: B
!!#### REQUIRED OUTPUT
TYPE(TYPE_smatCSR_Csp) :: C
INCLUDE "06-A-USR_smatCSR__MATMUL_smatCSR_C.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__MATMUL_smatCSR.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION MATMUL_smatCSR_smatCSR_Cdp( A , B ) RESULT(C)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_C=>KIND_Cdp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Cdp),INTENT(IN) :: A
TYPE(TYPE_smatCSR_Cdp),INTENT(IN) :: B
!!#### REQUIRED OUTPUT
TYPE(TYPE_smatCSR_Cdp) :: C
INCLUDE "06-A-USR_smatCSR__MATMUL_smatCSR_C.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__MATMUL_smatCSR.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION ADD_smatCSR_smatCSR_Rsp( A , B ) RESULT(C)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Rsp),INTENT(IN) :: A
TYPE(TYPE_smatCSR_Rsp),INTENT(IN) :: B
!!#### REQUIRED OUTPUT
TYPE(TYPE_smatCSR_Rsp) :: C
INCLUDE "06-A-USR_smatCSR__ADD_smatCSR_R.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__ADD_smatCSR.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION ADD_smatCSR_smatCSR_Rdp( A , B ) RESULT(C)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Rdp),INTENT(IN) :: A
TYPE(TYPE_smatCSR_Rdp),INTENT(IN) :: B
!!#### REQUIRED OUTPUT
TYPE(TYPE_smatCSR_Rdp) :: C
INCLUDE "06-A-USR_smatCSR__ADD_smatCSR_R.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__ADD_smatCSR.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION ADD_smatCSR_smatCSR_Csp( A , B ) RESULT(C)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_C=>KIND_Csp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Csp),INTENT(IN) :: A
TYPE(TYPE_smatCSR_Csp),INTENT(IN) :: B
!!#### REQUIRED OUTPUT
TYPE(TYPE_smatCSR_Csp) :: C
INCLUDE "06-A-USR_smatCSR__ADD_smatCSR_C.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__ADD_smatCSR.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION ADD_smatCSR_smatCSR_Cdp( A , B ) RESULT(C)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_C=>KIND_Cdp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Cdp),INTENT(IN) :: A
TYPE(TYPE_smatCSR_Cdp),INTENT(IN) :: B
!!#### REQUIRED OUTPUT
TYPE(TYPE_smatCSR_Cdp) :: C
INCLUDE "06-A-USR_smatCSR__ADD_smatCSR_C.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__ADD_smatCSR.f90.bdy"
!!--end--
END FUNCTION

SUBROUTINE EQUALS_smatCSR_dmat_Rsp( S , A )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED OUTPUT
TYPE(TYPE_smatCSR_Rsp),INTENT(OUT) :: S
INCLUDE "06-A-USR_smatCSR__EQUALS_dmat_R.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__EQUALS_dmat.f90.bdy"
!!--end--
END SUBROUTINE

SUBROUTINE EQUALS_smatCSR_dmat_Rdp( S , A )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED OUTPUT
TYPE(TYPE_smatCSR_Rdp),INTENT(OUT) :: S
INCLUDE "06-A-USR_smatCSR__EQUALS_dmat_R.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__EQUALS_dmat.f90.bdy"
!!--end--
END SUBROUTINE

SUBROUTINE EQUALS_smatCSR_dmat_Csp( S , A )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_C=>KIND_Csp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED OUTPUT
TYPE(TYPE_smatCSR_Csp),INTENT(OUT) :: S
INCLUDE "06-A-USR_smatCSR__EQUALS_dmat_C.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__EQUALS_dmat.f90.bdy"
!!--end--
END SUBROUTINE

SUBROUTINE EQUALS_smatCSR_dmat_Cdp( S , A )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_C=>KIND_Cdp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED OUTPUT
TYPE(TYPE_smatCSR_Cdp),INTENT(OUT) :: S
INCLUDE "06-A-USR_smatCSR__EQUALS_dmat_C.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__EQUALS_dmat.f90.bdy"
!!--end--
END SUBROUTINE

SUBROUTINE EQUALS_dmat_smatCSR_Rsp( A , S )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Rsp),INTENT(IN) :: S
INCLUDE "06-A-USR_smatCSR__dmat_EQUALS_R.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__dmat_EQUALS.f90.bdy"
!!--end--
END SUBROUTINE

SUBROUTINE EQUALS_dmat_smatCSR_Rdp( A , S )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Rdp),INTENT(IN) :: S
INCLUDE "06-A-USR_smatCSR__dmat_EQUALS_R.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__dmat_EQUALS.f90.bdy"
!!--end--
END SUBROUTINE

SUBROUTINE EQUALS_dmat_smatCSR_Csp( A , S )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_C=>KIND_Csp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Csp),INTENT(IN) :: S
INCLUDE "06-A-USR_smatCSR__dmat_EQUALS_C.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__dmat_EQUALS.f90.bdy"
!!--end--
END SUBROUTINE

SUBROUTINE EQUALS_dmat_smatCSR_Cdp( A , S )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_C=>KIND_Cdp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Cdp),INTENT(IN) :: S
INCLUDE "06-A-USR_smatCSR__dmat_EQUALS_C.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__dmat_EQUALS.f90.bdy"
!!--end--
END SUBROUTINE

PURE SUBROUTINE COPY_smatCSR_Rsp( S , A )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Rsp),INTENT(OUT) :: S
TYPE(TYPE_smatCSR_Rsp),INTENT(IN)  :: A
INCLUDE "06-A-USR_smatCSR__COPY.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__COPY.f90.bdy"
!!--end--
END SUBROUTINE

PURE SUBROUTINE COPY_smatCSR_Rdp( S , A )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Rdp),INTENT(OUT) :: S
TYPE(TYPE_smatCSR_Rdp),INTENT(IN)  :: A
INCLUDE "06-A-USR_smatCSR__COPY.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__COPY.f90.bdy"
!!--end--
END SUBROUTINE

PURE SUBROUTINE COPY_smatCSR_Csp( S , A )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_C=>KIND_Csp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Csp),INTENT(OUT) :: S
TYPE(TYPE_smatCSR_Csp),INTENT(IN)  :: A
INCLUDE "06-A-USR_smatCSR__COPY.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__COPY.f90.bdy"
!!--end--
END SUBROUTINE

PURE SUBROUTINE COPY_smatCSR_Cdp( S , A )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_C=>KIND_Cdp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Cdp),INTENT(OUT) :: S
TYPE(TYPE_smatCSR_Cdp),INTENT(IN)  :: A
INCLUDE "06-A-USR_smatCSR__COPY.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__COPY.f90.bdy"
!!--end--
END SUBROUTINE

FUNCTION IsLower_smatCSR_Rsp( S ) RESULT(IsLower)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Rsp),INTENT(IN) :: S
INCLUDE "06-A-USR_smatCSR__IsLower.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__IsLower.f90.bdy"
!!--end--
END FUNCTION

FUNCTION IsLower_smatCSR_Rdp( S ) RESULT(IsLower)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Rdp),INTENT(IN) :: S
INCLUDE "06-A-USR_smatCSR__IsLower.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__IsLower.f90.bdy"
!!--end--
END FUNCTION

FUNCTION IsLower_smatCSR_Csp( S ) RESULT(IsLower)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_C=>KIND_Csp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Csp),INTENT(IN) :: S
INCLUDE "06-A-USR_smatCSR__IsLower.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__IsLower.f90.bdy"
!!--end--
END FUNCTION

FUNCTION IsLower_smatCSR_Cdp( S ) RESULT(IsLower)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_C=>KIND_Cdp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Cdp),INTENT(IN) :: S
INCLUDE "06-A-USR_smatCSR__IsLower.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__IsLower.f90.bdy"
!!--end--
END FUNCTION

FUNCTION IsUpper_smatCSR_Rsp( S ) RESULT(IsUpper)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Rsp),INTENT(IN) :: S
INCLUDE "06-A-USR_smatCSR__IsUpper.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__IsUpper.f90.bdy"
!!--end--
END FUNCTION

FUNCTION IsUpper_smatCSR_Rdp( S ) RESULT(IsUpper)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Rdp),INTENT(IN) :: S
INCLUDE "06-A-USR_smatCSR__IsUpper.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__IsUpper.f90.bdy"
!!--end--
END FUNCTION

FUNCTION IsUpper_smatCSR_Csp( S ) RESULT(IsUpper)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_C=>KIND_Csp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Csp),INTENT(IN) :: S
INCLUDE "06-A-USR_smatCSR__IsUpper.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__IsUpper.f90.bdy"
!!--end--
END FUNCTION

FUNCTION IsUpper_smatCSR_Cdp( S ) RESULT(IsUpper)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_C=>KIND_Cdp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Cdp),INTENT(IN) :: S
INCLUDE "06-A-USR_smatCSR__IsUpper.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__IsUpper.f90.bdy"
!!--end--
END FUNCTION

FUNCTION IsStrictlyLower_smatCSR_Rsp( S ) RESULT(IsStrictlyLower)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Rsp),INTENT(IN) :: S
INCLUDE "06-A-USR_smatCSR__IsStrictlyLower.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__IsStrictlyLower.f90.bdy"
!!--end--
END FUNCTION

FUNCTION IsStrictlyLower_smatCSR_Rdp( S ) RESULT(IsStrictlyLower)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Rdp),INTENT(IN) :: S
INCLUDE "06-A-USR_smatCSR__IsStrictlyLower.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__IsStrictlyLower.f90.bdy"
!!--end--
END FUNCTION

FUNCTION IsStrictlyLower_smatCSR_Csp( S ) RESULT(IsStrictlyLower)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_C=>KIND_Csp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Csp),INTENT(IN) :: S
INCLUDE "06-A-USR_smatCSR__IsStrictlyLower.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__IsStrictlyLower.f90.bdy"
!!--end--
END FUNCTION

FUNCTION IsStrictlyLower_smatCSR_Cdp( S ) RESULT(IsStrictlyLower)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_C=>KIND_Cdp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Cdp),INTENT(IN) :: S
INCLUDE "06-A-USR_smatCSR__IsStrictlyLower.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__IsStrictlyLower.f90.bdy"
!!--end--
END FUNCTION

FUNCTION IsStrictlyUpper_smatCSR_Rsp( S ) RESULT(IsStrictlyUpper)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Rsp),INTENT(IN) :: S
INCLUDE "06-A-USR_smatCSR__IsStrictlyUpper.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__IsStrictlyUpper.f90.bdy"
!!--end--
END FUNCTION

FUNCTION IsStrictlyUpper_smatCSR_Rdp( S ) RESULT(IsStrictlyUpper)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Rdp),INTENT(IN) :: S
INCLUDE "06-A-USR_smatCSR__IsStrictlyUpper.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__IsStrictlyUpper.f90.bdy"
!!--end--
END FUNCTION

FUNCTION IsStrictlyUpper_smatCSR_Csp( S ) RESULT(IsStrictlyUpper)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_C=>KIND_Csp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Csp),INTENT(IN) :: S
INCLUDE "06-A-USR_smatCSR__IsStrictlyUpper.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__IsStrictlyUpper.f90.bdy"
!!--end--
END FUNCTION

FUNCTION IsStrictlyUpper_smatCSR_Cdp( S ) RESULT(IsStrictlyUpper)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_C=>KIND_Cdp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Cdp),INTENT(IN) :: S
INCLUDE "06-A-USR_smatCSR__IsStrictlyUpper.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__IsStrictlyUpper.f90.bdy"
!!--end--
END FUNCTION

FUNCTION IsOK_smatCSR_Rsp ( S ) RESULT(IsOK)
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Rsp),INTENT(IN) :: S
INCLUDE "06-A-USR_smatCSR__IsOK.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__IsOK.f90.bdy"
!!--end--
END FUNCTION

FUNCTION IsOK_smatCSR_Rdp ( S ) RESULT(IsOK)
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Rdp),INTENT(IN) :: S
INCLUDE "06-A-USR_smatCSR__IsOK.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__IsOK.f90.bdy"
!!--end--
END FUNCTION

FUNCTION IsOK_smatCSR_Csp ( S ) RESULT(IsOK)
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Csp),INTENT(IN) :: S
INCLUDE "06-A-USR_smatCSR__IsOK.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__IsOK.f90.bdy"
!!--end--
END FUNCTION

FUNCTION IsOK_smatCSR_Cdp ( S ) RESULT(IsOK)
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Cdp),INTENT(IN) :: S
INCLUDE "06-A-USR_smatCSR__IsOK.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__IsOK.f90.bdy"
!!--end--
END FUNCTION

SUBROUTINE SetVal_smatCSR_Rsp( S , i , j , val )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT/OUTPUT
TYPE(TYPE_smatCSR_Rsp),INTENT(INOUT) :: S
INCLUDE "06-A-USR_smatCSR__SetVal_R.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__SetVal.f90.bdy"
END SUBROUTINE

SUBROUTINE SetVal_smatCSR_Rdp( S , i , j , val )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT/OUTPUT
TYPE(TYPE_smatCSR_Rdp),INTENT(INOUT) :: S
INCLUDE "06-A-USR_smatCSR__SetVal_R.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__SetVal.f90.bdy"
END SUBROUTINE

SUBROUTINE SetVal_smatCSR_Csp( S , i , j , val )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_C=>KIND_Csp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT/OUTPUT
TYPE(TYPE_smatCSR_Csp),INTENT(INOUT) :: S
INCLUDE "06-A-USR_smatCSR__SetVal_C.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__SetVal.f90.bdy"
END SUBROUTINE

SUBROUTINE SetVal_smatCSR_Cdp( S , i , j , val )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_C=>KIND_Cdp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT/OUTPUT
TYPE(TYPE_smatCSR_Cdp),INTENT(INOUT) :: S
INCLUDE "06-A-USR_smatCSR__SetVal_C.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__SetVal.f90.bdy"
END SUBROUTINE

SUBROUTINE AddVal_smatCSR_Rsp( S , i , j , val )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT/OUTPUT
TYPE(TYPE_smatCSR_Rsp),INTENT(INOUT) :: S
INCLUDE "06-A-USR_smatCSR__AddVal_R.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__AddVal.f90.bdy"
END SUBROUTINE

SUBROUTINE AddVal_smatCSR_Rdp( S , i , j , val )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT/OUTPUT
TYPE(TYPE_smatCSR_Rdp),INTENT(INOUT) :: S
INCLUDE "06-A-USR_smatCSR__AddVal_R.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__AddVal.f90.bdy"
END SUBROUTINE

SUBROUTINE AddVal_smatCSR_Csp( S , i , j , val )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_C=>KIND_Csp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT/OUTPUT
TYPE(TYPE_smatCSR_Csp),INTENT(INOUT) :: S
INCLUDE "06-A-USR_smatCSR__AddVal_C.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__AddVal.f90.bdy"
END SUBROUTINE

SUBROUTINE AddVal_smatCSR_Cdp( S , i , j , val )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_C=>KIND_Cdp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT/OUTPUT
TYPE(TYPE_smatCSR_Cdp),INTENT(INOUT) :: S
INCLUDE "06-A-USR_smatCSR__AddVal_C.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__AddVal.f90.bdy"
END SUBROUTINE

FUNCTION RowSum_smatCSR_Rsp( S, i ) RESULT( RowSum )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Rsp),INTENT(IN) :: S
INCLUDE "06-A-USR_smatCSR__RowSum_R.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__RowSum.f90.bdy"
!!--end--
END FUNCTION

FUNCTION RowSum_smatCSR_Rdp( S, i ) RESULT( RowSum )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Rdp),INTENT(IN) :: S
INCLUDE "06-A-USR_smatCSR__RowSum_R.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__RowSum.f90.bdy"
!!--end--
END FUNCTION

FUNCTION RowSum_smatCSR_Csp( S, i ) RESULT( RowSum )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_C=>KIND_Csp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Csp),INTENT(IN) :: S
INCLUDE "06-A-USR_smatCSR__RowSum_C.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__RowSum.f90.bdy"
!!--end--
END FUNCTION

FUNCTION RowSum_smatCSR_Cdp( S, i ) RESULT( RowSum )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_C=>KIND_Cdp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Cdp),INTENT(IN) :: S
INCLUDE "06-A-USR_smatCSR__RowSum_C.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__RowSum.f90.bdy"
!!--end--
END FUNCTION

FUNCTION RowNNZ_smatCSR_Rsp( S, i ) RESULT(RowNNZ)
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Rsp),INTENT(IN) :: S
INCLUDE "06-A-USR_smatCSR__RowNNZ.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__RowNNZ.f90.bdy"
!!--end--
END FUNCTION

FUNCTION RowNNZ_smatCSR_Rdp( S, i ) RESULT(RowNNZ)
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Rdp),INTENT(IN) :: S
INCLUDE "06-A-USR_smatCSR__RowNNZ.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__RowNNZ.f90.bdy"
!!--end--
END FUNCTION

FUNCTION RowNNZ_smatCSR_Csp( S, i ) RESULT(RowNNZ)
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Csp),INTENT(IN) :: S
INCLUDE "06-A-USR_smatCSR__RowNNZ.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__RowNNZ.f90.bdy"
!!--end--
END FUNCTION

FUNCTION RowNNZ_smatCSR_Cdp( S, i ) RESULT(RowNNZ)
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Cdp),INTENT(IN) :: S
INCLUDE "06-A-USR_smatCSR__RowNNZ.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__RowNNZ.f90.bdy"
!!--end--
END FUNCTION

SUBROUTINE SAVE_smatCSR_Rsp ( SA , A , form )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### LOCAL PARAMETERS
INTEGER,PARAMETER :: LEN_R = LEN_Rsp
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Rsp),INTENT(IN) :: A
INCLUDE "06-A-USR_smatCSR__SAVE_R.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__SAVE.f90.bdy"
!!--end--
END SUBROUTINE

SUBROUTINE SAVE_smatCSR_Rdp ( SA , A , form )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### LOCAL PARAMETERS
INTEGER,PARAMETER :: LEN_R = LEN_Rdp
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Rdp),INTENT(IN) :: A
INCLUDE "06-A-USR_smatCSR__SAVE_R.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__SAVE.f90.bdy"
!!--end--
END SUBROUTINE

SUBROUTINE SAVE_smatCSR_Csp ( SA , A , form )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_C=>KIND_Csp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### LOCAL PARAMETERS
INTEGER,PARAMETER :: LEN_C = LEN_Csp
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Csp),INTENT(IN) :: A
INCLUDE "06-A-USR_smatCSR__SAVE_C.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__SAVE.f90.bdy"
!!--end--
END SUBROUTINE

SUBROUTINE SAVE_smatCSR_Cdp ( SA , A , form )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_C=>KIND_Cdp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### LOCAL PARAMETERS
INTEGER,PARAMETER :: LEN_C = LEN_Cdp
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Cdp),INTENT(IN) :: A
INCLUDE "06-A-USR_smatCSR__SAVE_C.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__SAVE.f90.bdy"
!!--end--
END SUBROUTINE

FUNCTION Eye_smatCSR_Rsp( S ) RESULT(Eye)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Rsp),INTENT(IN) :: S
!!#### REQUIRED OUTPUT
TYPE(TYPE_smatCSR_Rsp) :: Eye
INCLUDE "06-A-USR_smatCSR__Eye_R.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__Eye.f90.bdy"
!!--end--
END FUNCTION

FUNCTION Eye_smatCSR_Rdp( S ) RESULT(Eye)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Rdp),INTENT(IN) :: S
!!#### REQUIRED OUTPUT
TYPE(TYPE_smatCSR_Rdp) :: Eye
INCLUDE "06-A-USR_smatCSR__Eye_R.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__Eye.f90.bdy"
!!--end--
END FUNCTION

FUNCTION Eye_smatCSR_Csp( S ) RESULT(Eye)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_C=>KIND_Csp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Csp),INTENT(IN)  :: S
!!#### REQUIRED OUTPUT
TYPE(TYPE_smatCSR_Csp) :: Eye
INCLUDE "06-A-USR_smatCSR__Eye_C.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__Eye.f90.bdy"
!!--end--
END FUNCTION

FUNCTION Eye_smatCSR_Cdp( S ) RESULT(Eye)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_C=>KIND_Cdp                    !!((01-A-KND_IntrinsicTypes.f90))
!!#### REQUIRED INPUT
TYPE(TYPE_smatCSR_Cdp),INTENT(IN)  :: S
!!#### REQUIRED OUTPUT
TYPE(TYPE_smatCSR_Cdp) :: Eye
INCLUDE "06-A-USR_smatCSR__Eye_C.f90.hdr"
!!--begin--
INCLUDE "06-A-USR_smatCSR__Eye.f90.bdy"
!!--end--
END FUNCTION

END MODULE


! Define the module for the key type.
! Override the hash_value and == operator interface.
module ints_module

  implicit none

  type ints_type
    integer, allocatable :: ints(:)
  end type

  type reals_type
    real(8), allocatable :: reals(:)
  end type

  interface hash_value
    module procedure hash_value_ints
  end interface

  interface operator (==)
    module procedure ints_equal
  end interface

#ifdef __GFORTRAN__
  interface assignment (=)
    module procedure ints_ptr_assign
  end interface
#endif

  contains

    function hash_value_ints(ints) result(hash)
      type(ints_type), intent(in) :: ints
      integer :: hash
      integer :: i

      hash = 0
      do i = 1, size(ints%ints)
        hash = xor(hash, ints%ints(i) + 1640531527 + ishft(hash, 6) + ishft(hash, -2))
      enddo
    end function

    function ints_equal(lhs, rhs)
      type(ints_type), intent(in) :: lhs, rhs
      logical :: ints_equal
      integer :: i

      if (size(lhs%ints) /= size(rhs%ints)) then
        ints_equal = .false.
        return
      endif

      do i = 1, size(lhs%ints)
        if (lhs%ints(i) /= rhs%ints(i)) then
          ints_equal = .false.
          return
        endif
      enddo

      ints_equal = .true.

    end function

#ifdef __GFORTRAN__
    subroutine ints_ptr_assign(lhs, rhs)
      type(ints_type), pointer, intent(inout) :: lhs
      type(ints_type), pointer, intent(in) :: rhs
      lhs => rhs
    end subroutine
#endif

end module ints_module

! Define the macros needed by fhash and include fhash.f90
#define KEY_USE use ints_module
#define KEY_TYPE type(ints_type)
#define VALUE_USE  use ints_module
#define VALUE_TYPE type(reals_type)
!#define VALUE_TYPE_INIT 0.0
#define SHORTNAME ints_double
#include "fhash.f90"


module ab
!Setup A and b i.e. we are solving Ax=b

use gauss_legendre
use inputs
use bonn
implicit none

	!n_k = Number of nodes and weights for [0,inf] integral
	integer, parameter, public :: n_k = n_0_2q + n_2q_inf

	!ss = Length of xi vector/function.
	integer, parameter, public :: ss = n_theta_k*(1 + n_k)

	!m_avg = Used in the denomenator of the scatering equation.
	!i.e. E_q - E_k + i*epsilon ---> sqrt( m_avg^2 + q^2 ) - (m_avg^2 + k^2) + i*epsilon
	real(8), parameter, public :: m_avg = ( m_1 + m_2 )/2.0d0

contains

real(8) function V_pip(qp,thetap,qpp,thetapp,lambda1p,lambda2p,lambda1pp,lambda2pp,LAMBDA,T)
!Computes the phi integrated potential (FEG method) over the interval [0,2pi].

implicit none

	!T = Isospin
	!(qp,thetap), (qpp,thetapp) = vec{q},vec{q'}.
	!lambda1p,lambda2p,lambda1pp,lambda2pp = < | >,< |sigma^(1)*sigma^(2)| >
	!LAMBDA = 0,1,-1 value that appears in FEG method.
	integer, intent(in) :: T
	real(8), intent(in) :: qp,thetap,qpp,thetapp,lambda1p,lambda2p,lambda1pp,lambda2pp,LAMBDA

	!s = Summing variable in the integral approximation
	!c1 = Counter
	!x,w = Nodes and weights for quadrature
	complex(8) :: s
	integer :: c1
	real(8), dimension(n_V_avg) :: x,w

	call gauss_legendre_quadrature(n_V_avg,0.0d0,2.0d0*pi,x,w)

	s = (0.0d0,0.0d0)
	do c1 = 1,n_V_avg

		!phi = 0 in the potential
		s = s + w(c1)*cdexp( i*LAMBDA*x(c1) )*V(qp,thetap,0.0d0,qpp,thetapp,x(c1),lambda1p,lambda2p,lambda1pp,lambda2pp,T)

	enddo

	!The imaginary part is zero.
	V_pip = ( 1.0d0/(2.0d0*pi) )*real(s)

end function

real(8) function V_1(qp,thetap,q,T)
!<++|V|++>

implicit none

	integer, intent(in) :: T
	real(8), intent(in) :: qp,thetap,q

	V_1 = V(qp,thetap,0.0d0,q,0.0d0,0.0d0,0.5d0,0.5d0,0.5d0,0.5d0,T)

end function

real(8) function VLAMBDA_1(qp,thetap,qpp,thetapp,LAMBDA,T)
!<++|V^Lambda|++>

implicit none

	integer, intent(in) :: T
	real(8), intent(in) :: qp,thetap,qpp,thetapp,LAMBDA

	VLAMBDA_1 = V_pip(qp,thetap,qpp,thetapp,0.5d0,0.5d0,0.5d0,0.5d0,LAMBDA,T)

end function

real(8) function V_2(qp,thetap,q,T)
!<++|V|-->

implicit none

	integer, intent(in) :: T
	real(8), intent(in) :: qp,thetap,q

	V_2 = V(qp,thetap,0.0d0,q,0.0d0,0.0d0,0.5d0,0.5d0,-0.5d0,-0.5d0,T)

end function

real(8) function VLAMBDA_2(qp,thetap,qpp,thetapp,LAMBDA,T)
!<++|V^Lambda|-->

implicit none

	integer, intent(in) :: T
	real(8), intent(in) :: qp,thetap,qpp,thetapp,LAMBDA

	VLAMBDA_2 = V_pip(qp,thetap,qpp,thetapp,0.5d0,0.5d0,-0.5d0,-0.5d0,LAMBDA,T)

end function

real(8) function V_3(qp,thetap,q,T)
!<+-|V|+->

implicit none

	integer, intent(in) :: T
	real(8), intent(in) :: qp,thetap,q

	V_3 = V(qp,thetap,0.0d0,q,0.0d0,0.0d0,0.5d0,-0.5d0,0.5d0,-0.5d0,T)

end function

real(8) function VLAMBDA_3(qp,thetap,qpp,thetapp,LAMBDA,T)
!<+-|V^Lambda|+->

implicit none

	integer, intent(in) :: T
	real(8), intent(in) :: qp,thetap,qpp,thetapp,LAMBDA

	VLAMBDA_3 = V_pip(qp,thetap,qpp,thetapp,0.5d0,-0.5d0,0.5d0,-0.5d0,LAMBDA,T)

end function

real(8) function V_4(qp,thetap,q,T)
!<+-|V|-+>

implicit none

	integer, intent(in) :: T
	real(8), intent(in) :: qp,thetap,q

	V_4 = V(qp,thetap,0.0d0,q,0.0d0,0.0d0,0.5d0,-0.5d0,-0.5d0,0.5d0,T)

end function

real(8) function VLAMBDA_4(qp,thetap,qpp,thetapp,LAMBDA,T)
!<+-|V^Lambda|-+>

implicit none

	integer, intent(in) :: T
	real(8), intent(in) :: qp,thetap,qpp,thetapp,LAMBDA

	VLAMBDA_4 = V_pip(qp,thetap,qpp,thetapp,0.5d0,-0.5d0,-0.5d0,0.5d0,LAMBDA,T)

end function

real(8) function V_5(qp,thetap,q,T)
!<++|V|+->

implicit none

	integer, intent(in) :: T
	real(8), intent(in) :: qp,thetap,q

	V_5 = V(qp,thetap,0.0d0,q,0.0d0,0.0d0,0.5d0,0.5d0,0.5d0,-0.5d0,T)

end function

real(8) function VLAMBDA_5(qp,thetap,qpp,thetapp,LAMBDA,T)
!<++|V^Lambda|+->

implicit none

	integer, intent(in) :: T
	real(8), intent(in) :: qp,thetap,qpp,thetapp,LAMBDA

	VLAMBDA_5 = V_pip(qp,thetap,qpp,thetapp,0.5d0,0.5d0,0.5d0,-0.5d0,LAMBDA,T)

end function

real(8) function V_6(qp,thetap,q,T)
!<+-|V|++>

implicit none

	integer, intent(in) :: T
	real(8), intent(in) :: qp,thetap,q

	V_6 = V(qp,thetap,0.0d0,q,0.0d0,0.0d0,0.5d0,-0.5d0,0.5d0,0.5d0,T)

end function

real(8) function VLAMBDA_6(qp,thetap,qpp,thetapp,LAMBDA,T)
!<+-|V^Lambda|++>

implicit none

	integer, intent(in) :: T
	real(8), intent(in) :: qp,thetap,qpp,thetapp,LAMBDA

	VLAMBDA_6 = V_pip(qp,thetap,qpp,thetapp,0.5d0,-0.5d0,0.5d0,0.5d0,LAMBDA,T)

end function

real(8) function V0(qp,thetap,q,T)
!^{0}V

implicit none

	integer, intent(in) :: T
	real(8), intent(in) :: qp,thetap,q

	V0 = V_1(qp,thetap,q,T) - V_2(qp,thetap,q,T)

end function

real(8) function VLAMBDA0(qp,thetap,qpp,thetapp,LAMBDA,T)
!^{0}V^Lambda

implicit none

	integer, intent(in) :: T
	real(8), intent(in) :: qp,thetap,qpp,thetapp,LAMBDA

	VLAMBDA0 = VLAMBDA_1(qp,thetap,qpp,thetapp,LAMBDA,T) - VLAMBDA_2(qp,thetap,qpp,thetapp,LAMBDA,T)

end function

real(8) function V12(qp,thetap,q,T)
!^{12}V

implicit none

	integer, intent(in) :: T
	real(8), intent(in) :: qp,thetap,q

	V12 = V_1(qp,thetap,q,T) + V_2(qp,thetap,q,T)

end function

real(8) function VLAMBDA12(qp,thetap,qpp,thetapp,LAMBDA,T)
!^{12}V^Lambda

implicit none

	integer, intent(in) :: T
	real(8), intent(in) :: qp,thetap,qpp,thetapp,LAMBDA

	VLAMBDA12 = VLAMBDA_1(qp,thetap,qpp,thetapp,LAMBDA,T) + VLAMBDA_2(qp,thetap,qpp,thetapp,LAMBDA,T)

end function

real(8) function VLAMBDA1(qp,thetap,qpp,thetapp,LAMBDA,T)
!^{1}V^Lambda
!Note: This is used purly for convience. I'm using Rup's linear combinations.

implicit none

	integer, intent(in) :: T
	real(8), intent(in) :: qp,thetap,qpp,thetapp,LAMBDA

	VLAMBDA1 = VLAMBDA_3(qp,thetap,qpp,thetapp,LAMBDA,T) - VLAMBDA_4(qp,thetap,qpp,thetapp,LAMBDA,T)

end function

subroutine principle_value_quadrature(q,xx,ww,cutoff_inf)
!Generates quadradure rule to preform the priciple value integral i.e.,
!pv int[f(x)/(x-q),{x,0,inf}] with a singularity at x = q.
!
!To preform the principle value integral,
!pv int[f(x)/(x-q),{x,0,inf}] = int[f(x)/(x-q),{x,0,2q}] + int[f(x)/(x-q),{x,2q,inf}]
!Then employ Gauss-Legendre quadrature normally with the exception that
!YOU MAKE SURE TO CHOOSE AN EVEN NUMBER OF PONTS FOR THE [0,2q] INTEGRAL.

implicit none

	!q = |q|
	!cutoff_inf = Cutoff for [2q,inf] integral.
	!xx,ww = Nodes/Weights
	real(8), intent(in) :: q,cutoff_inf
	real(8), dimension(n_k), intent(out) :: xx,ww

	!x_1,w_1 = Nodes/weights for [0,2q] integral.
	!x_2,w_2 = Nodes/weights for [2q,inf] integral.
	real(8), dimension(n_0_2q) :: x_1,w_1
	real(8), dimension(n_2q_inf) :: x_2,w_2

	call gauss_legendre_quadrature(n_0_2q,0.0d0,2.0d0*q,x_1,w_1)
	call gauss_legendre_quadrature(n_2q_inf,2.0d0*q,cutoff_inf,x_2,w_2)

	xx(1:n_0_2q) = x_1
	xx(n_0_2q + 1:n_k) = x_2
	ww(1:n_0_2q) = w_1
	ww(n_0_2q + 1:n_k) = w_2

end subroutine

subroutine xi(q,xi_k,cutoff_inf)
!Values of vec{q}' to evaluate at.

implicit none

	!q = |q|
	!cutoff_inf = Cutoff for [2q,inf] integral.
	!xi_k = Values of vec{q}' to evaluate at.
	real(8), intent(in) :: q,cutoff_inf
	real(8), dimension(ss,2), intent(out) :: xi_k

	!c1,c2 = Counters
	!p,j = Variables in Eq. 18 of T matrix report.
	!x_theta_k, w_theta_k,x_k,w_k = Nodes and weights for the theta_k, and k integral.
	integer :: c1,c2,p,j
	real(8), dimension(n_theta_k) :: x_theta_k,w_theta_k
	real(8), dimension(n_k) :: x_k,w_k

	call gauss_legendre_quadrature(n_theta_k,0.0d0,pi,x_theta_k,w_theta_k)
	call principle_value_quadrature(q,x_k,w_k,cutoff_inf)

	!c_j(q) vector see Eq. 19 of T matrix report.
	do c1 = 1,n_theta_k

		xi_k(c1,1) = q
		xi_k(c1,2) = x_theta_k(c1)

	enddo

	!b_l vector see Eq. 19 of T matrix report.
	do c2 = 1,n_k*n_theta_k

		p = floor(  ( dble(c2-1)/dble(n_theta_k) ) + 1.0d0  )
		j = c2 - n_theta_k*(p - 1)

		xi_k(c2 + n_theta_k,1) = x_k(p)
		xi_k(c2 + n_theta_k,2) = x_theta_k(j)

	enddo

end subroutine

real(8) function pauli(qpp,thetapp)
!The Pauli operator i.e. Q(q",theta",P,kF1,kF2)
!Notes: Pcm, k_fermi_1, k_fermi_2, and Q_pauli are globaly defined variables found in input.f90

implicit none

	!qpp,thetapp = vec{q}".
	real(8), intent(in) :: qpp,thetapp

	!P_plus_qpp and P_minus_qpp = |P + q"| and |P - q"|
	real(8) :: P_plus_qpp,P_minus_qpp

	P_plus_qpp = dsqrt(  (qpp**2.0d0) + (Pcm**2.0d0) + 2.0d0*Pcm*qpp*dcos(thetapp)  )
	P_minus_qpp = dsqrt(  (qpp**2.0d0) + (Pcm**2.0d0) - 2.0d0*Pcm*qpp*dcos(thetapp)  )

	!I have to convert kF[fm^(-1)] to MeV by multiplying by hbar*c.
	if( (P_plus_qpp > (k_fermi_1*197.327d0)) .and. (P_minus_qpp > (k_fermi_2*197.327d0)) ) then

		pauli = 1.0d0

	else

		pauli = Q_pauli

	endif

end function

complex(8) function alpha(k,j,q,LAMBDA,T,Vn,cutoff_inf)
!Computes alpha

implicit none

	interface

		real(8) function Vn(qp,thetap,qpp,thetapp,LAMBDA,T)

				integer, intent(in) :: T
				real(8), intent(in) :: qp,thetap,qpp,thetapp,LAMBDA

		end function

	end interface

	!k,j = Row,Column of matrix.
	!T = Isospin.
	!q =|q|.
	!LAMBDA = 0,1,-1 value that appears in FEG method.
	!cutoff_inf = Cutoff for [2q,inf] integral.
	integer, intent(in) :: k,j,T
	real(8), intent(in) :: q,LAMBDA,cutoff_inf

	!E_q = I.e. E_q = sqrt( q^2 + m_avg^2 ).
	!x_theta_k, w_theta_k = Nodes and weights for the theta_k integral.
	!xi_k = Values to evaluate vec{q}' at.
	real(8) :: E_q
	real(8), dimension(n_theta_k) :: x_theta_k,w_theta_k
	real(8), dimension(ss,2):: xi_k

	call xi(q,xi_k,cutoff_inf)
	call gauss_legendre_quadrature(n_theta_k,0.0d0,pi,x_theta_k,w_theta_k)

	!Use "m_avg" i.e. not m or m_1 or m_2.
	E_q = dsqrt( q**2.0d0 + m_avg**2.0d0 )

	alpha = -i*(pi**2.0d0)*q*E_q*w_theta_k(j)*dsin( x_theta_k(j) )*Vn(xi_k(k,1),xi_k(k,2),q,x_theta_k(j),LAMBDA,T)&
			&*pauli(q,x_theta_k(j))

end function

real(8) function beta(k,L,q,LAMBDA,T,Vn,cutoff_inf)
!Computes beta

implicit none

	interface

		real(8) function Vn(qp,thetap,qpp,thetapp,LAMBDA,T)

			integer, intent(in) :: T
			real(8), intent(in) :: qp,thetap,qpp,thetapp,LAMBDA

		end function

	end interface

	!k,L = Row,Column of matrix.
	!T = Isospin.
	!q =|q|.
	!LAMBDA = 0,1,-1 value that appears in FEG method.
	!cutoff_inf = Cutoff for [2q,inf] integral.
	integer, intent(in) :: k,L,T
	real(8), intent(in) :: q,LAMBDA,cutoff_inf

	!p,j = Variables in Eq. 18 of T matrix report.
	!E_q,E_yp = I.e. E_q = sqrt(m_avg^2 + q^2).
	!temp1 = Temporary variable.
	!x_theta_k, w_theta_k,x_k,w_k = Nodes and weights for the theta_k, and k integral.
	integer :: p,j
	real(8) :: E_q,E_yp,temp1
	real(8), dimension(n_theta_k) :: x_theta_k,w_theta_k
	real(8), dimension(n_k) :: x_k,w_k
	real(8), dimension(ss,2):: xi_k

	call xi(q,xi_k,cutoff_inf)

	call gauss_legendre_quadrature(n_theta_k,0.0d0,pi,x_theta_k,w_theta_k)
	call principle_value_quadrature(q,x_k,w_k,cutoff_inf)

	p = floor(  ( dble(L-1)/dble(n_theta_k) ) + 1.0d0  )
	j = L - n_theta_k*(p - 1)

	!Use "m_avg" i.e. not m or m_1 or m_2.
	E_q = dsqrt( q**2.0d0 + m_avg**2.0d0 )
	E_yp = dsqrt(  ( x_k(p) )**2.0d0 + m_avg**2.0d0  )

	temp1 = ( x_k(p)**2.0d0 )*dsin( x_theta_k(j) )
	beta = pi*w_k(p)*w_theta_k(j)*( temp1/(E_q - E_yp) )*Vn(xi_k(k,1),xi_k(k,2),x_k(p),x_theta_k(j),LAMBDA,T)&
			&*pauli(x_k(p),x_theta_k(j))

end function

subroutine build_A(A,q,LAMBDA,T,Vn,cutoff_inf)
!Computes matrix A i.e. Ax=b

implicit none

	interface

		real(8) function Vn(qp,thetap,qpp,thetapp,LAMBDA,T)

			integer, intent(in) :: T
			real(8), intent(in) :: qp,thetap,qpp,thetapp,LAMBDA

		end function

	end interface

	!T = Isospin.
	!q = |q|.
	!LAMBDA = 0,1,-1 value that appears in FEG method.
	!cutoff_inf = Cutoff for [2q,inf] integral.
	!A = Matrix representing the kernal.
	integer, intent(in) :: T
	real(8), intent(in) :: q,LAMBDA,cutoff_inf
	complex, dimension(ss,ss), intent(out) :: A

	!c1,c2,c3,c4 = Counters
	integer :: c1,c2,c3,c4

	!Put column on the outside of loop. Since this is more efficient in fortran.

!$omp parallel
!$omp do

	!Alpha block
	do c2 = 1,n_theta_k

		do c1 = 1,ss

			!They are automatically typecast
			A(c1,c2) = alpha(c1,c2,q,LAMBDA,T,Vn,cutoff_inf)

		enddo

	enddo

!$omp end do
!$omp do

	!Beta block
	do c4 = 1,(n_k*n_theta_k)

		do c3 = 1,ss

			!They are automatically typecast
			A(c3,n_theta_k + c4) = beta(c3,c4,q,LAMBDA,T,Vn,cutoff_inf)

		enddo

	enddo

!$omp end do
!$omp end parallel

end subroutine

subroutine build_V(V,q,T,Vn,cutoff_inf)
!Builds the potential vector. i.e. the b in Ax=b

implicit none

	interface

		real(8) function Vn(qp,thetap,q,T)

			integer, intent(in) :: T
			real(8), intent(in) :: qp,thetap,q

		end function

	end interface

	!q = |q|
	!cutoff_inf = Cutoff for [2q,inf] integral.
	!T = Isospin
	!V = Potential vector
	real(8), intent(in) :: q,cutoff_inf
	integer, intent(in) :: T
	complex, dimension(ss), intent(out) :: V

	!c1 = Counter
	!xi_k = Where to evaluate vec{q}' at.
	integer :: c1
	real(8), dimension(ss,2) :: xi_k

	call xi(q,xi_k,cutoff_inf)

	do c1 = 1,ss

		V(c1) = Vn(xi_k(c1,1),xi_k(c1,2),q,T)

	enddo

end subroutine

end module


! **********************************************************************************
! *    ROUTINES FOR COMPUTING THE SCATTERED FIELD COEFFICIENTS FOR SPHERES AND     *
! *    THE Q MATRIX FOR UNIAXIAL ANISOTROPIC PARTICLES AND PARTICLES ON OR NEAR    *
! *                              A PLANE SURFACE                                   *
! *    -----------------------------------------------------------------------     *
! *    Partial list of subroutines:                                                *
! *      coefficients_fg,                  coefficients_fg_m,                      *
! *      coefficients_fg_m_coated,         coefficients_fg_m_rec,                  *
! *      vector_Q_sphere,                  vector_Q_sphere1,                       *
! *      vector_Q_sphere1_m,               An,      Bn,                            *
! *      matrix_S1,                        matrix_Q_anis,                          *
! *      ConvergenceMatrixElemAnis,        matrixPARTSUB                           *
! **********************************************************************************
subroutine coefficients_fg (wavenumber, r, ind_ref, Mrank, Nrank, Nmax, c)
!-----------------------------------------------------------------------------------
! The routine computes the scattered field coefficients for a spherical particle   !
! and the azimuthal modes m = 0,1,..., Mrank.                                      !
!-----------------------------------------------------------------------------------
  use parameters
  use derived_parameters
  implicit none
  integer    :: Mrank, Nrank, Nmax
  real(O)    :: r, wavenumber
  complex(O) :: ind_ref, c(2*Nmax)
!
  integer    :: k, n, m, l, N0
  real(O)    :: nr
  complex(O) :: x, f, f1, f2
  complex(O),allocatable :: j(:), y(:), h(:), hd(:), A(:)
!
  allocate (j(0:Nrank), y(0:Nrank), h(0:Nrank), hd(0:Nrank), A(Nrank))
  x = cmplx(wavenumber * r,0.0,O)
  if (abs(x) < MachEps) x = cmplx(MachEps,MachEps,O)
  call besel_h_complete (x, Nrank, j, y, h, hd)
  call An (x, ind_ref, Nrank, A)
  do m = 0, Mrank
    if (m == 0) then
      do k = 1, Nrank
        n  = k
        nr = real(n,O)
        f  = ind_ref * A(n) + nr / x
        f1 = f * j(n) - j(n-1)
        f2 = f * h(n) - h(n-1)
        c(k) = - f1 / f2
        f  = A(n) / ind_ref + nr / x
        f1 = f * j(n) - j(n-1)
        f2 = f * h(n) - h(n-1)
        c(Nmax+k) = - f1 / f2
      end do
    else
      N0 = Nrank + (m - 1) * (2 * Nrank - m + 2)
      do l = 1, 2
        do k = 1, Nrank - m + 1
          n  = m + k - 1
          nr = real(n,O)
          f  = ind_ref * A(n) + nr / x
          f1 = f * j(n) - j(n-1)
          f2 = f * h(n) - h(n-1)
          c(N0+k) = - f1 / f2
          f  = A(n) / ind_ref + nr / x
          f1 = f * j(n) - j(n-1)
          f2 = f * h(n) - h(n-1)
          c(Nmax+N0+k) = - f1 / f2
        end do
        N0 = N0 + Nrank - m + 1
      end do
    end if
  end do
  deallocate (j, y, h, hd, A)
end subroutine coefficients_fg
!***********************************************************************************
subroutine coefficients_fg_m (wavenumber, r, ind_ref, m, Nrank, Nmax, c)
!-----------------------------------------------------------------------------------
! The routine computes the scattered field coefficients for a spherical particle   !
! and the azimuthal modes m.                                                       !
!-----------------------------------------------------------------------------------
  use parameters
  use derived_parameters
  implicit none
  integer    :: m, Nrank, Nmax
  real(O)    :: r, wavenumber
  complex(O) :: ind_ref, c(2*Nmax)
!
  integer    :: k, n
  real(O)    :: nr
  complex(O) :: x, f, f1, f2
  complex(O),allocatable :: j(:), y(:), h(:), hd(:), A(:)
!
  allocate (j(0:Nrank), y(0:Nrank), h(0:Nrank), hd(0:Nrank), A(Nrank))
  x = cmplx(wavenumber * r,0.0,O)
  if (abs(x) < MachEps) x = cmplx(MachEps,MachEps,O)
  call besel_h_complete (x, Nrank, j, y, h, hd)
  call An (x, ind_ref, Nrank, A)
  if (m == 0) then
    do k = 1, Nmax
      n  = k
      nr = real(n,O)
      f  = ind_ref * A(n) + nr / x
      f1 = f * j(n) - j(n-1)
      f2 = f * h(n) - h(n-1)
      c(k) = - f1 / f2
      f  = A(n) / ind_ref + nr / x
      f1 = f * j(n) - j(n-1)
      f2 = f * h(n) - h(n-1)
      c(Nmax+k) = - f1 / f2
    end do
  else
    do k = 1, Nmax
      n  = m + k - 1
      nr = real(n,O)
      f  = ind_ref * A(n) + nr / x
      f1 = f * j(n) - j(n-1)
      f2 = f * h(n) - h(n-1)
      c(k) = - f1 / f2
      f  = A(n) / ind_ref + nr / x
      f1 = f * j(n) - j(n-1)
      f2 = f * h(n) - h(n-1)
      c(Nmax+k) = - f1 / f2
    end do
  end if
  deallocate (j, y, h, hd, A)
end subroutine coefficients_fg_m
!***********************************************************************************
subroutine coefficients_fg_m_coated (wavenumber, Npart, r, ind_ref, m, Nrank,       &
           Nmax, c)
!-----------------------------------------------------------------------------------
! The routine computes the scattered field coefficients for a coated spherical     !
! particle and the azimuthal modes m.                                              !
!-----------------------------------------------------------------------------------
  use parameters
  use derived_parameters
  implicit none
  integer    :: m, Npart, Nrank, Nmax
  real(O)    :: wavenumber, r(Npart)
  complex(O) :: ind_ref(Npart), c(2*Nmax)
!
  integer    :: p
  complex(O) :: x, ind_refC
!
  if (Npart == 1) then
    x = cmplx(wavenumber * r(1),0.0,O)
    ind_refC = ind_ref(1)
  else
    x = ind_ref(Npart-1) * wavenumber * r(Npart)
    ind_refC = ind_ref(Npart) / ind_ref(Npart-1)
  end if
  if (abs(x) < MachEps) x = cmplx(MachEps,MachEps,O)
  call coefficients_fg_m_rec (.true., x, ind_refC, m, Nrank, Nmax, c)
  if (Npart > 1) then
    do p = Npart - 1, 1, -1
      if (p > 1) then
        x = ind_ref(p-1) * wavenumber * r(p)
        ind_refC = ind_ref(p) / ind_ref(p-1)
      else
        x = cmplx(wavenumber * r(1),0.0,O)
        ind_refC = ind_ref(1)
      end if
      if (abs(x) < MachEps) x = cmplx(MachEps,MachEps,O)
      call coefficients_fg_m_rec (.false., x, ind_refC, m, Nrank, Nmax, c)
    end do
  end if
end subroutine coefficients_fg_m_coated
!***********************************************************************************
subroutine coefficients_fg_m_rec (firstcall, x, ind_ref, m, Nrank, Nmax, c)
!-----------------------------------------------------------------------------------
! The routine computes the scattered field coefficients for a coated sphere and    !
! the azimuthal mode m using a reccurence relation.                                !
!-----------------------------------------------------------------------------------
  use parameters
  implicit none
  integer    :: m, Nrank, Nmax
  complex(O) :: x, ind_ref, c(2*Nmax)
  logical    :: firstcall
!
  integer    :: k, n
  real(O)    :: nr
  complex(O) :: xm, f, f1, f2, b1, b2, pn, sn, qn, rn
  complex(O),allocatable :: j(:), y(:), h(:), hd(:), A(:), B(:), jm(:), ym(:),      &
                            hm(:), hdm(:)
!
  allocate (j(0:Nrank), y(0:Nrank), h(0:Nrank), hd(0:Nrank), A(Nrank))
  call besel_h_complete (x, Nrank, j, y, h, hd)
  call An (x, ind_ref, Nrank, A)
  if (.not. firstcall) then
    xm = x * ind_ref
    allocate (jm(0:Nrank), ym(0:Nrank), hm(0:Nrank), hdm(0:Nrank), B(Nrank))
    call besel_h_complete (xm, Nrank, jm, ym, hm, hdm)
    call Bn (x, ind_ref, Nrank, B)
  end if
  if (m == 0) then
    do k = 1, Nmax
      n  = k
      nr = real(n,O)
      if (firstcall) then
        pn = one
        sn = one
        qn = one
        rn = one
      else
        b1 = hm(n) / jm(n)
        b2 = B(n) / A(n)
        pn = one + c(k) * b1
        sn = one + c(Nmax+k) * b1
        qn = one + c(Nmax+k) * b1 * b2
        rn = one + c(k) * b1 * b2
      end if
      f  = rn * ind_ref * A(n) + pn * nr / x
      f1 = f * j(n) - pn * j(n-1)
      f2 = f * h(n) - pn * h(n-1)
      c(k) = - f1 / f2
      f  = qn * A(n) / ind_ref + sn * nr / x
      f1 = f * j(n) - sn * j(n-1)
      f2 = f * h(n) - sn * h(n-1)
      c(Nmax+k) = - f1 / f2
    end do
  else
    do k = 1, Nmax
      n  = m + k - 1
      nr = real(n,O)
      if (firstcall) then
        pn = one
        sn = one
        qn = one
        rn = one
      else
        b1 = hm(n) / jm(n)
        b2 = B(n) / A(n)
        pn = one + c(k) * b1
        sn = one + c(Nmax+k) * b1
        qn = one + c(Nmax+k) * b1 * b2
        rn = one + c(k) * b1 * b2
      end if
      f  = rn * ind_ref * A(n) + pn * nr / x
      f1 = f * j(n) - pn * j(n-1)
      f2 = f * h(n) - pn * h(n-1)
      c(k) = - f1 / f2
      f  = qn * A(n) / ind_ref + sn * nr / x
      f1 = f * j(n) - sn * j(n-1)
      f2 = f * h(n) - sn * h(n-1)
      c(Nmax+k) = - f1 / f2
    end do
  end if
  deallocate (j, y, h, hd, A)
  if (.not.firstcall) deallocate (jm, ym, hm, hdm, B)
end subroutine coefficients_fg_m_rec
!***********************************************************************************
subroutine vector_Q_sphere (index1, index2, wavenumber, r, ind_ref, Mrank, Nrank,   &
           Nmax, c)
!-----------------------------------------------------------------------------------
! The routine computes the Q vector for a spherical particle and the azimuthal     !
! modes m = 0,1,...,Mrank.                                                         !
!-----------------------------------------------------------------------------------
  use parameters
  use derived_parameters
  implicit none
  integer    :: Mrank, Nrank, Nmax, index1, index2
  real(O)    :: r, wavenumber
  complex(O) :: ind_ref, c(2*Nmax)
!
  integer    :: k, n, m, l, N0
  complex(O) :: x, mx, f, f1, f2
  complex(O),allocatable :: j(:), jd(:), h(:), hd(:)
!
  allocate (j(0:Nrank), jd(0:Nrank), h(0:Nrank), hd(0:Nrank))
  x = cmplx(wavenumber * r,0.0,O)
  if (abs(x) < MachEps) x = cmplx(MachEps,MachEps,O)
  mx = x * ind_ref
  if (index1 == 3 .and. index2 == 1) then
    call besel_h (x, Nrank, h, hd)
    call besel_j (mx, Nrank, j, jd)
  else if (index1 == 3 .and. index2 == 3) then
    call besel_h (x, Nrank, h, hd)
    call besel_h (mx, Nrank, j, jd)
  else if (index1 == 1 .and. index2 == 1) then
    call besel_j (x, Nrank, h, hd)
    call besel_j (mx, Nrank, j, jd)
  else if (index1 == 1 .and. index2 == 3) then
    call besel_j (x, Nrank, h, hd)
    call besel_h (mx, Nrank, j, jd)
  end if
  f = im * x
  do m = 0, Mrank
    if (m == 0) then
      do k = 1, Nrank
        n  = k
        f1 = f * j(n) * hd(n)
        f2 = f * h(n) * jd(n)
        c(k)      = f1 - f2
        c(Nmax+k) = (ind_ref**2 * f1 - f2) / ind_ref
      end do
    else
      N0 = Nrank + (m - 1) * (2 * Nrank - m + 2)
      do l = 1, 2
        do k = 1, Nrank - m + 1
          n = m + k - 1
          f1 = f * j(n) * hd(n)
          f2 = f * h(n) * jd(n)
          c(N0+k)      = f1 - f2
          c(Nmax+N0+k) = (ind_ref**2 * f1 - f2) / ind_ref
        end do
        N0 = N0 + Nrank - m + 1
      end do
    end if
  end do
  deallocate (j, jd, h, hd)
end subroutine vector_Q_sphere
!***********************************************************************************
subroutine vector_Q_sphere1 (index1, index2, wavenumber, r, ind_ref, Mrank, Nrank,  &
           Nmax, c)
!-----------------------------------------------------------------------------------
! The routine computes the Q vector for a spherical particle and the azimuthal     !
! modes m = 0,1,..., Mrank. In contrast to the subroutine "vector_Q_sphere" the    !
! derivative of the Bessel and Hankel functions are expressed in terms of the      !
! An and Bn coefficients.                                                          !
!-----------------------------------------------------------------------------------
  use parameters
  use derived_parameters
  implicit none
  integer    :: Mrank, Nrank, Nmax, index1, index2
  real(O)    :: r, wavenumber
  complex(O) :: ind_ref, c(2*Nmax)
!
  integer    :: k, n, m, l, N0
  real(O)    :: nr
  complex(O) :: x, mx, f, f1, f2, fn
  complex(O),allocatable :: j(:), jd(:), h(:), hd(:), A(:)
!
  allocate (j(0:Nrank), jd(0:Nrank), h(0:Nrank), hd(0:Nrank), A(Nrank))
  x = cmplx(wavenumber * r,0._O)
  if (abs(x) < MachEps) x = cmplx(MachEps,MachEps,O)
  mx = x * ind_ref
  if (index2 == 1) then
    call An (x, ind_ref, Nrank, A)
  else
    call Bn (x, ind_ref, Nrank, A)
  end if
  if (index1 == 3 .and. index2 == 1) then
    call besel_h (x, Nrank, h, hd)
    call besel_j (mx, Nrank, j, jd)
  else if(index1 == 3 .and. index2 == 3) then
    call besel_h (x, Nrank, h, hd)
    call besel_h (mx, Nrank, j, jd)
  else if(index1 == 1 .and. index2 == 1) then
    call besel_j (x, Nrank, h, hd)
    call besel_j (mx, Nrank, j, jd)
  else if (index1 == 1 .and. index2 == 3) then
    call besel_j (x, Nrank, h, hd)
    call besel_h (mx, Nrank, j, jd)
  end if
  f = - im * x * x
  do m = 0, Mrank
    if (m == 0) then
      do k = 1, Nrank
        n  = k
        nr = real(n,O)
        f1 = ind_ref * A(n) + nr / x
        f2 = A(n) / ind_ref + nr / x
        fn = f * j(n)
        c(k) = fn * (f1*h(n) - h(n-1))
        c(Nmax+k) = ind_ref * fn * (f2 * h(n) - h(n-1))
      end do
    else
      N0 = Nrank + (m - 1) * (2 * Nrank - m + 2)
      do l = 1, 2
        do k = 1, Nrank - m + 1
          n = m + k - 1
          nr = real(n,O)
          f1 = ind_ref * A(n) + nr / x
          f2 = A(n) / ind_ref + nr / x
          fn = f * j(n)
          c(N0+k) = fn * (f1 * h(n) - h(n-1))
          c(Nmax+N0+k) = ind_ref * fn * (f2 * h(n) - h(n-1))
        end do
        N0 = N0 + Nrank - m + 1
      end do
    end if
  end do
  deallocate (j, jd, h, hd, A)
end subroutine vector_Q_sphere1
!***********************************************************************************
subroutine vector_Q_sphere1_m (index1, index2, wavenumber, r,ind_ref, m, Nrank,     &
           Nmax, c)
!-----------------------------------------------------------------------------------
! The routine computes the Q vector for a spherical particle and the azimuthal     !
! mode m.                                                                          !
!-----------------------------------------------------------------------------------
  use parameters
  use derived_parameters
  implicit none
  integer    :: m, Nrank, Nmax, index1, index2
  real(O)    :: wavenumber, r
  complex(O) :: ind_ref, c(2*Nmax)
!
  integer    :: k, n
  real(O)    :: nr
  complex(O) :: x, mx, f, f1, f2, fn
  complex(O),allocatable :: j(:), jd(:), h(:), hd(:), A(:)
!
  allocate (j(0:Nrank), jd(0:Nrank), h(0:Nrank), hd(0:Nrank), A(Nrank))
  x = cmplx(wavenumber * r,0.0,O)
  if (abs(x) < MachEps) x = cmplx(MachEps,MachEps,O)
  mx = x * ind_ref
  if (index2 == 1) then
    call An (x, ind_ref, Nrank, A)
  else
    call Bn (x, ind_ref, Nrank, A)
  end if
  if (index1 == 3 .and. index2 == 1) then
    call besel_h (x, Nrank, h, hd)
    call besel_j (mx, Nrank, j, jd)
  else if (index1 == 3 .and. index2 == 3) then
    call besel_h (x, Nrank, h, hd)
    call besel_h (mx, Nrank, j, jd)
  else if (index1 == 1 .and. index2 == 1) then
    call besel_j (x, Nrank, h, hd)
    call besel_j (mx, Nrank, j, jd)
  else if (index1 == 1 .and. index2 == 3) then
    call besel_j (x, Nrank, h, hd)
    call besel_h (mx, Nrank, j, jd)
  end if
  f = - im * x * x
  if (m == 0) then
    do k = 1, Nmax
      n = k
      nr = real(n,O)
      f1 = ind_ref * A(n) + nr / x
      f2 = A(n) / ind_ref + nr / x
      fn = f * j(n)
      c(k)      = fn * (f1 * h(n) - h(n-1))
      c(Nmax+k) = ind_ref * fn * (f2 * h(n) - h(n-1))
    end do
  else
    do k = 1, Nmax
      n = m + k - 1
      nr = real(n,O)
      f1 = ind_ref * A(n) + nr / x
      f2 = A(n) / ind_ref + nr / x
      fn = f * j(n)
      c(k)      = fn * (f1 * h(n) - h(n-1))
      c(Nmax+k) = ind_ref * fn * (f2 * h(n) - h(n-1))
    end do
  end if
  deallocate (j, jd, h, hd, A)
end subroutine vector_Q_sphere1_m
!***********************************************************************************
subroutine An (x, m, Nrank, A)
!-----------------------------------------------------------------------------------
! The routine computes                                                             !
!                  A(n) = d[ln(x*jn(x))] = [x*jn(x)]'/[x*jn(x)],                   !
! where jn are the Bessel functions.                                               !
!-----------------------------------------------------------------------------------
  use parameters
  implicit none
  integer    :: Nrank
  complex(O) :: x, m, A(Nrank)
!
  real(O)    :: DNc, DNmax, n1r
  integer    :: Nmax, n
  complex(O) :: mx, fp, f, tamp
!
  DNc   = abs(x + 4._O * x**0.33_O + 2._O)
  DNmax = max(DNc,abs(m * x)) + 100._O
  Nmax  = int(DNmax)
  mx = m * x
  fp = zero
  do n = Nmax, 1, -1
    n1r  = real(n + 1,O)
    tamp = n1r / mx
    f = tamp - 1._O / (fp + tamp)
    if (n <= Nrank) A(n) = f
    fp = f
  end do
end subroutine An
!***********************************************************************************
subroutine Bn (x, m, Nrank, B)
!-----------------------------------------------------------------------------------
! The routine computes                                                             !
!                    B(n) = d[ln(x*hn(x))] = [x*hn(x)]'/[x*hn(x)],                 !
! where hn are the Hankel functions.                                               !
!-----------------------------------------------------------------------------------
  use parameters
  implicit none
  integer    :: Nrank
  complex(O) :: x, m, B(Nrank)
!
  integer    :: n
  real(O)    :: n1r
  complex(O) :: mx, smx, cmx, j0, j1, y0, y1, h0, h1, tamp
!
  mx  = m * x
  smx = sin(mx)
  cmx = cos(mx)
  j0  = smx / mx
  j1  = j0 / mx - cmx / mx
  y0  = - cmx / mx
  y1  = y0 / mx - smx / mx
  h0  = j0 + im * y0
  h1  = j1 + im * y1
  B(1)= h0 / h1 - 1._O / mx
  do n = 1, Nrank - 1
    n1r  = real(n + 1,O)
    tamp = n1r / mx
    B(n+1) = - tamp + 1._O / (tamp - B(n))
  end do
end subroutine Bn
!***********************************************************************************
subroutine matrix_S1 (Nmax, Nmax1, S2, n2p, m2p, S1, n1p, m1p)
  use parameters
  implicit none
  integer    :: Nmax, Nmax1, n1p, m1p, n2p, m2p, k, k1
  complex(O) :: S1(2*n1p,2*m1p), S2(2*n2p,2*m2p)
!
  do k = 1, Nmax
    do k1 = 1, Nmax1
      S1(k,k1) = S2(k1,k)
      S1(k,k1+Nmax1) = - S2(k1+Nmax1,k)
      S1(k+Nmax,k1)  =   S1(k,k1+Nmax1)
      S1(k+Nmax,k1+Nmax1) = S1(k,k1)
    end do
  end do
end subroutine matrix_S1
!***********************************************************************************
subroutine matrix_Q_anis (FileGeom, TypeGeom, index1, index2, k, ind_ref, ind_refZ, &
           alphaP, betaP, gamaP, Nsurf, surf, rpX, npX, areaX, Nface, Mrank, Nrank, &
           Nmax, Nbeta, NintAL, Nparam, Nintparam, paramG1, paramG2, weightsG,      &
           A, nap, map)
!-----------------------------------------------------------------------------------
! The routine compute the Q matrix of an uniaxial anisotropic particle.            !
!-----------------------------------------------------------------------------------
  use parameters
  implicit none
  integer     :: TypeGeom, index1, index2, Mrank, Nrank, Nmax, Nsurf, Nface,         &
                 NintAL, Nparam, Nintparam(Nparam), Nbeta, nap, map
  real(O)     :: k, alphaP, betaP, gamaP, surf(Nsurf), paramG1(Nparam,NintAL*NintAL),&
                 paramG2(Nparam,NintAL*NintAL), weightsG(Nparam,NintAL*NintAL),      &
                 rpX(3,NfacePD), npX(3,NfacePD), areaX(NfacePD)
  complex(O)  :: ind_ref, ind_refZ, A(2*nap,2*map)
  logical     :: FileGeom
!
  integer     :: i, j, pint, iparam, Nintl
  real(O)     :: r, theta, phi, dA, param1, param2, pondere, sign, n(3), x, y, z,    &
                 xl, yl, zl, thetal, phil, rl, nr, nt, np, nx, ny, nz, nxl, nyl, nzl
  complex(O)  :: ki, zkl, ml(3), nl(3), xec(3), yec(3), v1, v2, fact, f, xhc(3),     &
                 yhc(3), mixt_product
  complex(O),allocatable :: Xe(:,:), Ye(:,:), m3(:,:), n3(:,:), Xh(:,:), Yh(:,:)
!
  allocate (Xe(3,Nmax), Ye(3,Nmax), Xh(3,Nmax), Yh(3,Nmax), m3(3,Nmax), n3(3,Nmax))
  do i = 1, 2*Nmax
    do j = 1, 2*Nmax
      A(i,j) = zero
    end do
  end do
  ki   = k * ind_ref
  sign = 1._O
  if (index1 == 3 .and. index2 == 1) sign = - 1._O
  f = sign * im * k * k / Pi
  if (.not. FileGeom) then
    do iparam = 1, Nparam
      Nintl = Nintparam(iparam)
      do pint = 1, Nintl
        param1  = paramG1(iparam,pint)
        param2  = paramG2(iparam,pint)
        pondere = weightsG(iparam,pint)
        call elem_geom3D (TypeGeom, Nsurf, surf, param1, param2, iparam, r, theta,   &
             phi, dA, n, .false., 1)
        call MN_anisotrop (ki, ind_ref, ind_refZ, r, theta, phi, alphaP, betaP,      &
             gamaP, Mrank, Nrank, Nmax, Nbeta, Xe, Ye, Xh, Yh)
!       --- compute the localized SWVF in the principal coordinate system ----
        x = r * sin(theta) * cos(phi)
        y = r * sin(theta) * sin(phi)
        z = r * cos(theta)
        call T_cartesian_global_local (x, y, z, alphaP, betaP, gamaP, xl, yl, zl)
        call T_cartesian_spherical (xl, yl, zl, rl, thetal, phil)
        zkl = cmplx(k * rl,0.0,O)
        if (index1 == 3 .and. index2 == 1) then
          call MN_complete (3, zkl, thetal, phil, Mrank, Nrank, Nmax,.false.,.false.,&
               m3, n3)
        else if (index1 == 1 .and. index2 == 1) then
          call MN_complete (1, zkl, thetal, phil, Mrank, Nrank, Nmax,.false.,.false.,&
               m3, n3)
        end if
!       --- transform the unit normal vector in the principal coordinate system ---
        nr = n(1)
        nt = n(2)
        np = n(3)
        nx = sin(theta) * cos(phi)  * nr + cos(theta) * cos(phi)  * nt - sin(phi) * np
        ny = sin(theta) * sin(phi)  * nr + cos(theta) * sin(phi)  * nt + cos(phi) * np
        nz =             cos(theta) * nr -             sin(theta) * nt
        call T_cartesian_global_local (nx, ny, nz, alphaP, betaP, gamaP, nxl, nyl, nzl)
        n(1) =   sin(thetal) * cos(phil) * nxl + sin(thetal) * sin(phil) * nyl +     &
                 cos(thetal) * nzl
        n(2) =   cos(thetal) * cos(phil) * nxl + cos(thetal) * sin(phil) * nyl -     &
                 sin(thetal) * nzl
        n(3) =               - sin(phil) * nxl +               cos(phil) * nyl
        fact = f * dA * pondere
        do i = 1, Nmax
          ml(1) = m3(1,i)
          ml(2) = m3(2,i)
          ml(3) = m3(3,i)
          nl(1) = n3(1,i)
          nl(2) = n3(2,i)
          nl(3) = n3(3,i)
          do j = 1, Nmax
            xec(1) = Xe(1,j)
            xec(2) = Xe(2,j)
            xec(3) = Xe(3,j)
            yec(1) = Ye(1,j)
            yec(2) = Ye(2,j)
            yec(3) = Ye(3,j)
            xhc(1) = Xh(1,j)
            xhc(2) = Xh(2,j)
            xhc(3) = Xh(3,j)
            yhc(1) = Yh(1,j)
            yhc(2) = Yh(2,j)
            yhc(3) = Yh(3,j)
            v1 = mixt_product (n, xec, nl)
            v2 = mixt_product (n, xhc, ml)
            A(i,j) = A(i,j) + (v1 + ind_ref * v2) * fact
            v1 = mixt_product (n, yec, nl)
            v2 = mixt_product (n, yhc, ml)
            A(i,j+Nmax) = A(i,j+Nmax) + (v1 + ind_ref * v2) * fact
            v1 = mixt_product (n, xec, ml)
            v2 = mixt_product (n, xhc, nl)
            A(i+Nmax,j) = A(i+Nmax,j) + (v1 + ind_ref * v2) * fact
            v1 = mixt_product (n, yec, ml)
            v2 = mixt_product (n, yhc, nl)
            A(i+Nmax,j+Nmax) = A(i+Nmax,j+Nmax) + (v1 + ind_ref * v2) * fact
          end do
        end do
      end do
    end do
  else
    do pint = 1, Nface
      x = rpX(1,pint)
      y = rpX(2,pint)
      z = rpX(3,pint)
      call T_cartesian_spherical (x, y, z, r, theta, phi)
      dA = areaX(pint)
      nr =   sin(theta) * cos(phi) * npX(1,pint) +                                   &
             sin(theta) * sin(phi) * npX(2,pint) + cos(theta) * npX(3,pint)
      nt =   cos(theta) * cos(phi) * npX(1,pint) +                                   &
             cos(theta) * sin(phi) * npX(2,pint) - sin(theta) * npX(3,pint)
      np = - sin(phi) * npX(1,pint) + cos(phi) * npX(2,pint)
      call MN_anisotrop (ki, ind_ref, ind_refZ, r, theta, phi, alphaP, betaP, gamaP, &
           Mrank, Nrank, Nmax, Nbeta, Xe, Ye, Xh, Yh)
!     --- compute the localized SWVF in the principal coordinate system ----
      call T_cartesian_global_local (x, y, z, alphaP, betaP, gamaP, xl, yl, zl)
      call T_cartesian_spherical (xl, yl, zl, rl, thetal, phil)
      zkl = cmplx(k * rl,0.0,O)
      if (index1 == 3 .and. index2 == 1) then
        call MN_complete (3, zkl, thetal, phil, Mrank, Nrank, Nmax,.false.,.false.,  &
             m3, n3)
      else if (index1 == 1 .and. index2 == 1) then
        call MN_complete (1, zkl, thetal, phil, Mrank, Nrank, Nmax,.false.,.false.,  &
             m3, n3)
      end if
!     --- transform the unit normal vector in the principal coordinate system ---
      nx = sin(theta) * cos(phi)  * nr + cos(theta) * cos(phi)  * nt - sin(phi) * np
      ny = sin(theta) * sin(phi)  * nr + cos(theta) * sin(phi)  * nt + cos(phi) * np
      nz =             cos(theta) * nr -             sin(theta) * nt
      call T_cartesian_global_local (nx, ny, nz, alphaP, betaP, gamaP, nxl, nyl, nzl)
      n(1) =   sin(thetal) * cos(phil) * nxl + sin(thetal) * sin(phil) * nyl +       &
               cos(thetal) * nzl
      n(2) =   cos(thetal) * cos(phil) * nxl + cos(thetal) * sin(phil) * nyl -       &
               sin(thetal) * nzl
      n(3) =               - sin(phil) * nxl +               cos(phil) * nyl
      fact = f * dA
      do i = 1, Nmax
        ml(1) = m3(1,i)
        ml(2) = m3(2,i)
        ml(3) = m3(3,i)
        nl(1) = n3(1,i)
        nl(2) = n3(2,i)
        nl(3) = n3(3,i)
        do j = 1, Nmax
          xec(1) = Xe(1,j)
          xec(2) = Xe(2,j)
          xec(3) = Xe(3,j)
          yec(1) = Ye(1,j)
          yec(2) = Ye(2,j)
          yec(3) = Ye(3,j)
          xhc(1) = Xh(1,j)
          xhc(2) = Xh(2,j)
          xhc(3) = Xh(3,j)
          yhc(1) = Yh(1,j)
          yhc(2) = Yh(2,j)
          yhc(3) = Yh(3,j)
          v1 = mixt_product (n, xec, nl)
          v2 = mixt_product (n, xhc, ml)
          A(i,j) = A(i,j) + (v1 + ind_ref * v2) * fact
          v1 = mixt_product (n, yec, nl)
          v2 = mixt_product (n, yhc, ml)
          A(i,j+Nmax) = A(i,j+Nmax) + (v1 + ind_ref * v2) * fact
          v1 = mixt_product (n, xec, ml)
          v2 = mixt_product (n, xhc, nl)
          A(i+Nmax,j) = A(i+Nmax,j) + (v1 + ind_ref * v2) * fact
          v1 = mixt_product (n, yec, ml)
          v2 = mixt_product (n, yhc, nl)
          A(i+Nmax,j+Nmax) = A(i+Nmax,j+Nmax) + (v1 + ind_ref * v2) * fact
        end do
      end do
    end do
  end if
  deallocate (Xe, Ye, Xh, Yh, m3, n3)
end subroutine matrix_Q_anis
!***********************************************************************************
subroutine ConvergenceMatrixElemAnis (TypeGeom, index1, index2, k, ind_ref,         &
           ind_refZ, alphaP, betaP, gamaP, Nsurf, surf, mline, mcol, Nrank,         &
           NintMax, Nint1, Nint2, Nbeta, Nparam)
  use parameters
  use derived_parameters
  implicit none
  integer     :: TypeGeom, index1, index2, mline, mcol, Nrank, NintMax, Nint1,      &
                 Nint2, Nsurf, Nparam, Nbeta
  real(O)     :: k, alphaP, betaP, gamaP, surf(Nsurf)
  complex(O)  :: ind_ref, ind_refZ
!
  integer     :: NmaxL, NmaxC, ml_minus, i, j, pint, iparam, Nint1l, Nint2l,        &
                 Nintl, NintAL, iint, imn, jmn
  real(O)     :: r, theta, phi, dA, param1, param2, pondere, sign, n(3), x, y, z,   &
                 xl, yl, zl, thetal, phil, rl, nr, nt, np, nx, ny, nz, nxl, nyl,    &
                 nzl, MaxA(2), MinA(2)
  complex(O)  :: ki, zkl, ml(3), nl(3), xec(3), yec(3), v1, v2, fact, f, xhc(3),    &
                 yhc(3), mixt_product, A11(2,2), A12(2,2), A21(2,2), A22(2,2),      &
                 expfctL
  integer,allocatable    :: Nintparam(:)
  real(O),allocatable    :: paramG1(:,:), paramG2(:,:), weightsG(:,:)
  complex(O),allocatable :: Xe(:,:), Ye(:,:), m3(:,:), n3(:,:), Xh(:,:), Yh(:,:)
!
  NmaxL = Nrank - mline + 1  ! mline >= 0
  NmaxC = Nrank - mcol  + 1  ! mcol  >= 0
  ml_minus = - mline
  allocate (Xe(3,NmaxC), Ye(3,NmaxC), Xh(3,NmaxC), Yh(3,NmaxC),                     &
            m3(3,NmaxL), n3(3,NmaxL))
  ki   = k * ind_ref
  sign = 1._O
  if (index1 == 3 .and. index2 == 1) sign = - 1._O
  f = sign * im * k * k / Pi
  if (mline == 1) then
    print "(2x,'Integral Test over Matrix Elements of Blocks (1,Mrank):')"
  else
    print "(2x,'Integral Test over Matrix Elements of Blocks (Mrank,Mrank):')"
  end if
  print "(2x,'Nint1   Nint2          max-min (A11,A22)             max-min (A12,A21) ')"
  do iint = 1, NintMax
    Nint1l = Nint1 + iint - 1
    Nint2l = Nint2 + iint - 1
    NintAL = max(Nint1l,Nint2l)
    allocate (paramG1(Nparam,NintAL*NintAL), paramG2(Nparam,NintAL*NintAL),         &
              weightsG(Nparam,NintAL*NintAL))
    allocate (Nintparam(Nparam))
    call interpolation_list3D (TypeGeom, Nsurf, surf, Nint1l, Nint2l, NintAL,       &
         Nparam, Nintparam, paramG1, paramG2, weightsG, .false., 1)
    do i = 1, 2
      do j = 1, 2
        A11(i,j) = zero
        A12(i,j) = zero
        A21(i,j) = zero
        A22(i,j) = zero
      end do
    end do
    do iparam = 1, Nparam
      Nintl = Nintparam(iparam)
      do pint = 1, Nintl
        param1  = paramG1(iparam,pint)
        param2  = paramG2(iparam,pint)
        pondere = weightsG(iparam,pint)
        call elem_geom3D (TypeGeom, Nsurf, surf, param1, param2, iparam, r, theta,   &
             phi, dA, n, .false., 1)
        call MN_m_anisotrop (ki, ind_ref, ind_refZ, r, theta, phi, alphaP, betaP,    &
             gamaP, mcol, Nrank, NmaxC, Nbeta, Xe, Ye, Xh, Yh)
!       --- compute the localized SWVF in the principal coordinate system ----
        x = r * sin(theta) * cos(phi)
        y = r * sin(theta) * sin(phi)
        z = r * cos(theta)
        call T_cartesian_global_local (x, y, z, alphaP, betaP, gamaP, xl, yl, zl)
        call T_cartesian_spherical (xl, yl, zl, rl, thetal, phil)
        zkl = cmplx(k * rl,0.0,O)
        if (index1 == 3 .and. index2 == 1) then
          call MN (3, zkl, thetal, ml_minus, Nrank, NmaxL, m3, n3)
        else if (index1 == 1 .and. index2 == 1) then
          call MN (1, zkl, thetal, ml_minus, Nrank, NmaxL, m3, n3)
        end if
!       --- transform the unit normal vector in the principal coordinate system ---
        nr = n(1)
        nt = n(2)
        np = n(3)
        nx = sin(theta) * cos(phi)  * nr + cos(theta) * cos(phi)  * nt - sin(phi) * np
        ny = sin(theta) * sin(phi)  * nr + cos(theta) * sin(phi)  * nt + cos(phi) * np
        nz =             cos(theta) * nr -             sin(theta) * nt
        call T_cartesian_global_local (nx, ny, nz, alphaP, betaP, gamaP, nxl, nyl, nzl)
        n(1) = sin(thetal) * cos(phil) * nxl + sin(thetal) * sin(phil) * nyl + cos(thetal) * nzl
        n(2) = cos(thetal) * cos(phil) * nxl + cos(thetal) * sin(phil) * nyl - sin(thetal) * nzl
        n(3) =             - sin(phil) * nxl +               cos(phil) * nyl
        fact = f * dA * pondere
        expfctL =  exp(im * ml_minus * phil)
        do i = 1, 2
          if (i == 1) then
            imn = 1
          else
            imn = NmaxL
          end if
          ml(1) = m3(1,imn) * expfctL
          ml(2) = m3(2,imn) * expfctL
          ml(3) = m3(3,imn) * expfctL
          nl(1) = n3(1,imn) * expfctL
          nl(2) = n3(2,imn) * expfctL
          nl(3) = n3(3,imn) * expfctL
          do j = 1, 2
            if (j == 1) then
              jmn = 1
            else
              jmn = NmaxC
            end if
            xec(1) = Xe(1,jmn)
            xec(2) = Xe(2,jmn)
            xec(3) = Xe(3,jmn)
            yec(1) = Ye(1,jmn)
            yec(2) = Ye(2,jmn)
            yec(3) = Ye(3,jmn)
            xhc(1) = Xh(1,jmn)
            xhc(2) = Xh(2,jmn)
            xhc(3) = Xh(3,jmn)
            yhc(1) = Yh(1,jmn)
            yhc(2) = Yh(2,jmn)
            yhc(3) = Yh(3,jmn)
            v1 = mixt_product (n, xec, nl)
            v2 = mixt_product (n, xhc, ml)
            A11(i,j) = A11(i,j) + (v1 + ind_ref * v2) * fact
            v1 = mixt_product (n, yec, nl)
            v2 = mixt_product (n, yhc, ml)
            A12(i,j) = A12(i,j) + (v1 + ind_ref * v2) * fact
            v1 = mixt_product (n, xec, ml)
            v2 = mixt_product (n, xhc, nl)
            A21(i,j) = A21(i,j) + (v1 + ind_ref * v2) * fact
            v1 = mixt_product (n, yec, ml)
            v2 = mixt_product (n, yhc, nl)
            A22(i,j) = A22(i,j) + (v1 + ind_ref * v2) * fact
          end do
        end do
      end do
    end do
    MaxA(1) = max(abs(A11(1,1)), abs(A11(1,2)), abs(A11(2,1)), abs(A11(2,2)),       &
                  abs(A22(1,1)), abs(A22(1,2)), abs(A22(2,1)), abs(A22(2,2)))
    MinA(1) = min(abs(A11(1,1)), abs(A11(1,2)), abs(A11(2,1)), abs(A11(2,2)),       &
                  abs(A22(1,1)), abs(A22(1,2)), abs(A22(2,1)), abs(A22(2,2)))

    MaxA(2) = max(abs(A12(1,1)), abs(A12(1,2)), abs(A12(2,1)), abs(A12(2,2)),       &
                  abs(A21(1,1)), abs(A21(1,2)), abs(A21(2,1)), abs(A21(2,2)))
    MinA(2) = min(abs(A12(1,1)), abs(A12(1,2)), abs(A12(2,1)), abs(A12(2,2)),       &
                  abs(A21(1,1)), abs(A21(1,2)), abs(A21(2,1)), abs(A21(2,2)))
    print "(3x,i3,5x,i3,4x,1pe14.6,1x,1pe14.6,1x,1pe14.6,1x,1pe14.6)", Nint1l,      &
            Nint2l, MaxA(1), MinA(1), MaxA(2), MinA(2)
    deallocate (paramG1, paramG2, weightsG, Nintparam)
  end do
  deallocate (Xe, Ye, Xh, Yh, m3, n3)
end subroutine  ConvergenceMatrixElemAnis
!***********************************************************************************
subroutine matrixPARTSUB (k, ind_ref, z0, m, Nrank, Nmax, Nx, x, pond, A, na, ma)
!-----------------------------------------------------------------------------------
! The routine computes the reflection matrix for the scattering of a particle      !
! near or on a plane surface.                                                      !
!-----------------------------------------------------------------------------------
  use parameters
  use derived_parameters
  implicit none
  integer    :: m, Nrank, Nmax, Nx, na, ma
  real(O)    :: k, z0, x(Nx), pond(Nx)
  complex(O) :: ind_ref, A(2*na,2*ma)
!
  integer    :: i, j, pint, n, n1
  real(O)    :: D, nm, n1m, mr
  complex(O) :: fact, t, Rpar, Rperp, Tpar, Tperp, q, cosb, sinb, cosbM0,           &
                sinbM0, sinb0, cosb0, f, fpp, ftp, fpt, ftt
  complex(O),allocatable :: Pnm(:), dPnm(:), pinm(:), taunm(:),                     &
                            PnmM(:), dPnmM(:), pinmM(:), taunmM(:)
!
  allocate (Pnm(0:Nrank), dPnm(0:Nrank), pinm(0:Nrank), taunm(0:Nrank))
  allocate (PnmM(0:Nrank), dPnmM(0:Nrank), pinmM(0:Nrank), taunmM(0:Nrank))
  do i = 1, 2*Nmax
    do j = 1, 2*Nmax
      A(i,j) = zero
    end do
  end do
  q = cmplx(k * z0,0.0,O)
  q = 2._O * im * q
  if (abs(q) < MachEps) q = cmplx(MachEps,MachEps,O)
  mr = real(m,O)
  do pint = 1, Nx
    t     = one - x(pint) / q
    fact  = 4._O * exp(q) * pond(pint) / q
    cosb0 = t
    sinb0 = sqrt(one - t * t)
    call Leg_normalized_complex (sinb0, cosb0, abs(m), Nrank, Pnm, dPnm, pinm, taunm)
    call Fresnel_aer_sub (cosb0, ind_ref, Rpar, Rperp, Tpar, Tperp, cosb, sinb)
    cosbM0 = - t
    sinbM0 = sqrt(one - t * t)
    call Leg_normalized_complex (sinbM0, cosbM0, abs(m), Nrank, PnmM, dPnmM,        &
         pinmM, taunmM)
    do i = 1, Nmax
      if (m == 0) then
        n1 = i
      else
        n1 = abs(m) + i - 1
      end if
      n1m = real(2 * n1 * (n1 + 1),O)
      n1m = 1._O / sqrt(n1m)
      do j = 1, Nmax
        if (m == 0) then
          n = j
        else
          n = abs(m) + j - 1
        end if
        nm  = real(2 * n * (n + 1),O)
        nm  = 1._O / sqrt(nm)
        D   = nm * n1m
        f   = fact * D * im**(n1 - n)
        fpp = f * pinm(n) * pinmM(n1)
        ftt = f * taunm(n) * taunmM(n1)
        fpt = f * pinm(n) * taunmM(n1)
        ftp = f * taunm(n) * pinmM(n1)
        A(i,j) = A(i,j) + (mr**2 * fpp * Rpar + ftt * Rperp)
        A(i+Nmax,j) = A(i+Nmax,j) + mr * (fpt * Rpar + ftp * Rperp)
        A(i,j+Nmax) = A(i,j+Nmax) + mr *(ftp * Rpar + fpt * Rperp)
        A(i+Nmax,j+Nmax) = A(i+Nmax,j+Nmax) + (mr**2 * fpp * Rperp + ftt * Rpar)
      end do
    end do
  end do
  deallocate (Pnm, dPnm, pinm, taunm, PnmM, dPnmM, pinmM, taunmM)
end subroutine matrixPARTSUB