diff --git a/fortran_implementation/CMakeLists.txt b/fortran_implementation/CMakeLists.txt new file mode 100644 index 0000000..0afaf56 --- /dev/null +++ b/fortran_implementation/CMakeLists.txt @@ -0,0 +1,47 @@ +# Specify minimum CMake version +cmake_minimum_required(VERSION 3.12) + +# Project name and language +project(squishyplanet Fortran) + +# Find BLAS source files +file(GLOB BLAS + "${CMAKE_CURRENT_SOURCE_DIR}/external_libraries/BLAS/SRC/*.f" +) +add_library(blas STATIC ${BLAS}) + +file(GLOB_RECURSE LAPACK_ROUTINES + "${CMAKE_CURRENT_SOURCE_DIR}/external_libraries/lapack_routines/*.f" + "${CMAKE_CURRENT_SOURCE_DIR}/external_libraries/lapack_routines/*.f90" +) +add_library(local_lapack_routines STATIC ${LAPACK_ROUTINES}) + +file(GLOB QUADPACK + "${CMAKE_CURRENT_SOURCE_DIR}/external_libraries/QUADPACK/*.F90" +) +add_library(local_quadpack STATIC ${QUADPACK}) + +# Add executable and specify source files +add_executable(squishyplanet + main.f90 + read_in_files.f90 + model_types.f90 + squishyplanet_2d.f90 + constants.f90 + keplerian.f90 + parametric_ellipse.f90 + intersection_pts.f90 + integrals.f90 + planet_3d.f90 + squishyplanet_3d.f90 +) + +target_link_libraries(local_lapack_routines PUBLIC blas) +target_link_libraries(squishyplanet PRIVATE + local_lapack_routines # This already includes blas + local_quadpack +) + +if(CMAKE_BUILD_TYPE MATCHES Debug) + set(CMAKE_Fortran_FLAGS_DEBUG "${CMAKE_Fortran_FLAGS_DEBUG} -fcheck=all -fbacktrace -g -O0 -Wall -Wextra -fimplicit-none") +endif() diff --git a/fortran_implementation/README.md b/fortran_implementation/README.md new file mode 100644 index 0000000..68bb8ee --- /dev/null +++ b/fortran_implementation/README.md @@ -0,0 +1,12 @@ +This is a standalone implementation of the squishyplanet code but in Fortran instead of JAX. The main JAX package does not rely on these routines, and these routines don't rely on the JAX package- this exists only to interface with other Fortran codebases like the original MultiNest and Luna. Though during development we verified it produces outputs for a reasonable set of parameters that match squishyplanet, it is not thoroughly tested or maintained. + +It should, fingers crossed, require no external dependencies beyond CMake and a Fortran compiler. It contains local copies of relevant BLAS, LINPACK, and QUADPACK routines. + +To run an example version, run: +```bash +mkdir build +cd build +cmake .. +cmake --build . +./squishyplanet +``` diff --git a/fortran_implementation/change_of_basis_matricies/g_matrix_10.bin b/fortran_implementation/change_of_basis_matricies/g_matrix_10.bin new file mode 100644 index 0000000..adc51c1 Binary files /dev/null and b/fortran_implementation/change_of_basis_matricies/g_matrix_10.bin differ diff --git a/fortran_implementation/change_of_basis_matricies/g_matrix_2.bin b/fortran_implementation/change_of_basis_matricies/g_matrix_2.bin new file mode 100644 index 0000000..847d471 Binary files /dev/null and b/fortran_implementation/change_of_basis_matricies/g_matrix_2.bin differ diff --git a/fortran_implementation/change_of_basis_matricies/g_matrix_3.bin b/fortran_implementation/change_of_basis_matricies/g_matrix_3.bin new file mode 100644 index 0000000..77539e8 Binary files /dev/null and b/fortran_implementation/change_of_basis_matricies/g_matrix_3.bin differ diff --git a/fortran_implementation/change_of_basis_matricies/g_matrix_4.bin b/fortran_implementation/change_of_basis_matricies/g_matrix_4.bin new file mode 100644 index 0000000..c486f0e Binary files /dev/null and b/fortran_implementation/change_of_basis_matricies/g_matrix_4.bin differ diff --git a/fortran_implementation/change_of_basis_matricies/g_matrix_5.bin b/fortran_implementation/change_of_basis_matricies/g_matrix_5.bin new file mode 100644 index 0000000..dd1fcd0 Binary files /dev/null and b/fortran_implementation/change_of_basis_matricies/g_matrix_5.bin differ diff --git a/fortran_implementation/change_of_basis_matricies/g_matrix_6.bin b/fortran_implementation/change_of_basis_matricies/g_matrix_6.bin new file mode 100644 index 0000000..69c1070 Binary files /dev/null and b/fortran_implementation/change_of_basis_matricies/g_matrix_6.bin differ diff --git a/fortran_implementation/change_of_basis_matricies/g_matrix_7.bin b/fortran_implementation/change_of_basis_matricies/g_matrix_7.bin new file mode 100644 index 0000000..3bcf67e Binary files /dev/null and b/fortran_implementation/change_of_basis_matricies/g_matrix_7.bin differ diff --git a/fortran_implementation/change_of_basis_matricies/g_matrix_8.bin b/fortran_implementation/change_of_basis_matricies/g_matrix_8.bin new file mode 100644 index 0000000..0e01a21 Binary files /dev/null and b/fortran_implementation/change_of_basis_matricies/g_matrix_8.bin differ diff --git a/fortran_implementation/change_of_basis_matricies/g_matrix_9.bin b/fortran_implementation/change_of_basis_matricies/g_matrix_9.bin new file mode 100644 index 0000000..459a5a1 Binary files /dev/null and b/fortran_implementation/change_of_basis_matricies/g_matrix_9.bin differ diff --git a/fortran_implementation/change_of_basis_matricies/generate.py b/fortran_implementation/change_of_basis_matricies/generate.py new file mode 100644 index 0000000..7ece98b --- /dev/null +++ b/fortran_implementation/change_of_basis_matricies/generate.py @@ -0,0 +1,10 @@ +import numpy as np + +from squishyplanet.engine.greens_basis_transform import generate_change_of_basis_matrix + +for i in range(2, 11): + m = np.array(generate_change_of_basis_matrix(i)) + # m = np.asfortranarray(m, dtype=np.float64) + # m.tofile(f"g_matrix_{i}.bin") + with open(f"g_matrix_{i}.bin", "wb") as f: + f.write(m.tobytes("F")) # 'F' ensures Fortran ordering diff --git a/fortran_implementation/constants.f90 b/fortran_implementation/constants.f90 new file mode 100644 index 0000000..0c65cd6 --- /dev/null +++ b/fortran_implementation/constants.f90 @@ -0,0 +1,10 @@ +module constants + use, intrinsic :: iso_fortran_env, only: dp => real64 + implicit none + real(dp), parameter :: PI = 3.14159265358979323846_dp + real(dp), parameter :: TWO_PI = 2.0_dp*PI + real(dp), parameter :: HALF_PI = 0.5_dp*PI + real(dp), parameter :: THREE_HALF_PI = 1.5_dp*PI + real(dp), parameter :: DEG_TO_RAD = PI/180.0_dp + real(dp), parameter :: RAD_TO_DEG = 180.0_dp/PI +end module constants diff --git a/fortran_implementation/external_libraries/BLAS/SRC/CMakeLists.txt b/fortran_implementation/external_libraries/BLAS/SRC/CMakeLists.txt new file mode 100644 index 0000000..b9e6f7c --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/CMakeLists.txt @@ -0,0 +1,161 @@ +####################################################################### +# This is the makefile to create a library for the BLAS. +# The files are grouped as follows: +# +# SBLAS1 -- Single precision real BLAS routines +# CBLAS1 -- Single precision complex BLAS routines +# DBLAS1 -- Double precision real BLAS routines +# ZBLAS1 -- Double precision complex BLAS routines +# +# CB1AUX -- Real BLAS routines called by complex routines +# ZB1AUX -- D.P. real BLAS routines called by d.p. complex +# routines +# +# ALLBLAS -- Auxiliary routines for Level 2 and 3 BLAS +# +# SBLAS2 -- Single precision real BLAS2 routines +# CBLAS2 -- Single precision complex BLAS2 routines +# DBLAS2 -- Double precision real BLAS2 routines +# ZBLAS2 -- Double precision complex BLAS2 routines +# +# SBLAS3 -- Single precision real BLAS3 routines +# CBLAS3 -- Single precision complex BLAS3 routines +# DBLAS3 -- Double precision real BLAS3 routines +# ZBLAS3 -- Double precision complex BLAS3 routines +# +####################################################################### + +#--------------------------------------------------------- +# Level 1 BLAS +#--------------------------------------------------------- + +set(SBLAS1 isamax.f sasum.f saxpy.f scopy.f sdot.f snrm2.f90 + srot.f srotg.f90 sscal.f sswap.f sdsdot.f srotmg.f srotm.f) + +set(CBLAS1 scabs1.f scasum.f scnrm2.f90 icamax.f caxpy.f ccopy.f + cdotc.f cdotu.f csscal.f crotg.f90 cscal.f cswap.f csrot.f) + +set(DBLAS1 idamax.f dasum.f daxpy.f dcopy.f ddot.f dnrm2.f90 + drot.f drotg.f90 dscal.f dsdot.f dswap.f drotmg.f drotm.f) + +set(DB1AUX sscal.f isamax.f) + +set(ZBLAS1 dcabs1.f dzasum.f dznrm2.f90 izamax.f zaxpy.f zcopy.f + zdotc.f zdotu.f zdscal.f zrotg.f90 zscal.f zswap.f zdrot.f) + +set(CB1AUX + isamax.f idamax.f + sasum.f saxpy.f scopy.f sdot.f sgemm.f sgemv.f snrm2.f90 srot.f sscal.f + sswap.f) + +set(ZB1AUX + icamax.f idamax.f + cgemm.f cherk.f cscal.f ctrsm.f + dasum.f daxpy.f dcopy.f ddot.f dgemm.f dgemv.f dnrm2.f90 drot.f dscal.f + dswap.f + scabs1.f) + +#--------------------------------------------------------------------- +# Auxiliary routines needed by both the Level 2 and Level 3 BLAS +#--------------------------------------------------------------------- +set(ALLBLAS lsame.f xerbla.f xerbla_array.f) + +#--------------------------------------------------------- +# Level 2 BLAS +#--------------------------------------------------------- +set(SBLAS2 sgemv.f sgbmv.f ssymv.f ssbmv.f sspmv.f + strmv.f stbmv.f stpmv.f strsv.f stbsv.f stpsv.f + sger.f ssyr.f sspr.f ssyr2.f sspr2.f) + +set(CBLAS2 cgemv.f cgbmv.f chemv.f chbmv.f chpmv.f + ctrmv.f ctbmv.f ctpmv.f ctrsv.f ctbsv.f ctpsv.f + cgerc.f cgeru.f cher.f chpr.f cher2.f chpr2.f) + +set(DBLAS2 dgemv.f dgbmv.f dsymv.f dsbmv.f dspmv.f + dtrmv.f dtbmv.f dtpmv.f dtrsv.f dtbsv.f dtpsv.f + dger.f dsyr.f dspr.f dsyr2.f dspr2.f) + +set(ZBLAS2 zgemv.f zgbmv.f zhemv.f zhbmv.f zhpmv.f + ztrmv.f ztbmv.f ztpmv.f ztrsv.f ztbsv.f ztpsv.f + zgerc.f zgeru.f zher.f zhpr.f zher2.f zhpr2.f) + +#--------------------------------------------------------- +# Level 3 BLAS +#--------------------------------------------------------- +set(SBLAS3 sgemm.f ssymm.f ssyrk.f ssyr2k.f strmm.f strsm.f sgemmtr.f) + +set(CBLAS3 cgemm.f csymm.f csyrk.f csyr2k.f ctrmm.f ctrsm.f + chemm.f cherk.f cher2k.f cgemmtr.f) + +set(DBLAS3 dgemm.f dsymm.f dsyrk.f dsyr2k.f dtrmm.f dtrsm.f dgemmtr.f) + +set(ZBLAS3 zgemm.f zsymm.f zsyrk.f zsyr2k.f ztrmm.f ztrsm.f + zhemm.f zherk.f zher2k.f zgemmtr.f) + + +set(SOURCES) +if(BUILD_SINGLE) + list(APPEND SOURCES ${SBLAS1} ${ALLBLAS} ${SBLAS2} ${SBLAS3}) +endif() +if(BUILD_DOUBLE) + list(APPEND SOURCES + ${DBLAS1} ${DB1AUX} ${ALLBLAS} ${DBLAS2} ${DBLAS3} ${SBLAS3}) +endif() +if(BUILD_COMPLEX) + list(APPEND SOURCES ${CBLAS1} ${CB1AUX} ${ALLBLAS} ${CBLAS2} ${CBLAS3}) +endif() +if(BUILD_COMPLEX16) + list(APPEND SOURCES ${ZBLAS1} ${ZB1AUX} ${ALLBLAS} ${ZBLAS2} ${ZBLAS3}) +endif() +list(REMOVE_DUPLICATES SOURCES) + +add_library(${BLASLIB}_obj OBJECT ${SOURCES}) +set_target_properties(${BLASLIB}_obj PROPERTIES POSITION_INDEPENDENT_CODE ON) + +if(BUILD_INDEX64_EXT_API) + set(SOURCES_64_F) + # Copy files so we can set source property specific to /${BLASLIB}_64_obj target + file(MAKE_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/${BLASLIB}_64_obj) + file(COPY ${SOURCES} DESTINATION ${CMAKE_CURRENT_BINARY_DIR}/${BLASLIB}_64_obj) + file(GLOB SOURCES_64_F ${CMAKE_CURRENT_BINARY_DIR}/${BLASLIB}_64_obj/*.f*) + add_library(${BLASLIB}_64_obj OBJECT ${SOURCES_64_F}) + target_compile_options(${BLASLIB}_64_obj PRIVATE ${FOPT_ILP64}) + set_target_properties(${BLASLIB}_64_obj PROPERTIES POSITION_INDEPENDENT_CODE ON) + #Add _64 suffix to all Fortran functions via macros + foreach(F IN LISTS SOURCES_64_F) + if(CMAKE_Fortran_COMPILER_ID STREQUAL "NAG") + set_source_files_properties(${F} PROPERTIES COMPILE_FLAGS "-fpp") + else() + set_source_files_properties(${F} PROPERTIES COMPILE_FLAGS "-cpp") + endif() + file(STRINGS ${F} ${F}.lst) + list(FILTER ${F}.lst INCLUDE REGEX "subroutine|SUBROUTINE|external|EXTERNAL|function|FUNCTION") + list(FILTER ${F}.lst EXCLUDE REGEX "^!.*") + list(FILTER ${F}.lst EXCLUDE REGEX "^[*].*") + list(FILTER ${F}.lst EXCLUDE REGEX "end|END") + foreach(FUNC IN LISTS ${F}.lst) + string(REGEX REPLACE "^[a-zA-Z0-9_ *]*(subroutine|SUBROUTINE|external|EXTERNAL|function|FUNCTION)[ ]*[*]?" "" FUNC ${FUNC}) + string(REGEX REPLACE "[(][a-zA-Z0-9_, )]*$" "" FUNC ${FUNC}) + string(STRIP ${FUNC} FUNC) + list(APPEND COPT_64_F "${FUNC}=${FUNC}_64") + endforeach() + list(REMOVE_DUPLICATES COPT_64_F) + set_source_files_properties(${F} PROPERTIES COMPILE_DEFINITIONS "${COPT_64_F}") + endforeach() +endif() + +add_library(${BLASLIB} + $ + $<$: $>) + +set_target_properties( + ${BLASLIB} PROPERTIES + VERSION ${LAPACK_VERSION} + SOVERSION ${LAPACK_MAJOR_VERSION} + POSITION_INDEPENDENT_CODE ON + ) +lapack_install_library(${BLASLIB}) + +if( TEST_FORTRAN_COMPILER ) + add_dependencies( ${BLASLIB} run_test_zcomplexabs run_test_zcomplexdiv run_test_zcomplexmult run_test_zminMax ) +endif() diff --git a/fortran_implementation/external_libraries/BLAS/SRC/Makefile b/fortran_implementation/external_libraries/BLAS/SRC/Makefile new file mode 100644 index 0000000..486571f --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/Makefile @@ -0,0 +1,177 @@ +####################################################################### +# This is the makefile to create a library for the BLAS. +# The files are grouped as follows: +# +# SBLAS1 -- Single precision real BLAS routines +# CBLAS1 -- Single precision complex BLAS routines +# DBLAS1 -- Double precision real BLAS routines +# ZBLAS1 -- Double precision complex BLAS routines +# +# CB1AUX -- Real BLAS routines called by complex routines +# ZB1AUX -- D.P. real BLAS routines called by d.p. complex +# routines +# +# ALLBLAS -- Auxiliary routines for Level 2 and 3 BLAS +# +# SBLAS2 -- Single precision real BLAS2 routines +# CBLAS2 -- Single precision complex BLAS2 routines +# DBLAS2 -- Double precision real BLAS2 routines +# ZBLAS2 -- Double precision complex BLAS2 routines +# +# SBLAS3 -- Single precision real BLAS3 routines +# CBLAS3 -- Single precision complex BLAS3 routines +# DBLAS3 -- Double precision real BLAS3 routines +# ZBLAS3 -- Double precision complex BLAS3 routines +# +# The library can be set up to include routines for any combination +# of the four precisions. To create or add to the library, enter make +# followed by one or more of the precisions desired. Some examples: +# make single +# make single complex +# make single double complex complex16 +# Note that these commands are not safe for parallel builds. +# +# Alternatively, the commands +# make all +# or +# make +# without any arguments creates a library of all four precisions. +# The name of the library is held in BLASLIB, which is set in the +# top-level make.inc +# +# To remove the object files after the library is created, enter +# make cleanobj +# To force the source files to be recompiled, enter, for example, +# make single FRC=FRC +# +#--------------------------------------------------------------------- +# +# Edward Anderson, University of Tennessee +# March 26, 1990 +# Susan Ostrouchov, Last updated September 30, 1994 +# ejr, May 2006. +# +####################################################################### + +TOPSRCDIR = ../.. +include $(TOPSRCDIR)/make.inc + +.SUFFIXES: .F .f90 .o +.F.o: + $(FC) $(FFLAGS) -c -o $@ $< +.f90.o: + $(FC) $(FFLAGS) -c -o $@ $< + +.PHONY: all +all: $(BLASLIB) + +#--------------------------------------------------------- +# Comment out the next 6 definitions if you already have +# the Level 1 BLAS. +#--------------------------------------------------------- +SBLAS1 = isamax.o sasum.o saxpy.o scopy.o sdot.o snrm2.o \ + srot.o srotg.o sscal.o sswap.o sdsdot.o srotmg.o srotm.o +$(SBLAS1): $(FRC) + +CBLAS1 = scabs1.o scasum.o scnrm2.o icamax.o caxpy.o ccopy.o \ + cdotc.o cdotu.o csscal.o crotg.o cscal.o cswap.o csrot.o +$(CBLAS1): $(FRC) + +DBLAS1 = idamax.o dasum.o daxpy.o dcopy.o ddot.o dnrm2.o \ + drot.o drotg.o dscal.o dsdot.o dswap.o drotmg.o drotm.o +$(DBLAS1): $(FRC) + +ZBLAS1 = dcabs1.o dzasum.o dznrm2.o izamax.o zaxpy.o zcopy.o \ + zdotc.o zdotu.o zdscal.o zrotg.o zscal.o zswap.o zdrot.o +$(ZBLAS1): $(FRC) + +CB1AUX = isamax.o sasum.o saxpy.o scopy.o snrm2.o sscal.o +$(CB1AUX): $(FRC) + +ZB1AUX = idamax.o dasum.o daxpy.o dcopy.o dnrm2.o dscal.o +$(ZB1AUX): $(FRC) + +#--------------------------------------------------------------------- +# The following line defines auxiliary routines needed by both the +# Level 2 and Level 3 BLAS. Comment it out only if you already have +# both the Level 2 and 3 BLAS. +#--------------------------------------------------------------------- +ALLBLAS = lsame.o xerbla.o xerbla_array.o +$(ALLBLAS): $(FRC) + +#--------------------------------------------------------- +# Comment out the next 4 definitions if you already have +# the Level 2 BLAS. +#--------------------------------------------------------- +SBLAS2 = sgemv.o sgbmv.o ssymv.o ssbmv.o sspmv.o \ + strmv.o stbmv.o stpmv.o strsv.o stbsv.o stpsv.o \ + sger.o ssyr.o sspr.o ssyr2.o sspr2.o +$(SBLAS2): $(FRC) + +CBLAS2 = cgemv.o cgbmv.o chemv.o chbmv.o chpmv.o \ + ctrmv.o ctbmv.o ctpmv.o ctrsv.o ctbsv.o ctpsv.o \ + cgerc.o cgeru.o cher.o chpr.o cher2.o chpr2.o +$(CBLAS2): $(FRC) + +DBLAS2 = dgemv.o dgbmv.o dsymv.o dsbmv.o dspmv.o \ + dtrmv.o dtbmv.o dtpmv.o dtrsv.o dtbsv.o dtpsv.o \ + dger.o dsyr.o dspr.o dsyr2.o dspr2.o +$(DBLAS2): $(FRC) + +ZBLAS2 = zgemv.o zgbmv.o zhemv.o zhbmv.o zhpmv.o \ + ztrmv.o ztbmv.o ztpmv.o ztrsv.o ztbsv.o ztpsv.o \ + zgerc.o zgeru.o zher.o zhpr.o zher2.o zhpr2.o +$(ZBLAS2): $(FRC) + +#--------------------------------------------------------- +# Comment out the next 4 definitions if you already have +# the Level 3 BLAS. +#--------------------------------------------------------- +SBLAS3 = sgemm.o ssymm.o ssyrk.o ssyr2k.o strmm.o strsm.o sgemmtr.o +$(SBLAS3): $(FRC) + +CBLAS3 = cgemm.o csymm.o csyrk.o csyr2k.o ctrmm.o ctrsm.o \ + chemm.o cherk.o cher2k.o cgemmtr.o +$(CBLAS3): $(FRC) + +DBLAS3 = dgemm.o dsymm.o dsyrk.o dsyr2k.o dtrmm.o dtrsm.o dgemmtr.o +$(DBLAS3): $(FRC) + +ZBLAS3 = zgemm.o zsymm.o zsyrk.o zsyr2k.o ztrmm.o ztrsm.o \ + zhemm.o zherk.o zher2k.o zgemmtr.o +$(ZBLAS3): $(FRC) + +ALLOBJ = $(SBLAS1) $(SBLAS2) $(SBLAS3) $(DBLAS1) $(DBLAS2) $(DBLAS3) \ + $(CBLAS1) $(CBLAS2) $(CBLAS3) $(ZBLAS1) \ + $(ZBLAS2) $(ZBLAS3) $(ALLBLAS) + +$(BLASLIB): $(ALLOBJ) + $(AR) $(ARFLAGS) $@ $^ + $(RANLIB) $@ + +.PHONY: single double complex complex16 +single: $(SBLAS1) $(ALLBLAS) $(SBLAS2) $(SBLAS3) + $(AR) $(ARFLAGS) $(BLASLIB) $^ + $(RANLIB) $(BLASLIB) + +double: $(DBLAS1) $(ALLBLAS) $(DBLAS2) $(DBLAS3) + $(AR) $(ARFLAGS) $(BLASLIB) $^ + $(RANLIB) $(BLASLIB) + +complex: $(CBLAS1) $(CB1AUX) $(ALLBLAS) $(CBLAS2) $(CBLAS3) + $(AR) $(ARFLAGS) $(BLASLIB) $^ + $(RANLIB) $(BLASLIB) + +complex16: $(ZBLAS1) $(ZB1AUX) $(ALLBLAS) $(ZBLAS2) $(ZBLAS3) + $(AR) $(ARFLAGS) $(BLASLIB) $^ + $(RANLIB) $(BLASLIB) + +FRC: + @FRC=$(FRC) + +.PHONY: clean cleanobj cleanlib +clean: cleanobj cleanlib +cleanobj: + rm -f *.o +cleanlib: + #rm -f $(BLASLIB) # May point to a system lib, e.g. -lblas diff --git a/fortran_implementation/external_libraries/BLAS/SRC/caxpy.f b/fortran_implementation/external_libraries/BLAS/SRC/caxpy.f new file mode 100644 index 0000000..f50a6ba --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/caxpy.f @@ -0,0 +1,139 @@ +*> \brief \b CAXPY +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CAXPY(N,CA,CX,INCX,CY,INCY) +* +* .. Scalar Arguments .. +* COMPLEX CA +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* COMPLEX CX(*),CY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CAXPY constant times a vector plus a vector. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] CA +*> \verbatim +*> CA is COMPLEX +*> On entry, CA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] CX +*> \verbatim +*> CX is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of CX +*> \endverbatim +*> +*> \param[in,out] CY +*> \verbatim +*> CY is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of CY +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup axpy +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, linpack, 3/11/78. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CAXPY(N,CA,CX,INCX,CY,INCY) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX CA + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + COMPLEX CX(*),CY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,IX,IY +* .. +* .. External Functions .. + REAL SCABS1 + EXTERNAL SCABS1 +* .. + IF (N.LE.0) RETURN + IF (SCABS1(CA).EQ.0.0E+0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* + DO I = 1,N + CY(I) = CY(I) + CA*CX(I) + END DO + ELSE +* +* code for unequal increments or equal increments +* not equal to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + CY(IY) = CY(IY) + CA*CX(IX) + IX = IX + INCX + IY = IY + INCY + END DO + END IF +* + RETURN +* +* End of CAXPY +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/ccopy.f b/fortran_implementation/external_libraries/BLAS/SRC/ccopy.f new file mode 100644 index 0000000..01ee79a --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/ccopy.f @@ -0,0 +1,125 @@ +*> \brief \b CCOPY +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CCOPY(N,CX,INCX,CY,INCY) +* +* .. Scalar Arguments .. +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* COMPLEX CX(*),CY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CCOPY copies a vector x to a vector y. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] CX +*> \verbatim +*> CX is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of CX +*> \endverbatim +*> +*> \param[out] CY +*> \verbatim +*> CY is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of CY +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup copy +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, linpack, 3/11/78. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CCOPY(N,CX,INCX,CY,INCY) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + COMPLEX CX(*),CY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,IX,IY +* .. + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* + DO I = 1,N + CY(I) = CX(I) + END DO + ELSE +* +* code for unequal increments or equal increments +* not equal to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + CY(IY) = CX(IX) + IX = IX + INCX + IY = IY + INCY + END DO + END IF + RETURN +* +* End of CCOPY +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/cdotc.f b/fortran_implementation/external_libraries/BLAS/SRC/cdotc.f new file mode 100644 index 0000000..4f9d8d8 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/cdotc.f @@ -0,0 +1,134 @@ +*> \brief \b CDOTC +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* COMPLEX FUNCTION CDOTC(N,CX,INCX,CY,INCY) +* +* .. Scalar Arguments .. +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* COMPLEX CX(*),CY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CDOTC forms the dot product of two complex vectors +*> CDOTC = X^H * Y +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] CX +*> \verbatim +*> CX is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of CX +*> \endverbatim +*> +*> \param[in] CY +*> \verbatim +*> CY is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of CY +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup dot +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, linpack, 3/11/78. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + COMPLEX FUNCTION CDOTC(N,CX,INCX,CY,INCY) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + COMPLEX CX(*),CY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + COMPLEX CTEMP + INTEGER I,IX,IY +* .. +* .. Intrinsic Functions .. + INTRINSIC CONJG +* .. + CTEMP = (0.0,0.0) + CDOTC = (0.0,0.0) + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* + DO I = 1,N + CTEMP = CTEMP + CONJG(CX(I))*CY(I) + END DO + ELSE +* +* code for unequal increments or equal increments +* not equal to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + CTEMP = CTEMP + CONJG(CX(IX))*CY(IY) + IX = IX + INCX + IY = IY + INCY + END DO + END IF + CDOTC = CTEMP + RETURN +* +* End of CDOTC +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/cdotu.f b/fortran_implementation/external_libraries/BLAS/SRC/cdotu.f new file mode 100644 index 0000000..a482875 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/cdotu.f @@ -0,0 +1,131 @@ +*> \brief \b CDOTU +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* COMPLEX FUNCTION CDOTU(N,CX,INCX,CY,INCY) +* +* .. Scalar Arguments .. +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* COMPLEX CX(*),CY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CDOTU forms the dot product of two complex vectors +*> CDOTU = X^T * Y +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] CX +*> \verbatim +*> CX is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of CX +*> \endverbatim +*> +*> \param[in] CY +*> \verbatim +*> CY is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of CY +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup dot +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, linpack, 3/11/78. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + COMPLEX FUNCTION CDOTU(N,CX,INCX,CY,INCY) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + COMPLEX CX(*),CY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + COMPLEX CTEMP + INTEGER I,IX,IY +* .. + CTEMP = (0.0,0.0) + CDOTU = (0.0,0.0) + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* + DO I = 1,N + CTEMP = CTEMP + CX(I)*CY(I) + END DO + ELSE +* +* code for unequal increments or equal increments +* not equal to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + CTEMP = CTEMP + CX(IX)*CY(IY) + IX = IX + INCX + IY = IY + INCY + END DO + END IF + CDOTU = CTEMP + RETURN +* +* End of CDOTU +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/cgbmv.f b/fortran_implementation/external_libraries/BLAS/SRC/cgbmv.f new file mode 100644 index 0000000..4666747 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/cgbmv.f @@ -0,0 +1,390 @@ +*> \brief \b CGBMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* .. Scalar Arguments .. +* COMPLEX ALPHA,BETA +* INTEGER INCX,INCY,KL,KU,LDA,M,N +* CHARACTER TRANS +* .. +* .. Array Arguments .. +* COMPLEX A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CGBMV performs one of the matrix-vector operations +*> +*> y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, or +*> +*> y := alpha*A**H*x + beta*y, +*> +*> where alpha and beta are scalars, x and y are vectors and A is an +*> m by n band matrix, with kl sub-diagonals and ku super-diagonals. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the operation to be performed as +*> follows: +*> +*> TRANS = 'N' or 'n' y := alpha*A*x + beta*y. +*> +*> TRANS = 'T' or 't' y := alpha*A**T*x + beta*y. +*> +*> TRANS = 'C' or 'c' y := alpha*A**H*x + beta*y. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix A. +*> M must be at least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] KL +*> \verbatim +*> KL is INTEGER +*> On entry, KL specifies the number of sub-diagonals of the +*> matrix A. KL must satisfy 0 .le. KL. +*> \endverbatim +*> +*> \param[in] KU +*> \verbatim +*> KU is INTEGER +*> On entry, KU specifies the number of super-diagonals of the +*> matrix A. KU must satisfy 0 .le. KU. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX array, dimension ( LDA, N ) +*> Before entry, the leading ( kl + ku + 1 ) by n part of the +*> array A must contain the matrix of coefficients, supplied +*> column by column, with the leading diagonal of the matrix in +*> row ( ku + 1 ) of the array, the first super-diagonal +*> starting at position 2 in row ku, the first sub-diagonal +*> starting at position 1 in row ( ku + 2 ), and so on. +*> Elements in the array A that do not correspond to elements +*> in the band matrix (such as the top left ku by ku triangle) +*> are not referenced. +*> The following program segment will transfer a band matrix +*> from conventional full matrix storage to band storage: +*> +*> DO 20, J = 1, N +*> K = KU + 1 - J +*> DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL ) +*> A( K + I, J ) = matrix( I, J ) +*> 10 CONTINUE +*> 20 CONTINUE +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> ( kl + ku + 1 ). +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is COMPLEX array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' +*> and at least +*> ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. +*> Before entry, the incremented array X must contain the +*> vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is COMPLEX +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then Y need not be set on input. +*> \endverbatim +*> +*> \param[in,out] Y +*> \verbatim +*> Y is COMPLEX array, dimension at least +*> ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' +*> and at least +*> ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. +*> Before entry, the incremented array Y must contain the +*> vector y. On exit, Y is overwritten by the updated vector y. +*> If either m or n is zero, then Y not referenced and the function +*> performs a quick return. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> Y. INCY must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup gbmv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> The vector and matrix arguments are not referenced when N = 0, or M = 0 +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX, + + BETA,Y,INCY) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX ALPHA,BETA + INTEGER INCX,INCY,KL,KU,LDA,M,N + CHARACTER TRANS +* .. +* .. Array Arguments .. + COMPLEX A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX ONE + PARAMETER (ONE= (1.0E+0,0.0E+0)) + COMPLEX ZERO + PARAMETER (ZERO= (0.0E+0,0.0E+0)) +* .. +* .. Local Scalars .. + COMPLEX TEMP + INTEGER I,INFO,IX,IY,J,JX,JY,K,KUP1,KX,KY,LENX,LENY + LOGICAL NOCONJ +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC CONJG,MAX,MIN +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. + + .NOT.LSAME(TRANS,'C')) THEN + INFO = 1 + ELSE IF (M.LT.0) THEN + INFO = 2 + ELSE IF (N.LT.0) THEN + INFO = 3 + ELSE IF (KL.LT.0) THEN + INFO = 4 + ELSE IF (KU.LT.0) THEN + INFO = 5 + ELSE IF (LDA.LT. (KL+KU+1)) THEN + INFO = 8 + ELSE IF (INCX.EQ.0) THEN + INFO = 10 + ELSE IF (INCY.EQ.0) THEN + INFO = 13 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('CGBMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. + + ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN +* + NOCONJ = LSAME(TRANS,'T') +* +* Set LENX and LENY, the lengths of the vectors x and y, and set +* up the start points in X and Y. +* + IF (LSAME(TRANS,'N')) THEN + LENX = N + LENY = M + ELSE + LENX = M + LENY = N + END IF + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (LENX-1)*INCX + END IF + IF (INCY.GT.0) THEN + KY = 1 + ELSE + KY = 1 - (LENY-1)*INCY + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through the band part of A. +* +* First form y := beta*y. +* + IF (BETA.NE.ONE) THEN + IF (INCY.EQ.1) THEN + IF (BETA.EQ.ZERO) THEN + DO 10 I = 1,LENY + Y(I) = ZERO + 10 CONTINUE + ELSE + DO 20 I = 1,LENY + Y(I) = BETA*Y(I) + 20 CONTINUE + END IF + ELSE + IY = KY + IF (BETA.EQ.ZERO) THEN + DO 30 I = 1,LENY + Y(IY) = ZERO + IY = IY + INCY + 30 CONTINUE + ELSE + DO 40 I = 1,LENY + Y(IY) = BETA*Y(IY) + IY = IY + INCY + 40 CONTINUE + END IF + END IF + END IF + IF (ALPHA.EQ.ZERO) RETURN + KUP1 = KU + 1 + IF (LSAME(TRANS,'N')) THEN +* +* Form y := alpha*A*x + y. +* + JX = KX + IF (INCY.EQ.1) THEN + DO 60 J = 1,N + TEMP = ALPHA*X(JX) + K = KUP1 - J + DO 50 I = MAX(1,J-KU),MIN(M,J+KL) + Y(I) = Y(I) + TEMP*A(K+I,J) + 50 CONTINUE + JX = JX + INCX + 60 CONTINUE + ELSE + DO 80 J = 1,N + TEMP = ALPHA*X(JX) + IY = KY + K = KUP1 - J + DO 70 I = MAX(1,J-KU),MIN(M,J+KL) + Y(IY) = Y(IY) + TEMP*A(K+I,J) + IY = IY + INCY + 70 CONTINUE + JX = JX + INCX + IF (J.GT.KU) KY = KY + INCY + 80 CONTINUE + END IF + ELSE +* +* Form y := alpha*A**T*x + y or y := alpha*A**H*x + y. +* + JY = KY + IF (INCX.EQ.1) THEN + DO 110 J = 1,N + TEMP = ZERO + K = KUP1 - J + IF (NOCONJ) THEN + DO 90 I = MAX(1,J-KU),MIN(M,J+KL) + TEMP = TEMP + A(K+I,J)*X(I) + 90 CONTINUE + ELSE + DO 100 I = MAX(1,J-KU),MIN(M,J+KL) + TEMP = TEMP + CONJG(A(K+I,J))*X(I) + 100 CONTINUE + END IF + Y(JY) = Y(JY) + ALPHA*TEMP + JY = JY + INCY + 110 CONTINUE + ELSE + DO 140 J = 1,N + TEMP = ZERO + IX = KX + K = KUP1 - J + IF (NOCONJ) THEN + DO 120 I = MAX(1,J-KU),MIN(M,J+KL) + TEMP = TEMP + A(K+I,J)*X(IX) + IX = IX + INCX + 120 CONTINUE + ELSE + DO 130 I = MAX(1,J-KU),MIN(M,J+KL) + TEMP = TEMP + CONJG(A(K+I,J))*X(IX) + IX = IX + INCX + 130 CONTINUE + END IF + Y(JY) = Y(JY) + ALPHA*TEMP + JY = JY + INCY + IF (J.GT.KU) KX = KX + INCX + 140 CONTINUE + END IF + END IF +* + RETURN +* +* End of CGBMV +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/cgemm.f b/fortran_implementation/external_libraries/BLAS/SRC/cgemm.f new file mode 100644 index 0000000..6f1846c --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/cgemm.f @@ -0,0 +1,478 @@ +*> \brief \b CGEMM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* .. Scalar Arguments .. +* COMPLEX ALPHA,BETA +* INTEGER K,LDA,LDB,LDC,M,N +* CHARACTER TRANSA,TRANSB +* .. +* .. Array Arguments .. +* COMPLEX A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CGEMM performs one of the matrix-matrix operations +*> +*> C := alpha*op( A )*op( B ) + beta*C, +*> +*> where op( X ) is one of +*> +*> op( X ) = X or op( X ) = X**T or op( X ) = X**H, +*> +*> alpha and beta are scalars, and A, B and C are matrices, with op( A ) +*> an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANSA +*> \verbatim +*> TRANSA is CHARACTER*1 +*> On entry, TRANSA specifies the form of op( A ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSA = 'N' or 'n', op( A ) = A. +*> +*> TRANSA = 'T' or 't', op( A ) = A**T. +*> +*> TRANSA = 'C' or 'c', op( A ) = A**H. +*> \endverbatim +*> +*> \param[in] TRANSB +*> \verbatim +*> TRANSB is CHARACTER*1 +*> On entry, TRANSB specifies the form of op( B ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSB = 'N' or 'n', op( B ) = B. +*> +*> TRANSB = 'T' or 't', op( B ) = B**T. +*> +*> TRANSB = 'C' or 'c', op( B ) = B**H. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix +*> op( A ) and of the matrix C. M must be at least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of the matrix +*> op( B ) and the number of columns of the matrix C. N must be +*> at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry, K specifies the number of columns of the matrix +*> op( A ) and the number of rows of the matrix op( B ). K must +*> be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX array, dimension ( LDA, ka ), where ka is +*> k when TRANSA = 'N' or 'n', and is m otherwise. +*> Before entry with TRANSA = 'N' or 'n', the leading m by k +*> part of the array A must contain the matrix A, otherwise +*> the leading k by m part of the array A must contain the +*> matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When TRANSA = 'N' or 'n' then +*> LDA must be at least max( 1, m ), otherwise LDA must be at +*> least max( 1, k ). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is COMPLEX array, dimension ( LDB, kb ), where kb is +*> n when TRANSB = 'N' or 'n', and is k otherwise. +*> Before entry with TRANSB = 'N' or 'n', the leading k by n +*> part of the array B must contain the matrix B, otherwise +*> the leading n by k part of the array B must contain the +*> matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. When TRANSB = 'N' or 'n' then +*> LDB must be at least max( 1, k ), otherwise LDB must be at +*> least max( 1, n ). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is COMPLEX +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then C need not be set on input. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX array, dimension ( LDC, N ) +*> Before entry, the leading m by n part of the array C must +*> contain the matrix C, except when beta is zero, in which +*> case C need not be set on entry. +*> On exit, the array C is overwritten by the m by n matrix +*> ( alpha*op( A )*op( B ) + beta*C ). +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> On entry, LDC specifies the first dimension of C as declared +*> in the calling (sub) program. LDC must be at least +*> max( 1, m ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup gemm +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> -- Written on 8-February-1989. +*> Jack Dongarra, Argonne National Laboratory. +*> Iain Duff, AERE Harwell. +*> Jeremy Du Croz, Numerical Algorithms Group Ltd. +*> Sven Hammarling, Numerical Algorithms Group Ltd. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB, + + BETA,C,LDC) +* +* -- Reference BLAS level3 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX ALPHA,BETA + INTEGER K,LDA,LDB,LDC,M,N + CHARACTER TRANSA,TRANSB +* .. +* .. Array Arguments .. + COMPLEX A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC CONJG,MAX +* .. +* .. Local Scalars .. + COMPLEX TEMP + INTEGER I,INFO,J,L,NROWA,NROWB + LOGICAL CONJA,CONJB,NOTA,NOTB +* .. +* .. Parameters .. + COMPLEX ONE + PARAMETER (ONE= (1.0E+0,0.0E+0)) + COMPLEX ZERO + PARAMETER (ZERO= (0.0E+0,0.0E+0)) +* .. +* +* Set NOTA and NOTB as true if A and B respectively are not +* conjugated or transposed, set CONJA and CONJB as true if A and +* B respectively are to be transposed but not conjugated and set +* NROWA and NROWB as the number of rows of A and B respectively. +* + NOTA = LSAME(TRANSA,'N') + NOTB = LSAME(TRANSB,'N') + CONJA = LSAME(TRANSA,'C') + CONJB = LSAME(TRANSB,'C') + IF (NOTA) THEN + NROWA = M + ELSE + NROWA = K + END IF + IF (NOTB) THEN + NROWB = K + ELSE + NROWB = N + END IF +* +* Test the input parameters. +* + INFO = 0 + IF ((.NOT.NOTA) .AND. (.NOT.CONJA) .AND. + + (.NOT.LSAME(TRANSA,'T'))) THEN + INFO = 1 + ELSE IF ((.NOT.NOTB) .AND. (.NOT.CONJB) .AND. + + (.NOT.LSAME(TRANSB,'T'))) THEN + INFO = 2 + ELSE IF (M.LT.0) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (K.LT.0) THEN + INFO = 5 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 8 + ELSE IF (LDB.LT.MAX(1,NROWB)) THEN + INFO = 10 + ELSE IF (LDC.LT.MAX(1,M)) THEN + INFO = 13 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('CGEMM ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. + + (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + IF (BETA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,M + C(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1,N + DO 30 I = 1,M + C(I,J) = BETA*C(I,J) + 30 CONTINUE + 40 CONTINUE + END IF + RETURN + END IF +* +* Start the operations. +* + IF (NOTB) THEN + IF (NOTA) THEN +* +* Form C := alpha*A*B + beta*C. +* + DO 90 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 50 I = 1,M + C(I,J) = ZERO + 50 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 60 I = 1,M + C(I,J) = BETA*C(I,J) + 60 CONTINUE + END IF + DO 80 L = 1,K + TEMP = ALPHA*B(L,J) + DO 70 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + ELSE IF (CONJA) THEN +* +* Form C := alpha*A**H*B + beta*C. +* + DO 120 J = 1,N + DO 110 I = 1,M + TEMP = ZERO + DO 100 L = 1,K + TEMP = TEMP + CONJG(A(L,I))*B(L,J) + 100 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 110 CONTINUE + 120 CONTINUE + ELSE +* +* Form C := alpha*A**T*B + beta*C +* + DO 150 J = 1,N + DO 140 I = 1,M + TEMP = ZERO + DO 130 L = 1,K + TEMP = TEMP + A(L,I)*B(L,J) + 130 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 140 CONTINUE + 150 CONTINUE + END IF + ELSE IF (NOTA) THEN + IF (CONJB) THEN +* +* Form C := alpha*A*B**H + beta*C. +* + DO 200 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 160 I = 1,M + C(I,J) = ZERO + 160 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 170 I = 1,M + C(I,J) = BETA*C(I,J) + 170 CONTINUE + END IF + DO 190 L = 1,K + TEMP = ALPHA*CONJG(B(J,L)) + DO 180 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 180 CONTINUE + 190 CONTINUE + 200 CONTINUE + ELSE +* +* Form C := alpha*A*B**T + beta*C +* + DO 250 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 210 I = 1,M + C(I,J) = ZERO + 210 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 220 I = 1,M + C(I,J) = BETA*C(I,J) + 220 CONTINUE + END IF + DO 240 L = 1,K + TEMP = ALPHA*B(J,L) + DO 230 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 230 CONTINUE + 240 CONTINUE + 250 CONTINUE + END IF + ELSE IF (CONJA) THEN + IF (CONJB) THEN +* +* Form C := alpha*A**H*B**H + beta*C. +* + DO 280 J = 1,N + DO 270 I = 1,M + TEMP = ZERO + DO 260 L = 1,K + TEMP = TEMP + CONJG(A(L,I))*CONJG(B(J,L)) + 260 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 270 CONTINUE + 280 CONTINUE + ELSE +* +* Form C := alpha*A**H*B**T + beta*C +* + DO 310 J = 1,N + DO 300 I = 1,M + TEMP = ZERO + DO 290 L = 1,K + TEMP = TEMP + CONJG(A(L,I))*B(J,L) + 290 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 300 CONTINUE + 310 CONTINUE + END IF + ELSE + IF (CONJB) THEN +* +* Form C := alpha*A**T*B**H + beta*C +* + DO 340 J = 1,N + DO 330 I = 1,M + TEMP = ZERO + DO 320 L = 1,K + TEMP = TEMP + A(L,I)*CONJG(B(J,L)) + 320 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 330 CONTINUE + 340 CONTINUE + ELSE +* +* Form C := alpha*A**T*B**T + beta*C +* + DO 370 J = 1,N + DO 360 I = 1,M + TEMP = ZERO + DO 350 L = 1,K + TEMP = TEMP + A(L,I)*B(J,L) + 350 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 360 CONTINUE + 370 CONTINUE + END IF + END IF +* + RETURN +* +* End of CGEMM +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/cgemmtr.f b/fortran_implementation/external_libraries/BLAS/SRC/cgemmtr.f new file mode 100644 index 0000000..a5f5529 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/cgemmtr.f @@ -0,0 +1,569 @@ +*> \brief \b CGEMMTR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CGEMMTR(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB,BETA, +* C,LDC) +* +* .. Scalar Arguments .. +* COMPLEX ALPHA,BETA +* INTEGER K,LDA,LDB,LDC,N +* CHARACTER TRANSA,TRANSB, UPLO +* .. +* .. Array Arguments .. +* COMPLEX A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CGEMMTR performs one of the matrix-matrix operations +*> +*> C := alpha*op( A )*op( B ) + beta*C, +*> +*> where op( X ) is one of +*> +*> op( X ) = X or op( X ) = X**T, +*> +*> alpha and beta are scalars, and A, B and C are matrices, with op( A ) +*> an n by k matrix, op( B ) a k by n matrix and C an n by n matrix. +*> Thereby, the routine only accesses and updates the upper or lower +*> triangular part of the result matrix C. This behaviour can be used if +*> the resulting matrix C is known to be Hermitian or symmetric. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the lower or the upper +*> triangular part of C is access and updated. +*> +*> UPLO = 'L' or 'l', the lower triangular part of C is used. +*> +*> UPLO = 'U' or 'u', the upper triangular part of C is used. +*> \endverbatim +* +*> \param[in] TRANSA +*> \verbatim +*> TRANSA is CHARACTER*1 +*> On entry, TRANSA specifies the form of op( A ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSA = 'N' or 'n', op( A ) = A. +*> +*> TRANSA = 'T' or 't', op( A ) = A**T. +*> +*> TRANSA = 'C' or 'c', op( A ) = A**H. +*> \endverbatim +*> +*> \param[in] TRANSB +*> \verbatim +*> TRANSB is CHARACTER*1 +*> On entry, TRANSB specifies the form of op( B ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSB = 'N' or 'n', op( B ) = B. +*> +*> TRANSB = 'T' or 't', op( B ) = B**T. +*> +*> TRANSB = 'C' or 'c', op( B ) = B**H. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of rows and columns of +*> the matrix C, the number of columns of op(B) and the number +*> of rows of op(A). N must be at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry, K specifies the number of columns of the matrix +*> op( A ) and the number of rows of the matrix op( B ). K must +*> be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX. +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX array, dimension ( LDA, ka ), where ka is +*> k when TRANSA = 'N' or 'n', and is n otherwise. +*> Before entry with TRANSA = 'N' or 'n', the leading n by k +*> part of the array A must contain the matrix A, otherwise +*> the leading k by m part of the array A must contain the +*> matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When TRANSA = 'N' or 'n' then +*> LDA must be at least max( 1, n ), otherwise LDA must be at +*> least max( 1, k ). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is COMPLEX array, dimension ( LDB, kb ), where kb is +*> n when TRANSB = 'N' or 'n', and is k otherwise. +*> Before entry with TRANSB = 'N' or 'n', the leading k by n +*> part of the array B must contain the matrix B, otherwise +*> the leading n by k part of the array B must contain the +*> matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. When TRANSB = 'N' or 'n' then +*> LDB must be at least max( 1, k ), otherwise LDB must be at +*> least max( 1, n ). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is COMPLEX. +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then C need not be set on input. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX array, dimension ( LDC, N ) +*> Before entry, the leading n by n part of the array C must +*> contain the matrix C, except when beta is zero, in which +*> case C need not be set on entry. +*> On exit, the upper or lower triangular part of the matrix +*> C is overwritten by the n by n matrix +*> ( alpha*op( A )*op( B ) + beta*C ). +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> On entry, LDC specifies the first dimension of C as declared +*> in the calling (sub) program. LDC must be at least +*> max( 1, n ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Martin Koehler +* +*> \ingroup gemmtr +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> -- Written on 19-July-2023. +*> Martin Koehler, MPI Magdeburg +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CGEMMTR(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB, + + BETA,C,LDC) + IMPLICIT NONE +* +* -- Reference BLAS level3 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX ALPHA,BETA + INTEGER K,LDA,LDB,LDC,N + CHARACTER TRANSA,TRANSB,UPLO +* .. +* .. Array Arguments .. + COMPLEX A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC CONJG,MAX +* .. +* .. Local Scalars .. + COMPLEX TEMP + INTEGER I,INFO,J,L,NROWA,NROWB,ISTART, ISTOP + LOGICAL CONJA,CONJB,NOTA,NOTB,UPPER +* .. +* .. Parameters .. + COMPLEX ONE + PARAMETER (ONE= (1.0E+0,0.0E+0)) + COMPLEX ZERO + PARAMETER (ZERO= (0.0E+0,0.0E+0)) +* .. +* +* Set NOTA and NOTB as true if A and B respectively are not +* conjugated or transposed, set CONJA and CONJB as true if A and +* B respectively are to be transposed but not conjugated and set +* NROWA and NROWB as the number of rows of A and B respectively. +* + NOTA = LSAME(TRANSA,'N') + NOTB = LSAME(TRANSB,'N') + CONJA = LSAME(TRANSA,'C') + CONJB = LSAME(TRANSB,'C') + IF (NOTA) THEN + NROWA = N + ELSE + NROWA = K + END IF + IF (NOTB) THEN + NROWB = K + ELSE + NROWB = N + END IF + UPPER = LSAME(UPLO, 'U') + +* +* Test the input parameters. +* + INFO = 0 + IF ((.NOT. UPPER) .AND. (.NOT. LSAME(UPLO, 'L'))) THEN + INFO = 1 + ELSE IF ((.NOT.NOTA) .AND. (.NOT.CONJA) .AND. + + (.NOT.LSAME(TRANSA,'T'))) THEN + INFO = 2 + ELSE IF ((.NOT.NOTB) .AND. (.NOT.CONJB) .AND. + + (.NOT.LSAME(TRANSB,'T'))) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (K.LT.0) THEN + INFO = 5 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 8 + ELSE IF (LDB.LT.MAX(1,NROWB)) THEN + INFO = 10 + ELSE IF (LDC.LT.MAX(1,N)) THEN + INFO = 13 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('CGEMMTR',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (N.EQ.0) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + IF (BETA.EQ.ZERO) THEN + DO 20 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + DO 10 I = ISTART, ISTOP + C(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + DO 30 I = ISTART, ISTOP + C(I,J) = BETA*C(I,J) + 30 CONTINUE + 40 CONTINUE + END IF + RETURN + END IF +* +* Start the operations. +* + IF (NOTB) THEN + IF (NOTA) THEN +* +* Form C := alpha*A*B + beta*C. +* + DO 90 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + IF (BETA.EQ.ZERO) THEN + DO 50 I = ISTART, ISTOP + C(I,J) = ZERO + 50 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 60 I = ISTART, ISTOP + C(I,J) = BETA*C(I,J) + 60 CONTINUE + END IF + DO 80 L = 1,K + TEMP = ALPHA*B(L,J) + DO 70 I = ISTART, ISTOP + C(I,J) = C(I,J) + TEMP*A(I,L) + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + ELSE IF (CONJA) THEN +* +* Form C := alpha*A**H*B + beta*C. +* + DO 120 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + DO 110 I = ISTART, ISTOP + TEMP = ZERO + DO 100 L = 1,K + TEMP = TEMP + CONJG(A(L,I))*B(L,J) + 100 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 110 CONTINUE + 120 CONTINUE + ELSE +* +* Form C := alpha*A**T*B + beta*C +* + DO 150 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + DO 140 I = ISTART, ISTOP + TEMP = ZERO + DO 130 L = 1,K + TEMP = TEMP + A(L,I)*B(L,J) + 130 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 140 CONTINUE + 150 CONTINUE + END IF + ELSE IF (NOTA) THEN + IF (CONJB) THEN +* +* Form C := alpha*A*B**H + beta*C. +* + DO 200 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + IF (BETA.EQ.ZERO) THEN + DO 160 I = ISTART,ISTOP + C(I,J) = ZERO + 160 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 170 I = ISTART, ISTOP + C(I,J) = BETA*C(I,J) + 170 CONTINUE + END IF + DO 190 L = 1,K + TEMP = ALPHA*CONJG(B(J,L)) + DO 180 I = ISTART, ISTOP + C(I,J) = C(I,J) + TEMP*A(I,L) + 180 CONTINUE + 190 CONTINUE + 200 CONTINUE + ELSE +* +* Form C := alpha*A*B**T + beta*C +* + DO 250 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + IF (BETA.EQ.ZERO) THEN + DO 210 I = ISTART, ISTOP + C(I,J) = ZERO + 210 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 220 I = ISTART, ISTOP + C(I,J) = BETA*C(I,J) + 220 CONTINUE + END IF + DO 240 L = 1,K + TEMP = ALPHA*B(J,L) + DO 230 I = ISTART, ISTOP + C(I,J) = C(I,J) + TEMP*A(I,L) + 230 CONTINUE + 240 CONTINUE + 250 CONTINUE + END IF + ELSE IF (CONJA) THEN + IF (CONJB) THEN +* +* Form C := alpha*A**H*B**H + beta*C. +* + DO 280 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + DO 270 I = ISTART, ISTOP + TEMP = ZERO + DO 260 L = 1,K + TEMP = TEMP + CONJG(A(L,I))*CONJG(B(J,L)) + 260 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 270 CONTINUE + 280 CONTINUE + ELSE +* +* Form C := alpha*A**H*B**T + beta*C +* + DO 310 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + DO 300 I = ISTART, ISTOP + TEMP = ZERO + DO 290 L = 1,K + TEMP = TEMP + CONJG(A(L,I))*B(J,L) + 290 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 300 CONTINUE + 310 CONTINUE + END IF + ELSE + IF (CONJB) THEN +* +* Form C := alpha*A**T*B**H + beta*C +* + DO 340 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + DO 330 I = ISTART, ISTOP + TEMP = ZERO + DO 320 L = 1,K + TEMP = TEMP + A(L,I)*CONJG(B(J,L)) + 320 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 330 CONTINUE + 340 CONTINUE + ELSE +* +* Form C := alpha*A**T*B**T + beta*C +* + DO 370 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + DO 360 I = ISTART, ISTOP + TEMP = ZERO + DO 350 L = 1,K + TEMP = TEMP + A(L,I)*B(J,L) + 350 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 360 CONTINUE + 370 CONTINUE + END IF + END IF +* + RETURN +* +* End of CGEMMTR +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/cgemv.f b/fortran_implementation/external_libraries/BLAS/SRC/cgemv.f new file mode 100644 index 0000000..b9fd846 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/cgemv.f @@ -0,0 +1,349 @@ +*> \brief \b CGEMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* .. Scalar Arguments .. +* COMPLEX ALPHA,BETA +* INTEGER INCX,INCY,LDA,M,N +* CHARACTER TRANS +* .. +* .. Array Arguments .. +* COMPLEX A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CGEMV performs one of the matrix-vector operations +*> +*> y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, or +*> +*> y := alpha*A**H*x + beta*y, +*> +*> where alpha and beta are scalars, x and y are vectors and A is an +*> m by n matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the operation to be performed as +*> follows: +*> +*> TRANS = 'N' or 'n' y := alpha*A*x + beta*y. +*> +*> TRANS = 'T' or 't' y := alpha*A**T*x + beta*y. +*> +*> TRANS = 'C' or 'c' y := alpha*A**H*x + beta*y. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix A. +*> M must be at least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX array, dimension ( LDA, N ) +*> Before entry, the leading m by n part of the array A must +*> contain the matrix of coefficients. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> max( 1, m ). +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is COMPLEX array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' +*> and at least +*> ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. +*> Before entry, the incremented array X must contain the +*> vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is COMPLEX +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then Y need not be set on input. +*> \endverbatim +*> +*> \param[in,out] Y +*> \verbatim +*> Y is COMPLEX array, dimension at least +*> ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' +*> and at least +*> ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. +*> Before entry with BETA non-zero, the incremented array Y +*> must contain the vector y. On exit, Y is overwritten by the +*> updated vector y. +*> If either m or n is zero, then Y not referenced and the function +*> performs a quick return. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> Y. INCY must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup gemv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> The vector and matrix arguments are not referenced when N = 0, or M = 0 +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX ALPHA,BETA + INTEGER INCX,INCY,LDA,M,N + CHARACTER TRANS +* .. +* .. Array Arguments .. + COMPLEX A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX ONE + PARAMETER (ONE= (1.0E+0,0.0E+0)) + COMPLEX ZERO + PARAMETER (ZERO= (0.0E+0,0.0E+0)) +* .. +* .. Local Scalars .. + COMPLEX TEMP + INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY,LENX,LENY + LOGICAL NOCONJ +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC CONJG,MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. + + .NOT.LSAME(TRANS,'C')) THEN + INFO = 1 + ELSE IF (M.LT.0) THEN + INFO = 2 + ELSE IF (N.LT.0) THEN + INFO = 3 + ELSE IF (LDA.LT.MAX(1,M)) THEN + INFO = 6 + ELSE IF (INCX.EQ.0) THEN + INFO = 8 + ELSE IF (INCY.EQ.0) THEN + INFO = 11 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('CGEMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. + + ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN +* + NOCONJ = LSAME(TRANS,'T') +* +* Set LENX and LENY, the lengths of the vectors x and y, and set +* up the start points in X and Y. +* + IF (LSAME(TRANS,'N')) THEN + LENX = N + LENY = M + ELSE + LENX = M + LENY = N + END IF + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (LENX-1)*INCX + END IF + IF (INCY.GT.0) THEN + KY = 1 + ELSE + KY = 1 - (LENY-1)*INCY + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* +* First form y := beta*y. +* + IF (BETA.NE.ONE) THEN + IF (INCY.EQ.1) THEN + IF (BETA.EQ.ZERO) THEN + DO 10 I = 1,LENY + Y(I) = ZERO + 10 CONTINUE + ELSE + DO 20 I = 1,LENY + Y(I) = BETA*Y(I) + 20 CONTINUE + END IF + ELSE + IY = KY + IF (BETA.EQ.ZERO) THEN + DO 30 I = 1,LENY + Y(IY) = ZERO + IY = IY + INCY + 30 CONTINUE + ELSE + DO 40 I = 1,LENY + Y(IY) = BETA*Y(IY) + IY = IY + INCY + 40 CONTINUE + END IF + END IF + END IF + IF (ALPHA.EQ.ZERO) RETURN + IF (LSAME(TRANS,'N')) THEN +* +* Form y := alpha*A*x + y. +* + JX = KX + IF (INCY.EQ.1) THEN + DO 60 J = 1,N + TEMP = ALPHA*X(JX) + DO 50 I = 1,M + Y(I) = Y(I) + TEMP*A(I,J) + 50 CONTINUE + JX = JX + INCX + 60 CONTINUE + ELSE + DO 80 J = 1,N + TEMP = ALPHA*X(JX) + IY = KY + DO 70 I = 1,M + Y(IY) = Y(IY) + TEMP*A(I,J) + IY = IY + INCY + 70 CONTINUE + JX = JX + INCX + 80 CONTINUE + END IF + ELSE +* +* Form y := alpha*A**T*x + y or y := alpha*A**H*x + y. +* + JY = KY + IF (INCX.EQ.1) THEN + DO 110 J = 1,N + TEMP = ZERO + IF (NOCONJ) THEN + DO 90 I = 1,M + TEMP = TEMP + A(I,J)*X(I) + 90 CONTINUE + ELSE + DO 100 I = 1,M + TEMP = TEMP + CONJG(A(I,J))*X(I) + 100 CONTINUE + END IF + Y(JY) = Y(JY) + ALPHA*TEMP + JY = JY + INCY + 110 CONTINUE + ELSE + DO 140 J = 1,N + TEMP = ZERO + IX = KX + IF (NOCONJ) THEN + DO 120 I = 1,M + TEMP = TEMP + A(I,J)*X(IX) + IX = IX + INCX + 120 CONTINUE + ELSE + DO 130 I = 1,M + TEMP = TEMP + CONJG(A(I,J))*X(IX) + IX = IX + INCX + 130 CONTINUE + END IF + Y(JY) = Y(JY) + ALPHA*TEMP + JY = JY + INCY + 140 CONTINUE + END IF + END IF +* + RETURN +* +* End of CGEMV +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/cgerc.f b/fortran_implementation/external_libraries/BLAS/SRC/cgerc.f new file mode 100644 index 0000000..ed60613 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/cgerc.f @@ -0,0 +1,224 @@ +*> \brief \b CGERC +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CGERC(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) +* +* .. Scalar Arguments .. +* COMPLEX ALPHA +* INTEGER INCX,INCY,LDA,M,N +* .. +* .. Array Arguments .. +* COMPLEX A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CGERC performs the rank 1 operation +*> +*> A := alpha*x*y**H + A, +*> +*> where alpha is a scalar, x is an m element vector, y is an n element +*> vector and A is an m by n matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix A. +*> M must be at least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is COMPLEX array, dimension at least +*> ( 1 + ( m - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the m +*> element vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in] Y +*> \verbatim +*> Y is COMPLEX array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCY ) ). +*> Before entry, the incremented array Y must contain the n +*> element vector y. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> Y. INCY must not be zero. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension ( LDA, N ) +*> Before entry, the leading m by n part of the array A must +*> contain the matrix of coefficients. On exit, A is +*> overwritten by the updated matrix. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> max( 1, m ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup ger +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CGERC(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX ALPHA + INTEGER INCX,INCY,LDA,M,N +* .. +* .. Array Arguments .. + COMPLEX A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX ZERO + PARAMETER (ZERO= (0.0E+0,0.0E+0)) +* .. +* .. Local Scalars .. + COMPLEX TEMP + INTEGER I,INFO,IX,J,JY,KX +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC CONJG,MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (M.LT.0) THEN + INFO = 1 + ELSE IF (N.LT.0) THEN + INFO = 2 + ELSE IF (INCX.EQ.0) THEN + INFO = 5 + ELSE IF (INCY.EQ.0) THEN + INFO = 7 + ELSE IF (LDA.LT.MAX(1,M)) THEN + INFO = 9 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('CGERC ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* + IF (INCY.GT.0) THEN + JY = 1 + ELSE + JY = 1 - (N-1)*INCY + END IF + IF (INCX.EQ.1) THEN + DO 20 J = 1,N + IF (Y(JY).NE.ZERO) THEN + TEMP = ALPHA*CONJG(Y(JY)) + DO 10 I = 1,M + A(I,J) = A(I,J) + X(I)*TEMP + 10 CONTINUE + END IF + JY = JY + INCY + 20 CONTINUE + ELSE + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (M-1)*INCX + END IF + DO 40 J = 1,N + IF (Y(JY).NE.ZERO) THEN + TEMP = ALPHA*CONJG(Y(JY)) + IX = KX + DO 30 I = 1,M + A(I,J) = A(I,J) + X(IX)*TEMP + IX = IX + INCX + 30 CONTINUE + END IF + JY = JY + INCY + 40 CONTINUE + END IF +* + RETURN +* +* End of CGERC +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/cgeru.f b/fortran_implementation/external_libraries/BLAS/SRC/cgeru.f new file mode 100644 index 0000000..4802cef --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/cgeru.f @@ -0,0 +1,224 @@ +*> \brief \b CGERU +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CGERU(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) +* +* .. Scalar Arguments .. +* COMPLEX ALPHA +* INTEGER INCX,INCY,LDA,M,N +* .. +* .. Array Arguments .. +* COMPLEX A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CGERU performs the rank 1 operation +*> +*> A := alpha*x*y**T + A, +*> +*> where alpha is a scalar, x is an m element vector, y is an n element +*> vector and A is an m by n matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix A. +*> M must be at least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is COMPLEX array, dimension at least +*> ( 1 + ( m - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the m +*> element vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in] Y +*> \verbatim +*> Y is COMPLEX array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCY ) ). +*> Before entry, the incremented array Y must contain the n +*> element vector y. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> Y. INCY must not be zero. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension ( LDA, N ) +*> Before entry, the leading m by n part of the array A must +*> contain the matrix of coefficients. On exit, A is +*> overwritten by the updated matrix. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> max( 1, m ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup ger +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CGERU(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX ALPHA + INTEGER INCX,INCY,LDA,M,N +* .. +* .. Array Arguments .. + COMPLEX A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX ZERO + PARAMETER (ZERO= (0.0E+0,0.0E+0)) +* .. +* .. Local Scalars .. + COMPLEX TEMP + INTEGER I,INFO,IX,J,JY,KX +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (M.LT.0) THEN + INFO = 1 + ELSE IF (N.LT.0) THEN + INFO = 2 + ELSE IF (INCX.EQ.0) THEN + INFO = 5 + ELSE IF (INCY.EQ.0) THEN + INFO = 7 + ELSE IF (LDA.LT.MAX(1,M)) THEN + INFO = 9 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('CGERU ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* + IF (INCY.GT.0) THEN + JY = 1 + ELSE + JY = 1 - (N-1)*INCY + END IF + IF (INCX.EQ.1) THEN + DO 20 J = 1,N + IF (Y(JY).NE.ZERO) THEN + TEMP = ALPHA*Y(JY) + DO 10 I = 1,M + A(I,J) = A(I,J) + X(I)*TEMP + 10 CONTINUE + END IF + JY = JY + INCY + 20 CONTINUE + ELSE + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (M-1)*INCX + END IF + DO 40 J = 1,N + IF (Y(JY).NE.ZERO) THEN + TEMP = ALPHA*Y(JY) + IX = KX + DO 30 I = 1,M + A(I,J) = A(I,J) + X(IX)*TEMP + IX = IX + INCX + 30 CONTINUE + END IF + JY = JY + INCY + 40 CONTINUE + END IF +* + RETURN +* +* End of CGERU +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/chbmv.f b/fortran_implementation/external_libraries/BLAS/SRC/chbmv.f new file mode 100644 index 0000000..afa447c --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/chbmv.f @@ -0,0 +1,377 @@ +*> \brief \b CHBMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CHBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* .. Scalar Arguments .. +* COMPLEX ALPHA,BETA +* INTEGER INCX,INCY,K,LDA,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* COMPLEX A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CHBMV performs the matrix-vector operation +*> +*> y := alpha*A*x + beta*y, +*> +*> where alpha and beta are scalars, x and y are n element vectors and +*> A is an n by n hermitian band matrix, with k super-diagonals. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the band matrix A is being supplied as +*> follows: +*> +*> UPLO = 'U' or 'u' The upper triangular part of A is +*> being supplied. +*> +*> UPLO = 'L' or 'l' The lower triangular part of A is +*> being supplied. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry, K specifies the number of super-diagonals of the +*> matrix A. K must satisfy 0 .le. K. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX array, dimension ( LDA, N ) +*> Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) +*> by n part of the array A must contain the upper triangular +*> band part of the hermitian matrix, supplied column by +*> column, with the leading diagonal of the matrix in row +*> ( k + 1 ) of the array, the first super-diagonal starting at +*> position 2 in row k, and so on. The top left k by k triangle +*> of the array A is not referenced. +*> The following program segment will transfer the upper +*> triangular part of a hermitian band matrix from conventional +*> full matrix storage to band storage: +*> +*> DO 20, J = 1, N +*> M = K + 1 - J +*> DO 10, I = MAX( 1, J - K ), J +*> A( M + I, J ) = matrix( I, J ) +*> 10 CONTINUE +*> 20 CONTINUE +*> +*> Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) +*> by n part of the array A must contain the lower triangular +*> band part of the hermitian matrix, supplied column by +*> column, with the leading diagonal of the matrix in row 1 of +*> the array, the first sub-diagonal starting at position 1 in +*> row 2, and so on. The bottom right k by k triangle of the +*> array A is not referenced. +*> The following program segment will transfer the lower +*> triangular part of a hermitian band matrix from conventional +*> full matrix storage to band storage: +*> +*> DO 20, J = 1, N +*> M = 1 - J +*> DO 10, I = J, MIN( N, J + K ) +*> A( M + I, J ) = matrix( I, J ) +*> 10 CONTINUE +*> 20 CONTINUE +*> +*> Note that the imaginary parts of the diagonal elements need +*> not be set and are assumed to be zero. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> ( k + 1 ). +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is COMPLEX array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the +*> vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is COMPLEX +*> On entry, BETA specifies the scalar beta. +*> \endverbatim +*> +*> \param[in,out] Y +*> \verbatim +*> Y is COMPLEX array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCY ) ). +*> Before entry, the incremented array Y must contain the +*> vector y. On exit, Y is overwritten by the updated vector y. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> Y. INCY must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup hbmv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> The vector and matrix arguments are not referenced when N = 0, or M = 0 +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CHBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX ALPHA,BETA + INTEGER INCX,INCY,K,LDA,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + COMPLEX A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX ONE + PARAMETER (ONE= (1.0E+0,0.0E+0)) + COMPLEX ZERO + PARAMETER (ZERO= (0.0E+0,0.0E+0)) +* .. +* .. Local Scalars .. + COMPLEX TEMP1,TEMP2 + INTEGER I,INFO,IX,IY,J,JX,JY,KPLUS1,KX,KY,L +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC CONJG,MAX,MIN,REAL +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (N.LT.0) THEN + INFO = 2 + ELSE IF (K.LT.0) THEN + INFO = 3 + ELSE IF (LDA.LT. (K+1)) THEN + INFO = 6 + ELSE IF (INCX.EQ.0) THEN + INFO = 8 + ELSE IF (INCY.EQ.0) THEN + INFO = 11 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('CHBMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN +* +* Set up the start points in X and Y. +* + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (N-1)*INCX + END IF + IF (INCY.GT.0) THEN + KY = 1 + ELSE + KY = 1 - (N-1)*INCY + END IF +* +* Start the operations. In this version the elements of the array A +* are accessed sequentially with one pass through A. +* +* First form y := beta*y. +* + IF (BETA.NE.ONE) THEN + IF (INCY.EQ.1) THEN + IF (BETA.EQ.ZERO) THEN + DO 10 I = 1,N + Y(I) = ZERO + 10 CONTINUE + ELSE + DO 20 I = 1,N + Y(I) = BETA*Y(I) + 20 CONTINUE + END IF + ELSE + IY = KY + IF (BETA.EQ.ZERO) THEN + DO 30 I = 1,N + Y(IY) = ZERO + IY = IY + INCY + 30 CONTINUE + ELSE + DO 40 I = 1,N + Y(IY) = BETA*Y(IY) + IY = IY + INCY + 40 CONTINUE + END IF + END IF + END IF + IF (ALPHA.EQ.ZERO) RETURN + IF (LSAME(UPLO,'U')) THEN +* +* Form y when upper triangle of A is stored. +* + KPLUS1 = K + 1 + IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN + DO 60 J = 1,N + TEMP1 = ALPHA*X(J) + TEMP2 = ZERO + L = KPLUS1 - J + DO 50 I = MAX(1,J-K),J - 1 + Y(I) = Y(I) + TEMP1*A(L+I,J) + TEMP2 = TEMP2 + CONJG(A(L+I,J))*X(I) + 50 CONTINUE + Y(J) = Y(J) + TEMP1*REAL(A(KPLUS1,J)) + ALPHA*TEMP2 + 60 CONTINUE + ELSE + JX = KX + JY = KY + DO 80 J = 1,N + TEMP1 = ALPHA*X(JX) + TEMP2 = ZERO + IX = KX + IY = KY + L = KPLUS1 - J + DO 70 I = MAX(1,J-K),J - 1 + Y(IY) = Y(IY) + TEMP1*A(L+I,J) + TEMP2 = TEMP2 + CONJG(A(L+I,J))*X(IX) + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + Y(JY) = Y(JY) + TEMP1*REAL(A(KPLUS1,J)) + ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + IF (J.GT.K) THEN + KX = KX + INCX + KY = KY + INCY + END IF + 80 CONTINUE + END IF + ELSE +* +* Form y when lower triangle of A is stored. +* + IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN + DO 100 J = 1,N + TEMP1 = ALPHA*X(J) + TEMP2 = ZERO + Y(J) = Y(J) + TEMP1*REAL(A(1,J)) + L = 1 - J + DO 90 I = J + 1,MIN(N,J+K) + Y(I) = Y(I) + TEMP1*A(L+I,J) + TEMP2 = TEMP2 + CONJG(A(L+I,J))*X(I) + 90 CONTINUE + Y(J) = Y(J) + ALPHA*TEMP2 + 100 CONTINUE + ELSE + JX = KX + JY = KY + DO 120 J = 1,N + TEMP1 = ALPHA*X(JX) + TEMP2 = ZERO + Y(JY) = Y(JY) + TEMP1*REAL(A(1,J)) + L = 1 - J + IX = JX + IY = JY + DO 110 I = J + 1,MIN(N,J+K) + IX = IX + INCX + IY = IY + INCY + Y(IY) = Y(IY) + TEMP1*A(L+I,J) + TEMP2 = TEMP2 + CONJG(A(L+I,J))*X(IX) + 110 CONTINUE + Y(JY) = Y(JY) + ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + 120 CONTINUE + END IF + END IF +* + RETURN +* +* End of CHBMV +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/chemm.f b/fortran_implementation/external_libraries/BLAS/SRC/chemm.f new file mode 100644 index 0000000..c9a2c3a --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/chemm.f @@ -0,0 +1,370 @@ +*> \brief \b CHEMM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CHEMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* .. Scalar Arguments .. +* COMPLEX ALPHA,BETA +* INTEGER LDA,LDB,LDC,M,N +* CHARACTER SIDE,UPLO +* .. +* .. Array Arguments .. +* COMPLEX A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CHEMM performs one of the matrix-matrix operations +*> +*> C := alpha*A*B + beta*C, +*> +*> or +*> +*> C := alpha*B*A + beta*C, +*> +*> where alpha and beta are scalars, A is an hermitian matrix and B and +*> C are m by n matrices. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> On entry, SIDE specifies whether the hermitian matrix A +*> appears on the left or right in the operation as follows: +*> +*> SIDE = 'L' or 'l' C := alpha*A*B + beta*C, +*> +*> SIDE = 'R' or 'r' C := alpha*B*A + beta*C, +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the hermitian matrix A is to be +*> referenced as follows: +*> +*> UPLO = 'U' or 'u' Only the upper triangular part of the +*> hermitian matrix is to be referenced. +*> +*> UPLO = 'L' or 'l' Only the lower triangular part of the +*> hermitian matrix is to be referenced. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix C. +*> M must be at least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of the matrix C. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX array, dimension ( LDA, ka ), where ka is +*> m when SIDE = 'L' or 'l' and is n otherwise. +*> Before entry with SIDE = 'L' or 'l', the m by m part of +*> the array A must contain the hermitian matrix, such that +*> when UPLO = 'U' or 'u', the leading m by m upper triangular +*> part of the array A must contain the upper triangular part +*> of the hermitian matrix and the strictly lower triangular +*> part of A is not referenced, and when UPLO = 'L' or 'l', +*> the leading m by m lower triangular part of the array A +*> must contain the lower triangular part of the hermitian +*> matrix and the strictly upper triangular part of A is not +*> referenced. +*> Before entry with SIDE = 'R' or 'r', the n by n part of +*> the array A must contain the hermitian matrix, such that +*> when UPLO = 'U' or 'u', the leading n by n upper triangular +*> part of the array A must contain the upper triangular part +*> of the hermitian matrix and the strictly lower triangular +*> part of A is not referenced, and when UPLO = 'L' or 'l', +*> the leading n by n lower triangular part of the array A +*> must contain the lower triangular part of the hermitian +*> matrix and the strictly upper triangular part of A is not +*> referenced. +*> Note that the imaginary parts of the diagonal elements need +*> not be set, they are assumed to be zero. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When SIDE = 'L' or 'l' then +*> LDA must be at least max( 1, m ), otherwise LDA must be at +*> least max( 1, n ). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is COMPLEX array, dimension ( LDB, N ) +*> Before entry, the leading m by n part of the array B must +*> contain the matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. LDB must be at least +*> max( 1, m ). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is COMPLEX +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then C need not be set on input. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX array, dimension ( LDC, N ) +*> Before entry, the leading m by n part of the array C must +*> contain the matrix C, except when beta is zero, in which +*> case C need not be set on entry. +*> On exit, the array C is overwritten by the m by n updated +*> matrix. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> On entry, LDC specifies the first dimension of C as declared +*> in the calling (sub) program. LDC must be at least +*> max( 1, m ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup hemm +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> -- Written on 8-February-1989. +*> Jack Dongarra, Argonne National Laboratory. +*> Iain Duff, AERE Harwell. +*> Jeremy Du Croz, Numerical Algorithms Group Ltd. +*> Sven Hammarling, Numerical Algorithms Group Ltd. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CHEMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* -- Reference BLAS level3 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX ALPHA,BETA + INTEGER LDA,LDB,LDC,M,N + CHARACTER SIDE,UPLO +* .. +* .. Array Arguments .. + COMPLEX A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC CONJG,MAX,REAL +* .. +* .. Local Scalars .. + COMPLEX TEMP1,TEMP2 + INTEGER I,INFO,J,K,NROWA + LOGICAL UPPER +* .. +* .. Parameters .. + COMPLEX ONE + PARAMETER (ONE= (1.0E+0,0.0E+0)) + COMPLEX ZERO + PARAMETER (ZERO= (0.0E+0,0.0E+0)) +* .. +* +* Set NROWA as the number of rows of A. +* + IF (LSAME(SIDE,'L')) THEN + NROWA = M + ELSE + NROWA = N + END IF + UPPER = LSAME(UPLO,'U') +* +* Test the input parameters. +* + INFO = 0 + IF ((.NOT.LSAME(SIDE,'L')) .AND. + + (.NOT.LSAME(SIDE,'R'))) THEN + INFO = 1 + ELSE IF ((.NOT.UPPER) .AND. + + (.NOT.LSAME(UPLO,'L'))) THEN + INFO = 2 + ELSE IF (M.LT.0) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 7 + ELSE IF (LDB.LT.MAX(1,M)) THEN + INFO = 9 + ELSE IF (LDC.LT.MAX(1,M)) THEN + INFO = 12 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('CHEMM ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. + + ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + IF (BETA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,M + C(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1,N + DO 30 I = 1,M + C(I,J) = BETA*C(I,J) + 30 CONTINUE + 40 CONTINUE + END IF + RETURN + END IF +* +* Start the operations. +* + IF (LSAME(SIDE,'L')) THEN +* +* Form C := alpha*A*B + beta*C. +* + IF (UPPER) THEN + DO 70 J = 1,N + DO 60 I = 1,M + TEMP1 = ALPHA*B(I,J) + TEMP2 = ZERO + DO 50 K = 1,I - 1 + C(K,J) = C(K,J) + TEMP1*A(K,I) + TEMP2 = TEMP2 + B(K,J)*CONJG(A(K,I)) + 50 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = TEMP1*REAL(A(I,I)) + ALPHA*TEMP2 + ELSE + C(I,J) = BETA*C(I,J) + TEMP1*REAL(A(I,I)) + + + ALPHA*TEMP2 + END IF + 60 CONTINUE + 70 CONTINUE + ELSE + DO 100 J = 1,N + DO 90 I = M,1,-1 + TEMP1 = ALPHA*B(I,J) + TEMP2 = ZERO + DO 80 K = I + 1,M + C(K,J) = C(K,J) + TEMP1*A(K,I) + TEMP2 = TEMP2 + B(K,J)*CONJG(A(K,I)) + 80 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = TEMP1*REAL(A(I,I)) + ALPHA*TEMP2 + ELSE + C(I,J) = BETA*C(I,J) + TEMP1*REAL(A(I,I)) + + + ALPHA*TEMP2 + END IF + 90 CONTINUE + 100 CONTINUE + END IF + ELSE +* +* Form C := alpha*B*A + beta*C. +* + DO 170 J = 1,N + TEMP1 = ALPHA*REAL(A(J,J)) + IF (BETA.EQ.ZERO) THEN + DO 110 I = 1,M + C(I,J) = TEMP1*B(I,J) + 110 CONTINUE + ELSE + DO 120 I = 1,M + C(I,J) = BETA*C(I,J) + TEMP1*B(I,J) + 120 CONTINUE + END IF + DO 140 K = 1,J - 1 + IF (UPPER) THEN + TEMP1 = ALPHA*A(K,J) + ELSE + TEMP1 = ALPHA*CONJG(A(J,K)) + END IF + DO 130 I = 1,M + C(I,J) = C(I,J) + TEMP1*B(I,K) + 130 CONTINUE + 140 CONTINUE + DO 160 K = J + 1,N + IF (UPPER) THEN + TEMP1 = ALPHA*CONJG(A(J,K)) + ELSE + TEMP1 = ALPHA*A(K,J) + END IF + DO 150 I = 1,M + C(I,J) = C(I,J) + TEMP1*B(I,K) + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE + END IF +* + RETURN +* +* End of CHEMM +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/chemv.f b/fortran_implementation/external_libraries/BLAS/SRC/chemv.f new file mode 100644 index 0000000..2b8866b --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/chemv.f @@ -0,0 +1,334 @@ +*> \brief \b CHEMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CHEMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* .. Scalar Arguments .. +* COMPLEX ALPHA,BETA +* INTEGER INCX,INCY,LDA,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* COMPLEX A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CHEMV performs the matrix-vector operation +*> +*> y := alpha*A*x + beta*y, +*> +*> where alpha and beta are scalars, x and y are n element vectors and +*> A is an n by n hermitian matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the array A is to be referenced as +*> follows: +*> +*> UPLO = 'U' or 'u' Only the upper triangular part of A +*> is to be referenced. +*> +*> UPLO = 'L' or 'l' Only the lower triangular part of A +*> is to be referenced. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX array, dimension ( LDA, N ) +*> Before entry with UPLO = 'U' or 'u', the leading n by n +*> upper triangular part of the array A must contain the upper +*> triangular part of the hermitian matrix and the strictly +*> lower triangular part of A is not referenced. +*> Before entry with UPLO = 'L' or 'l', the leading n by n +*> lower triangular part of the array A must contain the lower +*> triangular part of the hermitian matrix and the strictly +*> upper triangular part of A is not referenced. +*> Note that the imaginary parts of the diagonal elements need +*> not be set and are assumed to be zero. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> max( 1, n ). +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is COMPLEX array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is COMPLEX +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then Y need not be set on input. +*> \endverbatim +*> +*> \param[in,out] Y +*> \verbatim +*> Y is COMPLEX array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCY ) ). +*> Before entry, the incremented array Y must contain the n +*> element vector y. On exit, Y is overwritten by the updated +*> vector y. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> Y. INCY must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup hemv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> The vector and matrix arguments are not referenced when N = 0, or M = 0 +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CHEMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX ALPHA,BETA + INTEGER INCX,INCY,LDA,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + COMPLEX A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX ONE + PARAMETER (ONE= (1.0E+0,0.0E+0)) + COMPLEX ZERO + PARAMETER (ZERO= (0.0E+0,0.0E+0)) +* .. +* .. Local Scalars .. + COMPLEX TEMP1,TEMP2 + INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC CONJG,MAX,REAL +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (N.LT.0) THEN + INFO = 2 + ELSE IF (LDA.LT.MAX(1,N)) THEN + INFO = 5 + ELSE IF (INCX.EQ.0) THEN + INFO = 7 + ELSE IF (INCY.EQ.0) THEN + INFO = 10 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('CHEMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN +* +* Set up the start points in X and Y. +* + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (N-1)*INCX + END IF + IF (INCY.GT.0) THEN + KY = 1 + ELSE + KY = 1 - (N-1)*INCY + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through the triangular part +* of A. +* +* First form y := beta*y. +* + IF (BETA.NE.ONE) THEN + IF (INCY.EQ.1) THEN + IF (BETA.EQ.ZERO) THEN + DO 10 I = 1,N + Y(I) = ZERO + 10 CONTINUE + ELSE + DO 20 I = 1,N + Y(I) = BETA*Y(I) + 20 CONTINUE + END IF + ELSE + IY = KY + IF (BETA.EQ.ZERO) THEN + DO 30 I = 1,N + Y(IY) = ZERO + IY = IY + INCY + 30 CONTINUE + ELSE + DO 40 I = 1,N + Y(IY) = BETA*Y(IY) + IY = IY + INCY + 40 CONTINUE + END IF + END IF + END IF + IF (ALPHA.EQ.ZERO) RETURN + IF (LSAME(UPLO,'U')) THEN +* +* Form y when A is stored in upper triangle. +* + IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN + DO 60 J = 1,N + TEMP1 = ALPHA*X(J) + TEMP2 = ZERO + DO 50 I = 1,J - 1 + Y(I) = Y(I) + TEMP1*A(I,J) + TEMP2 = TEMP2 + CONJG(A(I,J))*X(I) + 50 CONTINUE + Y(J) = Y(J) + TEMP1*REAL(A(J,J)) + ALPHA*TEMP2 + 60 CONTINUE + ELSE + JX = KX + JY = KY + DO 80 J = 1,N + TEMP1 = ALPHA*X(JX) + TEMP2 = ZERO + IX = KX + IY = KY + DO 70 I = 1,J - 1 + Y(IY) = Y(IY) + TEMP1*A(I,J) + TEMP2 = TEMP2 + CONJG(A(I,J))*X(IX) + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + Y(JY) = Y(JY) + TEMP1*REAL(A(J,J)) + ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + 80 CONTINUE + END IF + ELSE +* +* Form y when A is stored in lower triangle. +* + IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN + DO 100 J = 1,N + TEMP1 = ALPHA*X(J) + TEMP2 = ZERO + Y(J) = Y(J) + TEMP1*REAL(A(J,J)) + DO 90 I = J + 1,N + Y(I) = Y(I) + TEMP1*A(I,J) + TEMP2 = TEMP2 + CONJG(A(I,J))*X(I) + 90 CONTINUE + Y(J) = Y(J) + ALPHA*TEMP2 + 100 CONTINUE + ELSE + JX = KX + JY = KY + DO 120 J = 1,N + TEMP1 = ALPHA*X(JX) + TEMP2 = ZERO + Y(JY) = Y(JY) + TEMP1*REAL(A(J,J)) + IX = JX + IY = JY + DO 110 I = J + 1,N + IX = IX + INCX + IY = IY + INCY + Y(IY) = Y(IY) + TEMP1*A(I,J) + TEMP2 = TEMP2 + CONJG(A(I,J))*X(IX) + 110 CONTINUE + Y(JY) = Y(JY) + ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + 120 CONTINUE + END IF + END IF +* + RETURN +* +* End of CHEMV +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/cher.f b/fortran_implementation/external_libraries/BLAS/SRC/cher.f new file mode 100644 index 0000000..9bec621 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/cher.f @@ -0,0 +1,275 @@ +*> \brief \b CHER +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CHER(UPLO,N,ALPHA,X,INCX,A,LDA) +* +* .. Scalar Arguments .. +* REAL ALPHA +* INTEGER INCX,LDA,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* COMPLEX A(LDA,*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CHER performs the hermitian rank 1 operation +*> +*> A := alpha*x*x**H + A, +*> +*> where alpha is a real scalar, x is an n element vector and A is an +*> n by n hermitian matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the array A is to be referenced as +*> follows: +*> +*> UPLO = 'U' or 'u' Only the upper triangular part of A +*> is to be referenced. +*> +*> UPLO = 'L' or 'l' Only the lower triangular part of A +*> is to be referenced. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is REAL +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is COMPLEX array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension ( LDA, N ) +*> Before entry with UPLO = 'U' or 'u', the leading n by n +*> upper triangular part of the array A must contain the upper +*> triangular part of the hermitian matrix and the strictly +*> lower triangular part of A is not referenced. On exit, the +*> upper triangular part of the array A is overwritten by the +*> upper triangular part of the updated matrix. +*> Before entry with UPLO = 'L' or 'l', the leading n by n +*> lower triangular part of the array A must contain the lower +*> triangular part of the hermitian matrix and the strictly +*> upper triangular part of A is not referenced. On exit, the +*> lower triangular part of the array A is overwritten by the +*> lower triangular part of the updated matrix. +*> Note that the imaginary parts of the diagonal elements need +*> not be set, they are assumed to be zero, and on exit they +*> are set to zero. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> max( 1, n ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup her +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CHER(UPLO,N,ALPHA,X,INCX,A,LDA) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + REAL ALPHA + INTEGER INCX,LDA,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + COMPLEX A(LDA,*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX ZERO + PARAMETER (ZERO= (0.0E+0,0.0E+0)) +* .. +* .. Local Scalars .. + COMPLEX TEMP + INTEGER I,INFO,IX,J,JX,KX +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC CONJG,MAX,REAL +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (N.LT.0) THEN + INFO = 2 + ELSE IF (INCX.EQ.0) THEN + INFO = 5 + ELSE IF (LDA.LT.MAX(1,N)) THEN + INFO = 7 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('CHER ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. (ALPHA.EQ.REAL(ZERO))) RETURN +* +* Set the start point in X if the increment is not unity. +* + IF (INCX.LE.0) THEN + KX = 1 - (N-1)*INCX + ELSE IF (INCX.NE.1) THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through the triangular part +* of A. +* + IF (LSAME(UPLO,'U')) THEN +* +* Form A when A is stored in upper triangle. +* + IF (INCX.EQ.1) THEN + DO 20 J = 1,N + IF (X(J).NE.ZERO) THEN + TEMP = ALPHA*CONJG(X(J)) + DO 10 I = 1,J - 1 + A(I,J) = A(I,J) + X(I)*TEMP + 10 CONTINUE + A(J,J) = REAL(A(J,J)) + REAL(X(J)*TEMP) + ELSE + A(J,J) = REAL(A(J,J)) + END IF + 20 CONTINUE + ELSE + JX = KX + DO 40 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = ALPHA*CONJG(X(JX)) + IX = KX + DO 30 I = 1,J - 1 + A(I,J) = A(I,J) + X(IX)*TEMP + IX = IX + INCX + 30 CONTINUE + A(J,J) = REAL(A(J,J)) + REAL(X(JX)*TEMP) + ELSE + A(J,J) = REAL(A(J,J)) + END IF + JX = JX + INCX + 40 CONTINUE + END IF + ELSE +* +* Form A when A is stored in lower triangle. +* + IF (INCX.EQ.1) THEN + DO 60 J = 1,N + IF (X(J).NE.ZERO) THEN + TEMP = ALPHA*CONJG(X(J)) + A(J,J) = REAL(A(J,J)) + REAL(TEMP*X(J)) + DO 50 I = J + 1,N + A(I,J) = A(I,J) + X(I)*TEMP + 50 CONTINUE + ELSE + A(J,J) = REAL(A(J,J)) + END IF + 60 CONTINUE + ELSE + JX = KX + DO 80 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = ALPHA*CONJG(X(JX)) + A(J,J) = REAL(A(J,J)) + REAL(TEMP*X(JX)) + IX = JX + DO 70 I = J + 1,N + IX = IX + INCX + A(I,J) = A(I,J) + X(IX)*TEMP + 70 CONTINUE + ELSE + A(J,J) = REAL(A(J,J)) + END IF + JX = JX + INCX + 80 CONTINUE + END IF + END IF +* + RETURN +* +* End of CHER +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/cher2.f b/fortran_implementation/external_libraries/BLAS/SRC/cher2.f new file mode 100644 index 0000000..025c2e5 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/cher2.f @@ -0,0 +1,314 @@ +*> \brief \b CHER2 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CHER2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) +* +* .. Scalar Arguments .. +* COMPLEX ALPHA +* INTEGER INCX,INCY,LDA,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* COMPLEX A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CHER2 performs the hermitian rank 2 operation +*> +*> A := alpha*x*y**H + conjg( alpha )*y*x**H + A, +*> +*> where alpha is a scalar, x and y are n element vectors and A is an n +*> by n hermitian matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the array A is to be referenced as +*> follows: +*> +*> UPLO = 'U' or 'u' Only the upper triangular part of A +*> is to be referenced. +*> +*> UPLO = 'L' or 'l' Only the lower triangular part of A +*> is to be referenced. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is COMPLEX array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in] Y +*> \verbatim +*> Y is COMPLEX array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCY ) ). +*> Before entry, the incremented array Y must contain the n +*> element vector y. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> Y. INCY must not be zero. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension ( LDA, N ) +*> Before entry with UPLO = 'U' or 'u', the leading n by n +*> upper triangular part of the array A must contain the upper +*> triangular part of the hermitian matrix and the strictly +*> lower triangular part of A is not referenced. On exit, the +*> upper triangular part of the array A is overwritten by the +*> upper triangular part of the updated matrix. +*> Before entry with UPLO = 'L' or 'l', the leading n by n +*> lower triangular part of the array A must contain the lower +*> triangular part of the hermitian matrix and the strictly +*> upper triangular part of A is not referenced. On exit, the +*> lower triangular part of the array A is overwritten by the +*> lower triangular part of the updated matrix. +*> Note that the imaginary parts of the diagonal elements need +*> not be set, they are assumed to be zero, and on exit they +*> are set to zero. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> max( 1, n ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup her2 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CHER2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX ALPHA + INTEGER INCX,INCY,LDA,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + COMPLEX A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX ZERO + PARAMETER (ZERO= (0.0E+0,0.0E+0)) +* .. +* .. Local Scalars .. + COMPLEX TEMP1,TEMP2 + INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC CONJG,MAX,REAL +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (N.LT.0) THEN + INFO = 2 + ELSE IF (INCX.EQ.0) THEN + INFO = 5 + ELSE IF (INCY.EQ.0) THEN + INFO = 7 + ELSE IF (LDA.LT.MAX(1,N)) THEN + INFO = 9 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('CHER2 ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN +* +* Set up the start points in X and Y if the increments are not both +* unity. +* + IF ((INCX.NE.1) .OR. (INCY.NE.1)) THEN + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (N-1)*INCX + END IF + IF (INCY.GT.0) THEN + KY = 1 + ELSE + KY = 1 - (N-1)*INCY + END IF + JX = KX + JY = KY + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through the triangular part +* of A. +* + IF (LSAME(UPLO,'U')) THEN +* +* Form A when A is stored in the upper triangle. +* + IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN + DO 20 J = 1,N + IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN + TEMP1 = ALPHA*CONJG(Y(J)) + TEMP2 = CONJG(ALPHA*X(J)) + DO 10 I = 1,J - 1 + A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2 + 10 CONTINUE + A(J,J) = REAL(A(J,J)) + + + REAL(X(J)*TEMP1+Y(J)*TEMP2) + ELSE + A(J,J) = REAL(A(J,J)) + END IF + 20 CONTINUE + ELSE + DO 40 J = 1,N + IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN + TEMP1 = ALPHA*CONJG(Y(JY)) + TEMP2 = CONJG(ALPHA*X(JX)) + IX = KX + IY = KY + DO 30 I = 1,J - 1 + A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2 + IX = IX + INCX + IY = IY + INCY + 30 CONTINUE + A(J,J) = REAL(A(J,J)) + + + REAL(X(JX)*TEMP1+Y(JY)*TEMP2) + ELSE + A(J,J) = REAL(A(J,J)) + END IF + JX = JX + INCX + JY = JY + INCY + 40 CONTINUE + END IF + ELSE +* +* Form A when A is stored in the lower triangle. +* + IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN + DO 60 J = 1,N + IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN + TEMP1 = ALPHA*CONJG(Y(J)) + TEMP2 = CONJG(ALPHA*X(J)) + A(J,J) = REAL(A(J,J)) + + + REAL(X(J)*TEMP1+Y(J)*TEMP2) + DO 50 I = J + 1,N + A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2 + 50 CONTINUE + ELSE + A(J,J) = REAL(A(J,J)) + END IF + 60 CONTINUE + ELSE + DO 80 J = 1,N + IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN + TEMP1 = ALPHA*CONJG(Y(JY)) + TEMP2 = CONJG(ALPHA*X(JX)) + A(J,J) = REAL(A(J,J)) + + + REAL(X(JX)*TEMP1+Y(JY)*TEMP2) + IX = JX + IY = JY + DO 70 I = J + 1,N + IX = IX + INCX + IY = IY + INCY + A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2 + 70 CONTINUE + ELSE + A(J,J) = REAL(A(J,J)) + END IF + JX = JX + INCX + JY = JY + INCY + 80 CONTINUE + END IF + END IF +* + RETURN +* +* End of CHER2 +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/cher2k.f b/fortran_implementation/external_libraries/BLAS/SRC/cher2k.f new file mode 100644 index 0000000..1d9910c --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/cher2k.f @@ -0,0 +1,439 @@ +*> \brief \b CHER2K +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CHER2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* .. Scalar Arguments .. +* COMPLEX ALPHA +* REAL BETA +* INTEGER K,LDA,LDB,LDC,N +* CHARACTER TRANS,UPLO +* .. +* .. Array Arguments .. +* COMPLEX A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CHER2K performs one of the hermitian rank 2k operations +*> +*> C := alpha*A*B**H + conjg( alpha )*B*A**H + beta*C, +*> +*> or +*> +*> C := alpha*A**H*B + conjg( alpha )*B**H*A + beta*C, +*> +*> where alpha and beta are scalars with beta real, C is an n by n +*> hermitian matrix and A and B are n by k matrices in the first case +*> and k by n matrices in the second case. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the array C is to be referenced as +*> follows: +*> +*> UPLO = 'U' or 'u' Only the upper triangular part of C +*> is to be referenced. +*> +*> UPLO = 'L' or 'l' Only the lower triangular part of C +*> is to be referenced. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the operation to be performed as +*> follows: +*> +*> TRANS = 'N' or 'n' C := alpha*A*B**H + +*> conjg( alpha )*B*A**H + +*> beta*C. +*> +*> TRANS = 'C' or 'c' C := alpha*A**H*B + +*> conjg( alpha )*B**H*A + +*> beta*C. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix C. N must be +*> at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry with TRANS = 'N' or 'n', K specifies the number +*> of columns of the matrices A and B, and on entry with +*> TRANS = 'C' or 'c', K specifies the number of rows of the +*> matrices A and B. K must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX array, dimension ( LDA, ka ), where ka is +*> k when TRANS = 'N' or 'n', and is n otherwise. +*> Before entry with TRANS = 'N' or 'n', the leading n by k +*> part of the array A must contain the matrix A, otherwise +*> the leading k by n part of the array A must contain the +*> matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When TRANS = 'N' or 'n' +*> then LDA must be at least max( 1, n ), otherwise LDA must +*> be at least max( 1, k ). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is COMPLEX array, dimension ( LDB, kb ), where kb is +*> k when TRANS = 'N' or 'n', and is n otherwise. +*> Before entry with TRANS = 'N' or 'n', the leading n by k +*> part of the array B must contain the matrix B, otherwise +*> the leading k by n part of the array B must contain the +*> matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. When TRANS = 'N' or 'n' +*> then LDB must be at least max( 1, n ), otherwise LDB must +*> be at least max( 1, k ). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is REAL +*> On entry, BETA specifies the scalar beta. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX array, dimension ( LDC, N ) +*> Before entry with UPLO = 'U' or 'u', the leading n by n +*> upper triangular part of the array C must contain the upper +*> triangular part of the hermitian matrix and the strictly +*> lower triangular part of C is not referenced. On exit, the +*> upper triangular part of the array C is overwritten by the +*> upper triangular part of the updated matrix. +*> Before entry with UPLO = 'L' or 'l', the leading n by n +*> lower triangular part of the array C must contain the lower +*> triangular part of the hermitian matrix and the strictly +*> upper triangular part of C is not referenced. On exit, the +*> lower triangular part of the array C is overwritten by the +*> lower triangular part of the updated matrix. +*> Note that the imaginary parts of the diagonal elements need +*> not be set, they are assumed to be zero, and on exit they +*> are set to zero. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> On entry, LDC specifies the first dimension of C as declared +*> in the calling (sub) program. LDC must be at least +*> max( 1, n ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup her2k +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> -- Written on 8-February-1989. +*> Jack Dongarra, Argonne National Laboratory. +*> Iain Duff, AERE Harwell. +*> Jeremy Du Croz, Numerical Algorithms Group Ltd. +*> Sven Hammarling, Numerical Algorithms Group Ltd. +*> +*> -- Modified 8-Nov-93 to set C(J,J) to REAL( C(J,J) ) when BETA = 1. +*> Ed Anderson, Cray Research Inc. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CHER2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* -- Reference BLAS level3 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX ALPHA + REAL BETA + INTEGER K,LDA,LDB,LDC,N + CHARACTER TRANS,UPLO +* .. +* .. Array Arguments .. + COMPLEX A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC CONJG,MAX,REAL +* .. +* .. Local Scalars .. + COMPLEX TEMP1,TEMP2 + INTEGER I,INFO,J,L,NROWA + LOGICAL UPPER +* .. +* .. Parameters .. + REAL ONE + PARAMETER (ONE=1.0E+0) + COMPLEX ZERO + PARAMETER (ZERO= (0.0E+0,0.0E+0)) +* .. +* +* Test the input parameters. +* + IF (LSAME(TRANS,'N')) THEN + NROWA = N + ELSE + NROWA = K + END IF + UPPER = LSAME(UPLO,'U') +* + INFO = 0 + IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN + INFO = 1 + ELSE IF ((.NOT.LSAME(TRANS,'N')) .AND. + + (.NOT.LSAME(TRANS,'C'))) THEN + INFO = 2 + ELSE IF (N.LT.0) THEN + INFO = 3 + ELSE IF (K.LT.0) THEN + INFO = 4 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 7 + ELSE IF (LDB.LT.MAX(1,NROWA)) THEN + INFO = 9 + ELSE IF (LDC.LT.MAX(1,N)) THEN + INFO = 12 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('CHER2K',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR. + + (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + IF (UPPER) THEN + IF (BETA.EQ.REAL(ZERO)) THEN + DO 20 J = 1,N + DO 10 I = 1,J + C(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1,N + DO 30 I = 1,J - 1 + C(I,J) = BETA*C(I,J) + 30 CONTINUE + C(J,J) = BETA*REAL(C(J,J)) + 40 CONTINUE + END IF + ELSE + IF (BETA.EQ.REAL(ZERO)) THEN + DO 60 J = 1,N + DO 50 I = J,N + C(I,J) = ZERO + 50 CONTINUE + 60 CONTINUE + ELSE + DO 80 J = 1,N + C(J,J) = BETA*REAL(C(J,J)) + DO 70 I = J + 1,N + C(I,J) = BETA*C(I,J) + 70 CONTINUE + 80 CONTINUE + END IF + END IF + RETURN + END IF +* +* Start the operations. +* + IF (LSAME(TRANS,'N')) THEN +* +* Form C := alpha*A*B**H + conjg( alpha )*B*A**H + +* C. +* + IF (UPPER) THEN + DO 130 J = 1,N + IF (BETA.EQ.REAL(ZERO)) THEN + DO 90 I = 1,J + C(I,J) = ZERO + 90 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 100 I = 1,J - 1 + C(I,J) = BETA*C(I,J) + 100 CONTINUE + C(J,J) = BETA*REAL(C(J,J)) + ELSE + C(J,J) = REAL(C(J,J)) + END IF + DO 120 L = 1,K + IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN + TEMP1 = ALPHA*CONJG(B(J,L)) + TEMP2 = CONJG(ALPHA*A(J,L)) + DO 110 I = 1,J - 1 + C(I,J) = C(I,J) + A(I,L)*TEMP1 + + + B(I,L)*TEMP2 + 110 CONTINUE + C(J,J) = REAL(C(J,J)) + + + REAL(A(J,L)*TEMP1+B(J,L)*TEMP2) + END IF + 120 CONTINUE + 130 CONTINUE + ELSE + DO 180 J = 1,N + IF (BETA.EQ.REAL(ZERO)) THEN + DO 140 I = J,N + C(I,J) = ZERO + 140 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 150 I = J + 1,N + C(I,J) = BETA*C(I,J) + 150 CONTINUE + C(J,J) = BETA*REAL(C(J,J)) + ELSE + C(J,J) = REAL(C(J,J)) + END IF + DO 170 L = 1,K + IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN + TEMP1 = ALPHA*CONJG(B(J,L)) + TEMP2 = CONJG(ALPHA*A(J,L)) + DO 160 I = J + 1,N + C(I,J) = C(I,J) + A(I,L)*TEMP1 + + + B(I,L)*TEMP2 + 160 CONTINUE + C(J,J) = REAL(C(J,J)) + + + REAL(A(J,L)*TEMP1+B(J,L)*TEMP2) + END IF + 170 CONTINUE + 180 CONTINUE + END IF + ELSE +* +* Form C := alpha*A**H*B + conjg( alpha )*B**H*A + +* C. +* + IF (UPPER) THEN + DO 210 J = 1,N + DO 200 I = 1,J + TEMP1 = ZERO + TEMP2 = ZERO + DO 190 L = 1,K + TEMP1 = TEMP1 + CONJG(A(L,I))*B(L,J) + TEMP2 = TEMP2 + CONJG(B(L,I))*A(L,J) + 190 CONTINUE + IF (I.EQ.J) THEN + IF (BETA.EQ.REAL(ZERO)) THEN + C(J,J) = REAL(ALPHA*TEMP1+ + + CONJG(ALPHA)*TEMP2) + ELSE + C(J,J) = BETA*REAL(C(J,J)) + + + REAL(ALPHA*TEMP1+ + + CONJG(ALPHA)*TEMP2) + END IF + ELSE + IF (BETA.EQ.REAL(ZERO)) THEN + C(I,J) = ALPHA*TEMP1 + CONJG(ALPHA)*TEMP2 + ELSE + C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 + + + CONJG(ALPHA)*TEMP2 + END IF + END IF + 200 CONTINUE + 210 CONTINUE + ELSE + DO 240 J = 1,N + DO 230 I = J,N + TEMP1 = ZERO + TEMP2 = ZERO + DO 220 L = 1,K + TEMP1 = TEMP1 + CONJG(A(L,I))*B(L,J) + TEMP2 = TEMP2 + CONJG(B(L,I))*A(L,J) + 220 CONTINUE + IF (I.EQ.J) THEN + IF (BETA.EQ.REAL(ZERO)) THEN + C(J,J) = REAL(ALPHA*TEMP1+ + + CONJG(ALPHA)*TEMP2) + ELSE + C(J,J) = BETA*REAL(C(J,J)) + + + REAL(ALPHA*TEMP1+ + + CONJG(ALPHA)*TEMP2) + END IF + ELSE + IF (BETA.EQ.REAL(ZERO)) THEN + C(I,J) = ALPHA*TEMP1 + CONJG(ALPHA)*TEMP2 + ELSE + C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 + + + CONJG(ALPHA)*TEMP2 + END IF + END IF + 230 CONTINUE + 240 CONTINUE + END IF + END IF +* + RETURN +* +* End of CHER2K +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/cherk.f b/fortran_implementation/external_libraries/BLAS/SRC/cherk.f new file mode 100644 index 0000000..01b5d4e --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/cherk.f @@ -0,0 +1,393 @@ +*> \brief \b CHERK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CHERK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) +* +* .. Scalar Arguments .. +* REAL ALPHA,BETA +* INTEGER K,LDA,LDC,N +* CHARACTER TRANS,UPLO +* .. +* .. Array Arguments .. +* COMPLEX A(LDA,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CHERK performs one of the hermitian rank k operations +*> +*> C := alpha*A*A**H + beta*C, +*> +*> or +*> +*> C := alpha*A**H*A + beta*C, +*> +*> where alpha and beta are real scalars, C is an n by n hermitian +*> matrix and A is an n by k matrix in the first case and a k by n +*> matrix in the second case. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the array C is to be referenced as +*> follows: +*> +*> UPLO = 'U' or 'u' Only the upper triangular part of C +*> is to be referenced. +*> +*> UPLO = 'L' or 'l' Only the lower triangular part of C +*> is to be referenced. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the operation to be performed as +*> follows: +*> +*> TRANS = 'N' or 'n' C := alpha*A*A**H + beta*C. +*> +*> TRANS = 'C' or 'c' C := alpha*A**H*A + beta*C. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix C. N must be +*> at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry with TRANS = 'N' or 'n', K specifies the number +*> of columns of the matrix A, and on entry with +*> TRANS = 'C' or 'c', K specifies the number of rows of the +*> matrix A. K must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is REAL +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX array, dimension ( LDA, ka ), where ka is +*> k when TRANS = 'N' or 'n', and is n otherwise. +*> Before entry with TRANS = 'N' or 'n', the leading n by k +*> part of the array A must contain the matrix A, otherwise +*> the leading k by n part of the array A must contain the +*> matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When TRANS = 'N' or 'n' +*> then LDA must be at least max( 1, n ), otherwise LDA must +*> be at least max( 1, k ). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is REAL +*> On entry, BETA specifies the scalar beta. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX array, dimension ( LDC, N ) +*> Before entry with UPLO = 'U' or 'u', the leading n by n +*> upper triangular part of the array C must contain the upper +*> triangular part of the hermitian matrix and the strictly +*> lower triangular part of C is not referenced. On exit, the +*> upper triangular part of the array C is overwritten by the +*> upper triangular part of the updated matrix. +*> Before entry with UPLO = 'L' or 'l', the leading n by n +*> lower triangular part of the array C must contain the lower +*> triangular part of the hermitian matrix and the strictly +*> upper triangular part of C is not referenced. On exit, the +*> lower triangular part of the array C is overwritten by the +*> lower triangular part of the updated matrix. +*> Note that the imaginary parts of the diagonal elements need +*> not be set, they are assumed to be zero, and on exit they +*> are set to zero. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> On entry, LDC specifies the first dimension of C as declared +*> in the calling (sub) program. LDC must be at least +*> max( 1, n ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup herk +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> -- Written on 8-February-1989. +*> Jack Dongarra, Argonne National Laboratory. +*> Iain Duff, AERE Harwell. +*> Jeremy Du Croz, Numerical Algorithms Group Ltd. +*> Sven Hammarling, Numerical Algorithms Group Ltd. +*> +*> -- Modified 8-Nov-93 to set C(J,J) to REAL( C(J,J) ) when BETA = 1. +*> Ed Anderson, Cray Research Inc. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CHERK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) +* +* -- Reference BLAS level3 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + REAL ALPHA,BETA + INTEGER K,LDA,LDC,N + CHARACTER TRANS,UPLO +* .. +* .. Array Arguments .. + COMPLEX A(LDA,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC CMPLX,CONJG,MAX,REAL +* .. +* .. Local Scalars .. + COMPLEX TEMP + REAL RTEMP + INTEGER I,INFO,J,L,NROWA + LOGICAL UPPER +* .. +* .. Parameters .. + REAL ONE,ZERO + PARAMETER (ONE=1.0E+0,ZERO=0.0E+0) +* .. +* +* Test the input parameters. +* + IF (LSAME(TRANS,'N')) THEN + NROWA = N + ELSE + NROWA = K + END IF + UPPER = LSAME(UPLO,'U') +* + INFO = 0 + IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN + INFO = 1 + ELSE IF ((.NOT.LSAME(TRANS,'N')) .AND. + + (.NOT.LSAME(TRANS,'C'))) THEN + INFO = 2 + ELSE IF (N.LT.0) THEN + INFO = 3 + ELSE IF (K.LT.0) THEN + INFO = 4 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 7 + ELSE IF (LDC.LT.MAX(1,N)) THEN + INFO = 10 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('CHERK ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR. + + (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + IF (UPPER) THEN + IF (BETA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,J + C(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1,N + DO 30 I = 1,J - 1 + C(I,J) = BETA*C(I,J) + 30 CONTINUE + C(J,J) = BETA*REAL(C(J,J)) + 40 CONTINUE + END IF + ELSE + IF (BETA.EQ.ZERO) THEN + DO 60 J = 1,N + DO 50 I = J,N + C(I,J) = ZERO + 50 CONTINUE + 60 CONTINUE + ELSE + DO 80 J = 1,N + C(J,J) = BETA*REAL(C(J,J)) + DO 70 I = J + 1,N + C(I,J) = BETA*C(I,J) + 70 CONTINUE + 80 CONTINUE + END IF + END IF + RETURN + END IF +* +* Start the operations. +* + IF (LSAME(TRANS,'N')) THEN +* +* Form C := alpha*A*A**H + beta*C. +* + IF (UPPER) THEN + DO 130 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 90 I = 1,J + C(I,J) = ZERO + 90 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 100 I = 1,J - 1 + C(I,J) = BETA*C(I,J) + 100 CONTINUE + C(J,J) = BETA*REAL(C(J,J)) + ELSE + C(J,J) = REAL(C(J,J)) + END IF + DO 120 L = 1,K + IF (A(J,L).NE.CMPLX(ZERO)) THEN + TEMP = ALPHA*CONJG(A(J,L)) + DO 110 I = 1,J - 1 + C(I,J) = C(I,J) + TEMP*A(I,L) + 110 CONTINUE + C(J,J) = REAL(C(J,J)) + REAL(TEMP*A(I,L)) + END IF + 120 CONTINUE + 130 CONTINUE + ELSE + DO 180 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 140 I = J,N + C(I,J) = ZERO + 140 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + C(J,J) = BETA*REAL(C(J,J)) + DO 150 I = J + 1,N + C(I,J) = BETA*C(I,J) + 150 CONTINUE + ELSE + C(J,J) = REAL(C(J,J)) + END IF + DO 170 L = 1,K + IF (A(J,L).NE.CMPLX(ZERO)) THEN + TEMP = ALPHA*CONJG(A(J,L)) + C(J,J) = REAL(C(J,J)) + REAL(TEMP*A(J,L)) + DO 160 I = J + 1,N + C(I,J) = C(I,J) + TEMP*A(I,L) + 160 CONTINUE + END IF + 170 CONTINUE + 180 CONTINUE + END IF + ELSE +* +* Form C := alpha*A**H*A + beta*C. +* + IF (UPPER) THEN + DO 220 J = 1,N + DO 200 I = 1,J - 1 + TEMP = ZERO + DO 190 L = 1,K + TEMP = TEMP + CONJG(A(L,I))*A(L,J) + 190 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 200 CONTINUE + RTEMP = ZERO + DO 210 L = 1,K + RTEMP = RTEMP + REAL(CONJG(A(L,J))*A(L,J)) + 210 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(J,J) = ALPHA*RTEMP + ELSE + C(J,J) = ALPHA*RTEMP + BETA*REAL(C(J,J)) + END IF + 220 CONTINUE + ELSE + DO 260 J = 1,N + RTEMP = ZERO + DO 230 L = 1,K + RTEMP = RTEMP + REAL(CONJG(A(L,J))*A(L,J)) + 230 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(J,J) = ALPHA*RTEMP + ELSE + C(J,J) = ALPHA*RTEMP + BETA*REAL(C(J,J)) + END IF + DO 250 I = J + 1,N + TEMP = ZERO + DO 240 L = 1,K + TEMP = TEMP + CONJG(A(L,I))*A(L,J) + 240 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 250 CONTINUE + 260 CONTINUE + END IF + END IF +* + RETURN +* +* End of CHERK +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/chpmv.f b/fortran_implementation/external_libraries/BLAS/SRC/chpmv.f new file mode 100644 index 0000000..e8b42d6 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/chpmv.f @@ -0,0 +1,335 @@ +*> \brief \b CHPMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CHPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY) +* +* .. Scalar Arguments .. +* COMPLEX ALPHA,BETA +* INTEGER INCX,INCY,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* COMPLEX AP(*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CHPMV performs the matrix-vector operation +*> +*> y := alpha*A*x + beta*y, +*> +*> where alpha and beta are scalars, x and y are n element vectors and +*> A is an n by n hermitian matrix, supplied in packed form. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the matrix A is supplied in the packed +*> array AP as follows: +*> +*> UPLO = 'U' or 'u' The upper triangular part of A is +*> supplied in AP. +*> +*> UPLO = 'L' or 'l' The lower triangular part of A is +*> supplied in AP. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] AP +*> \verbatim +*> AP is COMPLEX array, dimension at least +*> ( ( n*( n + 1 ) )/2 ). +*> Before entry with UPLO = 'U' or 'u', the array AP must +*> contain the upper triangular part of the hermitian matrix +*> packed sequentially, column by column, so that AP( 1 ) +*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) +*> and a( 2, 2 ) respectively, and so on. +*> Before entry with UPLO = 'L' or 'l', the array AP must +*> contain the lower triangular part of the hermitian matrix +*> packed sequentially, column by column, so that AP( 1 ) +*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) +*> and a( 3, 1 ) respectively, and so on. +*> Note that the imaginary parts of the diagonal elements need +*> not be set and are assumed to be zero. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is COMPLEX array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is COMPLEX +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then Y need not be set on input. +*> \endverbatim +*> +*> \param[in,out] Y +*> \verbatim +*> Y is COMPLEX array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCY ) ). +*> Before entry, the incremented array Y must contain the n +*> element vector y. On exit, Y is overwritten by the updated +*> vector y. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> Y. INCY must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup hpmv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> The vector and matrix arguments are not referenced when N = 0, or M = 0 +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CHPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX ALPHA,BETA + INTEGER INCX,INCY,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + COMPLEX AP(*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX ONE + PARAMETER (ONE= (1.0E+0,0.0E+0)) + COMPLEX ZERO + PARAMETER (ZERO= (0.0E+0,0.0E+0)) +* .. +* .. Local Scalars .. + COMPLEX TEMP1,TEMP2 + INTEGER I,INFO,IX,IY,J,JX,JY,K,KK,KX,KY +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC CONJG,REAL +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (N.LT.0) THEN + INFO = 2 + ELSE IF (INCX.EQ.0) THEN + INFO = 6 + ELSE IF (INCY.EQ.0) THEN + INFO = 9 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('CHPMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN +* +* Set up the start points in X and Y. +* + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (N-1)*INCX + END IF + IF (INCY.GT.0) THEN + KY = 1 + ELSE + KY = 1 - (N-1)*INCY + END IF +* +* Start the operations. In this version the elements of the array AP +* are accessed sequentially with one pass through AP. +* +* First form y := beta*y. +* + IF (BETA.NE.ONE) THEN + IF (INCY.EQ.1) THEN + IF (BETA.EQ.ZERO) THEN + DO 10 I = 1,N + Y(I) = ZERO + 10 CONTINUE + ELSE + DO 20 I = 1,N + Y(I) = BETA*Y(I) + 20 CONTINUE + END IF + ELSE + IY = KY + IF (BETA.EQ.ZERO) THEN + DO 30 I = 1,N + Y(IY) = ZERO + IY = IY + INCY + 30 CONTINUE + ELSE + DO 40 I = 1,N + Y(IY) = BETA*Y(IY) + IY = IY + INCY + 40 CONTINUE + END IF + END IF + END IF + IF (ALPHA.EQ.ZERO) RETURN + KK = 1 + IF (LSAME(UPLO,'U')) THEN +* +* Form y when AP contains the upper triangle. +* + IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN + DO 60 J = 1,N + TEMP1 = ALPHA*X(J) + TEMP2 = ZERO + K = KK + DO 50 I = 1,J - 1 + Y(I) = Y(I) + TEMP1*AP(K) + TEMP2 = TEMP2 + CONJG(AP(K))*X(I) + K = K + 1 + 50 CONTINUE + Y(J) = Y(J) + TEMP1*REAL(AP(KK+J-1)) + ALPHA*TEMP2 + KK = KK + J + 60 CONTINUE + ELSE + JX = KX + JY = KY + DO 80 J = 1,N + TEMP1 = ALPHA*X(JX) + TEMP2 = ZERO + IX = KX + IY = KY + DO 70 K = KK,KK + J - 2 + Y(IY) = Y(IY) + TEMP1*AP(K) + TEMP2 = TEMP2 + CONJG(AP(K))*X(IX) + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + Y(JY) = Y(JY) + TEMP1*REAL(AP(KK+J-1)) + ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + KK = KK + J + 80 CONTINUE + END IF + ELSE +* +* Form y when AP contains the lower triangle. +* + IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN + DO 100 J = 1,N + TEMP1 = ALPHA*X(J) + TEMP2 = ZERO + Y(J) = Y(J) + TEMP1*REAL(AP(KK)) + K = KK + 1 + DO 90 I = J + 1,N + Y(I) = Y(I) + TEMP1*AP(K) + TEMP2 = TEMP2 + CONJG(AP(K))*X(I) + K = K + 1 + 90 CONTINUE + Y(J) = Y(J) + ALPHA*TEMP2 + KK = KK + (N-J+1) + 100 CONTINUE + ELSE + JX = KX + JY = KY + DO 120 J = 1,N + TEMP1 = ALPHA*X(JX) + TEMP2 = ZERO + Y(JY) = Y(JY) + TEMP1*REAL(AP(KK)) + IX = JX + IY = JY + DO 110 K = KK + 1,KK + N - J + IX = IX + INCX + IY = IY + INCY + Y(IY) = Y(IY) + TEMP1*AP(K) + TEMP2 = TEMP2 + CONJG(AP(K))*X(IX) + 110 CONTINUE + Y(JY) = Y(JY) + ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + KK = KK + (N-J+1) + 120 CONTINUE + END IF + END IF +* + RETURN +* +* End of CHPMV +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/chpr.f b/fortran_implementation/external_libraries/BLAS/SRC/chpr.f new file mode 100644 index 0000000..a5b3788 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/chpr.f @@ -0,0 +1,276 @@ +*> \brief \b CHPR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CHPR(UPLO,N,ALPHA,X,INCX,AP) +* +* .. Scalar Arguments .. +* REAL ALPHA +* INTEGER INCX,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* COMPLEX AP(*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CHPR performs the hermitian rank 1 operation +*> +*> A := alpha*x*x**H + A, +*> +*> where alpha is a real scalar, x is an n element vector and A is an +*> n by n hermitian matrix, supplied in packed form. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the matrix A is supplied in the packed +*> array AP as follows: +*> +*> UPLO = 'U' or 'u' The upper triangular part of A is +*> supplied in AP. +*> +*> UPLO = 'L' or 'l' The lower triangular part of A is +*> supplied in AP. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is REAL +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is COMPLEX array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in,out] AP +*> \verbatim +*> AP is COMPLEX array, dimension at least +*> ( ( n*( n + 1 ) )/2 ). +*> Before entry with UPLO = 'U' or 'u', the array AP must +*> contain the upper triangular part of the hermitian matrix +*> packed sequentially, column by column, so that AP( 1 ) +*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) +*> and a( 2, 2 ) respectively, and so on. On exit, the array +*> AP is overwritten by the upper triangular part of the +*> updated matrix. +*> Before entry with UPLO = 'L' or 'l', the array AP must +*> contain the lower triangular part of the hermitian matrix +*> packed sequentially, column by column, so that AP( 1 ) +*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) +*> and a( 3, 1 ) respectively, and so on. On exit, the array +*> AP is overwritten by the lower triangular part of the +*> updated matrix. +*> Note that the imaginary parts of the diagonal elements need +*> not be set, they are assumed to be zero, and on exit they +*> are set to zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup hpr +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CHPR(UPLO,N,ALPHA,X,INCX,AP) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + REAL ALPHA + INTEGER INCX,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + COMPLEX AP(*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX ZERO + PARAMETER (ZERO= (0.0E+0,0.0E+0)) +* .. +* .. Local Scalars .. + COMPLEX TEMP + INTEGER I,INFO,IX,J,JX,K,KK,KX +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC CONJG,REAL +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (N.LT.0) THEN + INFO = 2 + ELSE IF (INCX.EQ.0) THEN + INFO = 5 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('CHPR ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. (ALPHA.EQ.REAL(ZERO))) RETURN +* +* Set the start point in X if the increment is not unity. +* + IF (INCX.LE.0) THEN + KX = 1 - (N-1)*INCX + ELSE IF (INCX.NE.1) THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of the array AP +* are accessed sequentially with one pass through AP. +* + KK = 1 + IF (LSAME(UPLO,'U')) THEN +* +* Form A when upper triangle is stored in AP. +* + IF (INCX.EQ.1) THEN + DO 20 J = 1,N + IF (X(J).NE.ZERO) THEN + TEMP = ALPHA*CONJG(X(J)) + K = KK + DO 10 I = 1,J - 1 + AP(K) = AP(K) + X(I)*TEMP + K = K + 1 + 10 CONTINUE + AP(KK+J-1) = REAL(AP(KK+J-1)) + REAL(X(J)*TEMP) + ELSE + AP(KK+J-1) = REAL(AP(KK+J-1)) + END IF + KK = KK + J + 20 CONTINUE + ELSE + JX = KX + DO 40 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = ALPHA*CONJG(X(JX)) + IX = KX + DO 30 K = KK,KK + J - 2 + AP(K) = AP(K) + X(IX)*TEMP + IX = IX + INCX + 30 CONTINUE + AP(KK+J-1) = REAL(AP(KK+J-1)) + REAL(X(JX)*TEMP) + ELSE + AP(KK+J-1) = REAL(AP(KK+J-1)) + END IF + JX = JX + INCX + KK = KK + J + 40 CONTINUE + END IF + ELSE +* +* Form A when lower triangle is stored in AP. +* + IF (INCX.EQ.1) THEN + DO 60 J = 1,N + IF (X(J).NE.ZERO) THEN + TEMP = ALPHA*CONJG(X(J)) + AP(KK) = REAL(AP(KK)) + REAL(TEMP*X(J)) + K = KK + 1 + DO 50 I = J + 1,N + AP(K) = AP(K) + X(I)*TEMP + K = K + 1 + 50 CONTINUE + ELSE + AP(KK) = REAL(AP(KK)) + END IF + KK = KK + N - J + 1 + 60 CONTINUE + ELSE + JX = KX + DO 80 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = ALPHA*CONJG(X(JX)) + AP(KK) = REAL(AP(KK)) + REAL(TEMP*X(JX)) + IX = JX + DO 70 K = KK + 1,KK + N - J + IX = IX + INCX + AP(K) = AP(K) + X(IX)*TEMP + 70 CONTINUE + ELSE + AP(KK) = REAL(AP(KK)) + END IF + JX = JX + INCX + KK = KK + N - J + 1 + 80 CONTINUE + END IF + END IF +* + RETURN +* +* End of CHPR +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/chpr2.f b/fortran_implementation/external_libraries/BLAS/SRC/chpr2.f new file mode 100644 index 0000000..a16f08a --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/chpr2.f @@ -0,0 +1,315 @@ +*> \brief \b CHPR2 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CHPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP) +* +* .. Scalar Arguments .. +* COMPLEX ALPHA +* INTEGER INCX,INCY,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* COMPLEX AP(*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CHPR2 performs the hermitian rank 2 operation +*> +*> A := alpha*x*y**H + conjg( alpha )*y*x**H + A, +*> +*> where alpha is a scalar, x and y are n element vectors and A is an +*> n by n hermitian matrix, supplied in packed form. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the matrix A is supplied in the packed +*> array AP as follows: +*> +*> UPLO = 'U' or 'u' The upper triangular part of A is +*> supplied in AP. +*> +*> UPLO = 'L' or 'l' The lower triangular part of A is +*> supplied in AP. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is COMPLEX array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in] Y +*> \verbatim +*> Y is COMPLEX array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCY ) ). +*> Before entry, the incremented array Y must contain the n +*> element vector y. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> Y. INCY must not be zero. +*> \endverbatim +*> +*> \param[in,out] AP +*> \verbatim +*> AP is COMPLEX array, dimension at least +*> ( ( n*( n + 1 ) )/2 ). +*> Before entry with UPLO = 'U' or 'u', the array AP must +*> contain the upper triangular part of the hermitian matrix +*> packed sequentially, column by column, so that AP( 1 ) +*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) +*> and a( 2, 2 ) respectively, and so on. On exit, the array +*> AP is overwritten by the upper triangular part of the +*> updated matrix. +*> Before entry with UPLO = 'L' or 'l', the array AP must +*> contain the lower triangular part of the hermitian matrix +*> packed sequentially, column by column, so that AP( 1 ) +*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) +*> and a( 3, 1 ) respectively, and so on. On exit, the array +*> AP is overwritten by the lower triangular part of the +*> updated matrix. +*> Note that the imaginary parts of the diagonal elements need +*> not be set, they are assumed to be zero, and on exit they +*> are set to zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup hpr2 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CHPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX ALPHA + INTEGER INCX,INCY,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + COMPLEX AP(*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX ZERO + PARAMETER (ZERO= (0.0E+0,0.0E+0)) +* .. +* .. Local Scalars .. + COMPLEX TEMP1,TEMP2 + INTEGER I,INFO,IX,IY,J,JX,JY,K,KK,KX,KY +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC CONJG,REAL +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (N.LT.0) THEN + INFO = 2 + ELSE IF (INCX.EQ.0) THEN + INFO = 5 + ELSE IF (INCY.EQ.0) THEN + INFO = 7 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('CHPR2 ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN +* +* Set up the start points in X and Y if the increments are not both +* unity. +* + IF ((INCX.NE.1) .OR. (INCY.NE.1)) THEN + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (N-1)*INCX + END IF + IF (INCY.GT.0) THEN + KY = 1 + ELSE + KY = 1 - (N-1)*INCY + END IF + JX = KX + JY = KY + END IF +* +* Start the operations. In this version the elements of the array AP +* are accessed sequentially with one pass through AP. +* + KK = 1 + IF (LSAME(UPLO,'U')) THEN +* +* Form A when upper triangle is stored in AP. +* + IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN + DO 20 J = 1,N + IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN + TEMP1 = ALPHA*CONJG(Y(J)) + TEMP2 = CONJG(ALPHA*X(J)) + K = KK + DO 10 I = 1,J - 1 + AP(K) = AP(K) + X(I)*TEMP1 + Y(I)*TEMP2 + K = K + 1 + 10 CONTINUE + AP(KK+J-1) = REAL(AP(KK+J-1)) + + + REAL(X(J)*TEMP1+Y(J)*TEMP2) + ELSE + AP(KK+J-1) = REAL(AP(KK+J-1)) + END IF + KK = KK + J + 20 CONTINUE + ELSE + DO 40 J = 1,N + IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN + TEMP1 = ALPHA*CONJG(Y(JY)) + TEMP2 = CONJG(ALPHA*X(JX)) + IX = KX + IY = KY + DO 30 K = KK,KK + J - 2 + AP(K) = AP(K) + X(IX)*TEMP1 + Y(IY)*TEMP2 + IX = IX + INCX + IY = IY + INCY + 30 CONTINUE + AP(KK+J-1) = REAL(AP(KK+J-1)) + + + REAL(X(JX)*TEMP1+Y(JY)*TEMP2) + ELSE + AP(KK+J-1) = REAL(AP(KK+J-1)) + END IF + JX = JX + INCX + JY = JY + INCY + KK = KK + J + 40 CONTINUE + END IF + ELSE +* +* Form A when lower triangle is stored in AP. +* + IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN + DO 60 J = 1,N + IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN + TEMP1 = ALPHA*CONJG(Y(J)) + TEMP2 = CONJG(ALPHA*X(J)) + AP(KK) = REAL(AP(KK)) + + + REAL(X(J)*TEMP1+Y(J)*TEMP2) + K = KK + 1 + DO 50 I = J + 1,N + AP(K) = AP(K) + X(I)*TEMP1 + Y(I)*TEMP2 + K = K + 1 + 50 CONTINUE + ELSE + AP(KK) = REAL(AP(KK)) + END IF + KK = KK + N - J + 1 + 60 CONTINUE + ELSE + DO 80 J = 1,N + IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN + TEMP1 = ALPHA*CONJG(Y(JY)) + TEMP2 = CONJG(ALPHA*X(JX)) + AP(KK) = REAL(AP(KK)) + + + REAL(X(JX)*TEMP1+Y(JY)*TEMP2) + IX = JX + IY = JY + DO 70 K = KK + 1,KK + N - J + IX = IX + INCX + IY = IY + INCY + AP(K) = AP(K) + X(IX)*TEMP1 + Y(IY)*TEMP2 + 70 CONTINUE + ELSE + AP(KK) = REAL(AP(KK)) + END IF + JX = JX + INCX + JY = JY + INCY + KK = KK + N - J + 1 + 80 CONTINUE + END IF + END IF +* + RETURN +* +* End of CHPR2 +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/crotg.f90 b/fortran_implementation/external_libraries/BLAS/SRC/crotg.f90 new file mode 100644 index 0000000..d16c6af --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/crotg.f90 @@ -0,0 +1,276 @@ +!> \brief \b CROTG generates a Givens rotation with real cosine and complex sine. +! +! =========== DOCUMENTATION =========== +! +! Online html documentation available at +! http://www.netlib.org/lapack/explore-html/ +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> CROTG constructs a plane rotation +!> [ c s ] [ a ] = [ r ] +!> [ -conjg(s) c ] [ b ] [ 0 ] +!> where c is real, s is complex, and c**2 + conjg(s)*s = 1. +!> +!> The computation uses the formulas +!> |x| = sqrt( Re(x)**2 + Im(x)**2 ) +!> sgn(x) = x / |x| if x /= 0 +!> = 1 if x = 0 +!> c = |a| / sqrt(|a|**2 + |b|**2) +!> s = sgn(a) * conjg(b) / sqrt(|a|**2 + |b|**2) +!> r = sgn(a)*sqrt(|a|**2 + |b|**2) +!> When a and b are real and r /= 0, the formulas simplify to +!> c = a / r +!> s = b / r +!> the same as in SROTG when |a| > |b|. When |b| >= |a|, the +!> sign of c and s will be different from those computed by SROTG +!> if the signs of a and b are not the same. +!> +!> \endverbatim +!> +!> @see lartg, @see lartgp +! +! Arguments: +! ========== +! +!> \param[in,out] A +!> \verbatim +!> A is COMPLEX +!> On entry, the scalar a. +!> On exit, the scalar r. +!> \endverbatim +!> +!> \param[in] B +!> \verbatim +!> B is COMPLEX +!> The scalar b. +!> \endverbatim +!> +!> \param[out] C +!> \verbatim +!> C is REAL +!> The scalar c. +!> \endverbatim +!> +!> \param[out] S +!> \verbatim +!> S is COMPLEX +!> The scalar s. +!> \endverbatim +! +! Authors: +! ======== +! +!> \author Weslley Pereira, University of Colorado Denver, USA +! +!> \date December 2021 +! +!> \ingroup rotg +! +!> \par Further Details: +! ===================== +!> +!> \verbatim +!> +!> Based on the algorithm from +!> +!> Anderson E. (2017) +!> Algorithm 978: Safe Scaling in the Level 1 BLAS +!> ACM Trans Math Softw 44:1--28 +!> https://doi.org/10.1145/3061665 +!> +!> \endverbatim +! +! ===================================================================== +subroutine CROTG( a, b, c, s ) + integer, parameter :: wp = kind(1.e0) +! +! -- Reference BLAS level1 routine -- +! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +! +! .. Constants .. + real(wp), parameter :: zero = 0.0_wp + real(wp), parameter :: one = 1.0_wp + complex(wp), parameter :: czero = 0.0_wp +! .. +! .. Scaling constants .. + real(wp), parameter :: safmin = real(radix(0._wp),wp)**max( & + minexponent(0._wp)-1, & + 1-maxexponent(0._wp) & + ) + real(wp), parameter :: safmax = real(radix(0._wp),wp)**max( & + 1-minexponent(0._wp), & + maxexponent(0._wp)-1 & + ) + real(wp), parameter :: rtmin = sqrt( safmin ) +! .. +! .. Scalar Arguments .. + real(wp) :: c + complex(wp) :: a, b, s +! .. +! .. Local Scalars .. + real(wp) :: d, f1, f2, g1, g2, h2, u, v, w, rtmax + complex(wp) :: f, fs, g, gs, r, t +! .. +! .. Intrinsic Functions .. + intrinsic :: abs, aimag, conjg, max, min, real, sqrt +! .. +! .. Statement Functions .. + real(wp) :: ABSSQ +! .. +! .. Statement Function definitions .. + ABSSQ( t ) = real( t )**2 + aimag( t )**2 +! .. +! .. Executable Statements .. +! + f = a + g = b + if( g == czero ) then + c = one + s = czero + r = f + else if( f == czero ) then + c = zero + if( real(g) == zero ) then + r = abs(aimag(g)) + s = conjg( g ) / r + elseif( aimag(g) == zero ) then + r = abs(real(g)) + s = conjg( g ) / r + else + g1 = max( abs(real(g)), abs(aimag(g)) ) + rtmax = sqrt( safmax/2 ) + if( g1 > rtmin .and. g1 < rtmax ) then +! +! Use unscaled algorithm +! +! The following two lines can be replaced by `d = abs( g )`. +! This algorithm do not use the intrinsic complex abs. + g2 = ABSSQ( g ) + d = sqrt( g2 ) + s = conjg( g ) / d + r = d + else +! +! Use scaled algorithm +! + u = min( safmax, max( safmin, g1 ) ) + gs = g / u +! The following two lines can be replaced by `d = abs( gs )`. +! This algorithm do not use the intrinsic complex abs. + g2 = ABSSQ( gs ) + d = sqrt( g2 ) + s = conjg( gs ) / d + r = d*u + end if + end if + else + f1 = max( abs(real(f)), abs(aimag(f)) ) + g1 = max( abs(real(g)), abs(aimag(g)) ) + rtmax = sqrt( safmax/4 ) + if( f1 > rtmin .and. f1 < rtmax .and. & + g1 > rtmin .and. g1 < rtmax ) then +! +! Use unscaled algorithm +! + f2 = ABSSQ( f ) + g2 = ABSSQ( g ) + h2 = f2 + g2 + ! safmin <= f2 <= h2 <= safmax + if( f2 >= h2 * safmin ) then + ! safmin <= f2/h2 <= 1, and h2/f2 is finite + c = sqrt( f2 / h2 ) + r = f / c + rtmax = rtmax * 2 + if( f2 > rtmin .and. h2 < rtmax ) then + ! safmin <= sqrt( f2*h2 ) <= safmax + s = conjg( g ) * ( f / sqrt( f2*h2 ) ) + else + s = conjg( g ) * ( r / h2 ) + end if + else + ! f2/h2 <= safmin may be subnormal, and h2/f2 may overflow. + ! Moreover, + ! safmin <= f2*f2 * safmax < f2 * h2 < h2*h2 * safmin <= safmax, + ! sqrt(safmin) <= sqrt(f2 * h2) <= sqrt(safmax). + ! Also, + ! g2 >> f2, which means that h2 = g2. + d = sqrt( f2 * h2 ) + c = f2 / d + if( c >= safmin ) then + r = f / c + else + ! f2 / sqrt(f2 * h2) < safmin, then + ! sqrt(safmin) <= f2 * sqrt(safmax) <= h2 / sqrt(f2 * h2) <= h2 * (safmin / f2) <= h2 <= safmax + r = f * ( h2 / d ) + end if + s = conjg( g ) * ( f / d ) + end if + else +! +! Use scaled algorithm +! + u = min( safmax, max( safmin, f1, g1 ) ) + gs = g / u + g2 = ABSSQ( gs ) + if( f1 / u < rtmin ) then +! +! f is not well-scaled when scaled by g1. +! Use a different scaling for f. +! + v = min( safmax, max( safmin, f1 ) ) + w = v / u + fs = f / v + f2 = ABSSQ( fs ) + h2 = f2*w**2 + g2 + else +! +! Otherwise use the same scaling for f and g. +! + w = one + fs = f / u + f2 = ABSSQ( fs ) + h2 = f2 + g2 + end if + ! safmin <= f2 <= h2 <= safmax + if( f2 >= h2 * safmin ) then + ! safmin <= f2/h2 <= 1, and h2/f2 is finite + c = sqrt( f2 / h2 ) + r = fs / c + rtmax = rtmax * 2 + if( f2 > rtmin .and. h2 < rtmax ) then + ! safmin <= sqrt( f2*h2 ) <= safmax + s = conjg( gs ) * ( fs / sqrt( f2*h2 ) ) + else + s = conjg( gs ) * ( r / h2 ) + end if + else + ! f2/h2 <= safmin may be subnormal, and h2/f2 may overflow. + ! Moreover, + ! safmin <= f2*f2 * safmax < f2 * h2 < h2*h2 * safmin <= safmax, + ! sqrt(safmin) <= sqrt(f2 * h2) <= sqrt(safmax). + ! Also, + ! g2 >> f2, which means that h2 = g2. + d = sqrt( f2 * h2 ) + c = f2 / d + if( c >= safmin ) then + r = fs / c + else + ! f2 / sqrt(f2 * h2) < safmin, then + ! sqrt(safmin) <= f2 * sqrt(safmax) <= h2 / sqrt(f2 * h2) <= h2 * (safmin / f2) <= h2 <= safmax + r = fs * ( h2 / d ) + end if + s = conjg( gs ) * ( fs / d ) + end if + ! Rescale c and r + c = c * w + r = r * u + end if + end if + a = r + return +end subroutine diff --git a/fortran_implementation/external_libraries/BLAS/SRC/cscal.f b/fortran_implementation/external_libraries/BLAS/SRC/cscal.f new file mode 100644 index 0000000..0fbfb72 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/cscal.f @@ -0,0 +1,121 @@ +*> \brief \b CSCAL +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CSCAL(N,CA,CX,INCX) +* +* .. Scalar Arguments .. +* COMPLEX CA +* INTEGER INCX,N +* .. +* .. Array Arguments .. +* COMPLEX CX(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CSCAL scales a vector by a constant. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] CA +*> \verbatim +*> CA is COMPLEX +*> On entry, CA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in,out] CX +*> \verbatim +*> CX is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of CX +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup scal +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, linpack, 3/11/78. +*> modified 3/93 to return if incx .le. 0. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CSCAL(N,CA,CX,INCX) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX CA + INTEGER INCX,N +* .. +* .. Array Arguments .. + COMPLEX CX(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,NINCX +* .. +* .. Parameters .. + COMPLEX ONE + PARAMETER (ONE= (1.0E+0,0.0E+0)) +* .. + IF (N.LE.0 .OR. INCX.LE.0 .OR. CA.EQ.ONE) RETURN + IF (INCX.EQ.1) THEN +* +* code for increment equal to 1 +* + DO I = 1,N + CX(I) = CA*CX(I) + END DO + ELSE +* +* code for increment not equal to 1 +* + NINCX = N*INCX + DO I = 1,NINCX,INCX + CX(I) = CA*CX(I) + END DO + END IF + RETURN +* +* End of CSCAL +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/csrot.f b/fortran_implementation/external_libraries/BLAS/SRC/csrot.f new file mode 100644 index 0000000..45f62c2 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/csrot.f @@ -0,0 +1,153 @@ +*> \brief \b CSROT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CSROT( N, CX, INCX, CY, INCY, C, S ) +* +* .. Scalar Arguments .. +* INTEGER INCX, INCY, N +* REAL C, S +* .. +* .. Array Arguments .. +* COMPLEX CX( * ), CY( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CSROT applies a plane rotation, where the cos and sin (c and s) are real +*> and the vectors cx and cy are complex. +*> jack dongarra, linpack, 3/11/78. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the vectors cx and cy. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in,out] CX +*> \verbatim +*> CX is COMPLEX array, dimension at least +*> ( 1 + ( N - 1 )*abs( INCX ) ). +*> Before entry, the incremented array CX must contain the n +*> element vector cx. On exit, CX is overwritten by the updated +*> vector cx. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> CX. INCX must not be zero. +*> \endverbatim +*> +*> \param[in,out] CY +*> \verbatim +*> CY is COMPLEX array, dimension at least +*> ( 1 + ( N - 1 )*abs( INCY ) ). +*> Before entry, the incremented array CY must contain the n +*> element vector cy. On exit, CY is overwritten by the updated +*> vector cy. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> CY. INCY must not be zero. +*> \endverbatim +*> +*> \param[in] C +*> \verbatim +*> C is REAL +*> On entry, C specifies the cosine, cos. +*> \endverbatim +*> +*> \param[in] S +*> \verbatim +*> S is REAL +*> On entry, S specifies the sine, sin. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup rot +* +* ===================================================================== + SUBROUTINE CSROT( N, CX, INCX, CY, INCY, C, S ) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX, INCY, N + REAL C, S +* .. +* .. Array Arguments .. + COMPLEX CX( * ), CY( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, IX, IY + COMPLEX CTEMP +* .. +* .. Executable Statements .. +* + IF( N.LE.0 ) + $ RETURN + IF( INCX.EQ.1 .AND. INCY.EQ.1 ) THEN +* +* code for both increments equal to 1 +* + DO I = 1, N + CTEMP = C*CX( I ) + S*CY( I ) + CY( I ) = C*CY( I ) - S*CX( I ) + CX( I ) = CTEMP + END DO + ELSE +* +* code for unequal increments or equal increments not equal +* to 1 +* + IX = 1 + IY = 1 + IF( INCX.LT.0 ) + $ IX = ( -N+1 )*INCX + 1 + IF( INCY.LT.0 ) + $ IY = ( -N+1 )*INCY + 1 + DO I = 1, N + CTEMP = C*CX( IX ) + S*CY( IY ) + CY( IY ) = C*CY( IY ) - S*CX( IX ) + CX( IX ) = CTEMP + IX = IX + INCX + IY = IY + INCY + END DO + END IF + RETURN +* +* End of CSROT +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/csscal.f b/fortran_implementation/external_libraries/BLAS/SRC/csscal.f new file mode 100644 index 0000000..45702c5 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/csscal.f @@ -0,0 +1,124 @@ +*> \brief \b CSSCAL +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CSSCAL(N,SA,CX,INCX) +* +* .. Scalar Arguments .. +* REAL SA +* INTEGER INCX,N +* .. +* .. Array Arguments .. +* COMPLEX CX(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CSSCAL scales a complex vector by a real constant. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] SA +*> \verbatim +*> SA is REAL +*> On entry, SA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in,out] CX +*> \verbatim +*> CX is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of CX +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup scal +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, linpack, 3/11/78. +*> modified 3/93 to return if incx .le. 0. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CSSCAL(N,SA,CX,INCX) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + REAL SA + INTEGER INCX,N +* .. +* .. Array Arguments .. + COMPLEX CX(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,NINCX +* .. +* .. Parameters .. + REAL ONE + PARAMETER (ONE=1.0E+0) +* .. +* .. Intrinsic Functions .. + INTRINSIC AIMAG,CMPLX,REAL +* .. + IF (N.LE.0 .OR. INCX.LE.0 .OR. SA.EQ.ONE) RETURN + IF (INCX.EQ.1) THEN +* +* code for increment equal to 1 +* + DO I = 1,N + CX(I) = CMPLX(SA*REAL(CX(I)),SA*AIMAG(CX(I))) + END DO + ELSE +* +* code for increment not equal to 1 +* + NINCX = N*INCX + DO I = 1,NINCX,INCX + CX(I) = CMPLX(SA*REAL(CX(I)),SA*AIMAG(CX(I))) + END DO + END IF + RETURN +* +* End of CSSCAL +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/cswap.f b/fortran_implementation/external_libraries/BLAS/SRC/cswap.f new file mode 100644 index 0000000..9962431 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/cswap.f @@ -0,0 +1,129 @@ +*> \brief \b CSWAP +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CSWAP(N,CX,INCX,CY,INCY) +* +* .. Scalar Arguments .. +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* COMPLEX CX(*),CY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CSWAP interchanges two vectors. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in,out] CX +*> \verbatim +*> CX is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of CX +*> \endverbatim +*> +*> \param[in,out] CY +*> \verbatim +*> CY is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of CY +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup swap +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, linpack, 3/11/78. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CSWAP(N,CX,INCX,CY,INCY) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + COMPLEX CX(*),CY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + COMPLEX CTEMP + INTEGER I,IX,IY +* .. + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 + DO I = 1,N + CTEMP = CX(I) + CX(I) = CY(I) + CY(I) = CTEMP + END DO + ELSE +* +* code for unequal increments or equal increments not equal +* to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + CTEMP = CX(IX) + CX(IX) = CY(IY) + CY(IY) = CTEMP + IX = IX + INCX + IY = IY + INCY + END DO + END IF + RETURN +* +* End of CSWAP +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/csymm.f b/fortran_implementation/external_libraries/BLAS/SRC/csymm.f new file mode 100644 index 0000000..9a7b360 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/csymm.f @@ -0,0 +1,368 @@ +*> \brief \b CSYMM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* .. Scalar Arguments .. +* COMPLEX ALPHA,BETA +* INTEGER LDA,LDB,LDC,M,N +* CHARACTER SIDE,UPLO +* .. +* .. Array Arguments .. +* COMPLEX A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CSYMM performs one of the matrix-matrix operations +*> +*> C := alpha*A*B + beta*C, +*> +*> or +*> +*> C := alpha*B*A + beta*C, +*> +*> where alpha and beta are scalars, A is a symmetric matrix and B and +*> C are m by n matrices. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> On entry, SIDE specifies whether the symmetric matrix A +*> appears on the left or right in the operation as follows: +*> +*> SIDE = 'L' or 'l' C := alpha*A*B + beta*C, +*> +*> SIDE = 'R' or 'r' C := alpha*B*A + beta*C, +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the symmetric matrix A is to be +*> referenced as follows: +*> +*> UPLO = 'U' or 'u' Only the upper triangular part of the +*> symmetric matrix is to be referenced. +*> +*> UPLO = 'L' or 'l' Only the lower triangular part of the +*> symmetric matrix is to be referenced. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix C. +*> M must be at least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of the matrix C. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX array, dimension ( LDA, ka ), where ka is +*> m when SIDE = 'L' or 'l' and is n otherwise. +*> Before entry with SIDE = 'L' or 'l', the m by m part of +*> the array A must contain the symmetric matrix, such that +*> when UPLO = 'U' or 'u', the leading m by m upper triangular +*> part of the array A must contain the upper triangular part +*> of the symmetric matrix and the strictly lower triangular +*> part of A is not referenced, and when UPLO = 'L' or 'l', +*> the leading m by m lower triangular part of the array A +*> must contain the lower triangular part of the symmetric +*> matrix and the strictly upper triangular part of A is not +*> referenced. +*> Before entry with SIDE = 'R' or 'r', the n by n part of +*> the array A must contain the symmetric matrix, such that +*> when UPLO = 'U' or 'u', the leading n by n upper triangular +*> part of the array A must contain the upper triangular part +*> of the symmetric matrix and the strictly lower triangular +*> part of A is not referenced, and when UPLO = 'L' or 'l', +*> the leading n by n lower triangular part of the array A +*> must contain the lower triangular part of the symmetric +*> matrix and the strictly upper triangular part of A is not +*> referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When SIDE = 'L' or 'l' then +*> LDA must be at least max( 1, m ), otherwise LDA must be at +*> least max( 1, n ). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is COMPLEX array, dimension ( LDB, N ) +*> Before entry, the leading m by n part of the array B must +*> contain the matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. LDB must be at least +*> max( 1, m ). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is COMPLEX +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then C need not be set on input. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX array, dimension ( LDC, N ) +*> Before entry, the leading m by n part of the array C must +*> contain the matrix C, except when beta is zero, in which +*> case C need not be set on entry. +*> On exit, the array C is overwritten by the m by n updated +*> matrix. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> On entry, LDC specifies the first dimension of C as declared +*> in the calling (sub) program. LDC must be at least +*> max( 1, m ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup hemm +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> -- Written on 8-February-1989. +*> Jack Dongarra, Argonne National Laboratory. +*> Iain Duff, AERE Harwell. +*> Jeremy Du Croz, Numerical Algorithms Group Ltd. +*> Sven Hammarling, Numerical Algorithms Group Ltd. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* -- Reference BLAS level3 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX ALPHA,BETA + INTEGER LDA,LDB,LDC,M,N + CHARACTER SIDE,UPLO +* .. +* .. Array Arguments .. + COMPLEX A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + COMPLEX TEMP1,TEMP2 + INTEGER I,INFO,J,K,NROWA + LOGICAL UPPER +* .. +* .. Parameters .. + COMPLEX ONE + PARAMETER (ONE= (1.0E+0,0.0E+0)) + COMPLEX ZERO + PARAMETER (ZERO= (0.0E+0,0.0E+0)) +* .. +* +* Set NROWA as the number of rows of A. +* + IF (LSAME(SIDE,'L')) THEN + NROWA = M + ELSE + NROWA = N + END IF + UPPER = LSAME(UPLO,'U') +* +* Test the input parameters. +* + INFO = 0 + IF ((.NOT.LSAME(SIDE,'L')) .AND. + + (.NOT.LSAME(SIDE,'R'))) THEN + INFO = 1 + ELSE IF ((.NOT.UPPER) .AND. + + (.NOT.LSAME(UPLO,'L'))) THEN + INFO = 2 + ELSE IF (M.LT.0) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 7 + ELSE IF (LDB.LT.MAX(1,M)) THEN + INFO = 9 + ELSE IF (LDC.LT.MAX(1,M)) THEN + INFO = 12 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('CSYMM ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. + + ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + IF (BETA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,M + C(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1,N + DO 30 I = 1,M + C(I,J) = BETA*C(I,J) + 30 CONTINUE + 40 CONTINUE + END IF + RETURN + END IF +* +* Start the operations. +* + IF (LSAME(SIDE,'L')) THEN +* +* Form C := alpha*A*B + beta*C. +* + IF (UPPER) THEN + DO 70 J = 1,N + DO 60 I = 1,M + TEMP1 = ALPHA*B(I,J) + TEMP2 = ZERO + DO 50 K = 1,I - 1 + C(K,J) = C(K,J) + TEMP1*A(K,I) + TEMP2 = TEMP2 + B(K,J)*A(K,I) + 50 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = TEMP1*A(I,I) + ALPHA*TEMP2 + ELSE + C(I,J) = BETA*C(I,J) + TEMP1*A(I,I) + + + ALPHA*TEMP2 + END IF + 60 CONTINUE + 70 CONTINUE + ELSE + DO 100 J = 1,N + DO 90 I = M,1,-1 + TEMP1 = ALPHA*B(I,J) + TEMP2 = ZERO + DO 80 K = I + 1,M + C(K,J) = C(K,J) + TEMP1*A(K,I) + TEMP2 = TEMP2 + B(K,J)*A(K,I) + 80 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = TEMP1*A(I,I) + ALPHA*TEMP2 + ELSE + C(I,J) = BETA*C(I,J) + TEMP1*A(I,I) + + + ALPHA*TEMP2 + END IF + 90 CONTINUE + 100 CONTINUE + END IF + ELSE +* +* Form C := alpha*B*A + beta*C. +* + DO 170 J = 1,N + TEMP1 = ALPHA*A(J,J) + IF (BETA.EQ.ZERO) THEN + DO 110 I = 1,M + C(I,J) = TEMP1*B(I,J) + 110 CONTINUE + ELSE + DO 120 I = 1,M + C(I,J) = BETA*C(I,J) + TEMP1*B(I,J) + 120 CONTINUE + END IF + DO 140 K = 1,J - 1 + IF (UPPER) THEN + TEMP1 = ALPHA*A(K,J) + ELSE + TEMP1 = ALPHA*A(J,K) + END IF + DO 130 I = 1,M + C(I,J) = C(I,J) + TEMP1*B(I,K) + 130 CONTINUE + 140 CONTINUE + DO 160 K = J + 1,N + IF (UPPER) THEN + TEMP1 = ALPHA*A(J,K) + ELSE + TEMP1 = ALPHA*A(K,J) + END IF + DO 150 I = 1,M + C(I,J) = C(I,J) + TEMP1*B(I,K) + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE + END IF +* + RETURN +* +* End of CSYMM +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/csyr2k.f b/fortran_implementation/external_libraries/BLAS/SRC/csyr2k.f new file mode 100644 index 0000000..5354c39 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/csyr2k.f @@ -0,0 +1,393 @@ +*> \brief \b CSYR2K +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* .. Scalar Arguments .. +* COMPLEX ALPHA,BETA +* INTEGER K,LDA,LDB,LDC,N +* CHARACTER TRANS,UPLO +* .. +* .. Array Arguments .. +* COMPLEX A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CSYR2K performs one of the symmetric rank 2k operations +*> +*> C := alpha*A*B**T + alpha*B*A**T + beta*C, +*> +*> or +*> +*> C := alpha*A**T*B + alpha*B**T*A + beta*C, +*> +*> where alpha and beta are scalars, C is an n by n symmetric matrix +*> and A and B are n by k matrices in the first case and k by n +*> matrices in the second case. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the array C is to be referenced as +*> follows: +*> +*> UPLO = 'U' or 'u' Only the upper triangular part of C +*> is to be referenced. +*> +*> UPLO = 'L' or 'l' Only the lower triangular part of C +*> is to be referenced. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the operation to be performed as +*> follows: +*> +*> TRANS = 'N' or 'n' C := alpha*A*B**T + alpha*B*A**T + +*> beta*C. +*> +*> TRANS = 'T' or 't' C := alpha*A**T*B + alpha*B**T*A + +*> beta*C. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix C. N must be +*> at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry with TRANS = 'N' or 'n', K specifies the number +*> of columns of the matrices A and B, and on entry with +*> TRANS = 'T' or 't', K specifies the number of rows of the +*> matrices A and B. K must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX array, dimension ( LDA, ka ), where ka is +*> k when TRANS = 'N' or 'n', and is n otherwise. +*> Before entry with TRANS = 'N' or 'n', the leading n by k +*> part of the array A must contain the matrix A, otherwise +*> the leading k by n part of the array A must contain the +*> matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When TRANS = 'N' or 'n' +*> then LDA must be at least max( 1, n ), otherwise LDA must +*> be at least max( 1, k ). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is COMPLEX array, dimension ( LDB, kb ), where kb is +*> k when TRANS = 'N' or 'n', and is n otherwise. +*> Before entry with TRANS = 'N' or 'n', the leading n by k +*> part of the array B must contain the matrix B, otherwise +*> the leading k by n part of the array B must contain the +*> matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. When TRANS = 'N' or 'n' +*> then LDB must be at least max( 1, n ), otherwise LDB must +*> be at least max( 1, k ). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is COMPLEX +*> On entry, BETA specifies the scalar beta. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX array, dimension ( LDC, N ) +*> Before entry with UPLO = 'U' or 'u', the leading n by n +*> upper triangular part of the array C must contain the upper +*> triangular part of the symmetric matrix and the strictly +*> lower triangular part of C is not referenced. On exit, the +*> upper triangular part of the array C is overwritten by the +*> upper triangular part of the updated matrix. +*> Before entry with UPLO = 'L' or 'l', the leading n by n +*> lower triangular part of the array C must contain the lower +*> triangular part of the symmetric matrix and the strictly +*> upper triangular part of C is not referenced. On exit, the +*> lower triangular part of the array C is overwritten by the +*> lower triangular part of the updated matrix. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> On entry, LDC specifies the first dimension of C as declared +*> in the calling (sub) program. LDC must be at least +*> max( 1, n ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup her2k +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> -- Written on 8-February-1989. +*> Jack Dongarra, Argonne National Laboratory. +*> Iain Duff, AERE Harwell. +*> Jeremy Du Croz, Numerical Algorithms Group Ltd. +*> Sven Hammarling, Numerical Algorithms Group Ltd. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* -- Reference BLAS level3 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX ALPHA,BETA + INTEGER K,LDA,LDB,LDC,N + CHARACTER TRANS,UPLO +* .. +* .. Array Arguments .. + COMPLEX A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + COMPLEX TEMP1,TEMP2 + INTEGER I,INFO,J,L,NROWA + LOGICAL UPPER +* .. +* .. Parameters .. + COMPLEX ONE + PARAMETER (ONE= (1.0E+0,0.0E+0)) + COMPLEX ZERO + PARAMETER (ZERO= (0.0E+0,0.0E+0)) +* .. +* +* Test the input parameters. +* + IF (LSAME(TRANS,'N')) THEN + NROWA = N + ELSE + NROWA = K + END IF + UPPER = LSAME(UPLO,'U') +* + INFO = 0 + IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN + INFO = 1 + ELSE IF ((.NOT.LSAME(TRANS,'N')) .AND. + + (.NOT.LSAME(TRANS,'T'))) THEN + INFO = 2 + ELSE IF (N.LT.0) THEN + INFO = 3 + ELSE IF (K.LT.0) THEN + INFO = 4 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 7 + ELSE IF (LDB.LT.MAX(1,NROWA)) THEN + INFO = 9 + ELSE IF (LDC.LT.MAX(1,N)) THEN + INFO = 12 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('CSYR2K',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR. + + (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + IF (UPPER) THEN + IF (BETA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,J + C(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1,N + DO 30 I = 1,J + C(I,J) = BETA*C(I,J) + 30 CONTINUE + 40 CONTINUE + END IF + ELSE + IF (BETA.EQ.ZERO) THEN + DO 60 J = 1,N + DO 50 I = J,N + C(I,J) = ZERO + 50 CONTINUE + 60 CONTINUE + ELSE + DO 80 J = 1,N + DO 70 I = J,N + C(I,J) = BETA*C(I,J) + 70 CONTINUE + 80 CONTINUE + END IF + END IF + RETURN + END IF +* +* Start the operations. +* + IF (LSAME(TRANS,'N')) THEN +* +* Form C := alpha*A*B**T + alpha*B*A**T + C. +* + IF (UPPER) THEN + DO 130 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 90 I = 1,J + C(I,J) = ZERO + 90 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 100 I = 1,J + C(I,J) = BETA*C(I,J) + 100 CONTINUE + END IF + DO 120 L = 1,K + IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN + TEMP1 = ALPHA*B(J,L) + TEMP2 = ALPHA*A(J,L) + DO 110 I = 1,J + C(I,J) = C(I,J) + A(I,L)*TEMP1 + + + B(I,L)*TEMP2 + 110 CONTINUE + END IF + 120 CONTINUE + 130 CONTINUE + ELSE + DO 180 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 140 I = J,N + C(I,J) = ZERO + 140 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 150 I = J,N + C(I,J) = BETA*C(I,J) + 150 CONTINUE + END IF + DO 170 L = 1,K + IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN + TEMP1 = ALPHA*B(J,L) + TEMP2 = ALPHA*A(J,L) + DO 160 I = J,N + C(I,J) = C(I,J) + A(I,L)*TEMP1 + + + B(I,L)*TEMP2 + 160 CONTINUE + END IF + 170 CONTINUE + 180 CONTINUE + END IF + ELSE +* +* Form C := alpha*A**T*B + alpha*B**T*A + C. +* + IF (UPPER) THEN + DO 210 J = 1,N + DO 200 I = 1,J + TEMP1 = ZERO + TEMP2 = ZERO + DO 190 L = 1,K + TEMP1 = TEMP1 + A(L,I)*B(L,J) + TEMP2 = TEMP2 + B(L,I)*A(L,J) + 190 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP1 + ALPHA*TEMP2 + ELSE + C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 + + + ALPHA*TEMP2 + END IF + 200 CONTINUE + 210 CONTINUE + ELSE + DO 240 J = 1,N + DO 230 I = J,N + TEMP1 = ZERO + TEMP2 = ZERO + DO 220 L = 1,K + TEMP1 = TEMP1 + A(L,I)*B(L,J) + TEMP2 = TEMP2 + B(L,I)*A(L,J) + 220 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP1 + ALPHA*TEMP2 + ELSE + C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 + + + ALPHA*TEMP2 + END IF + 230 CONTINUE + 240 CONTINUE + END IF + END IF +* + RETURN +* +* End of CSYR2K +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/csyrk.f b/fortran_implementation/external_libraries/BLAS/SRC/csyrk.f new file mode 100644 index 0000000..b6ff32d --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/csyrk.f @@ -0,0 +1,360 @@ +*> \brief \b CSYRK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) +* +* .. Scalar Arguments .. +* COMPLEX ALPHA,BETA +* INTEGER K,LDA,LDC,N +* CHARACTER TRANS,UPLO +* .. +* .. Array Arguments .. +* COMPLEX A(LDA,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CSYRK performs one of the symmetric rank k operations +*> +*> C := alpha*A*A**T + beta*C, +*> +*> or +*> +*> C := alpha*A**T*A + beta*C, +*> +*> where alpha and beta are scalars, C is an n by n symmetric matrix +*> and A is an n by k matrix in the first case and a k by n matrix +*> in the second case. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the array C is to be referenced as +*> follows: +*> +*> UPLO = 'U' or 'u' Only the upper triangular part of C +*> is to be referenced. +*> +*> UPLO = 'L' or 'l' Only the lower triangular part of C +*> is to be referenced. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the operation to be performed as +*> follows: +*> +*> TRANS = 'N' or 'n' C := alpha*A*A**T + beta*C. +*> +*> TRANS = 'T' or 't' C := alpha*A**T*A + beta*C. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix C. N must be +*> at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry with TRANS = 'N' or 'n', K specifies the number +*> of columns of the matrix A, and on entry with +*> TRANS = 'T' or 't', K specifies the number of rows of the +*> matrix A. K must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX array, dimension ( LDA, ka ), where ka is +*> k when TRANS = 'N' or 'n', and is n otherwise. +*> Before entry with TRANS = 'N' or 'n', the leading n by k +*> part of the array A must contain the matrix A, otherwise +*> the leading k by n part of the array A must contain the +*> matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When TRANS = 'N' or 'n' +*> then LDA must be at least max( 1, n ), otherwise LDA must +*> be at least max( 1, k ). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is COMPLEX +*> On entry, BETA specifies the scalar beta. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX array, dimension ( LDC, N ) +*> Before entry with UPLO = 'U' or 'u', the leading n by n +*> upper triangular part of the array C must contain the upper +*> triangular part of the symmetric matrix and the strictly +*> lower triangular part of C is not referenced. On exit, the +*> upper triangular part of the array C is overwritten by the +*> upper triangular part of the updated matrix. +*> Before entry with UPLO = 'L' or 'l', the leading n by n +*> lower triangular part of the array C must contain the lower +*> triangular part of the symmetric matrix and the strictly +*> upper triangular part of C is not referenced. On exit, the +*> lower triangular part of the array C is overwritten by the +*> lower triangular part of the updated matrix. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> On entry, LDC specifies the first dimension of C as declared +*> in the calling (sub) program. LDC must be at least +*> max( 1, n ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup herk +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> -- Written on 8-February-1989. +*> Jack Dongarra, Argonne National Laboratory. +*> Iain Duff, AERE Harwell. +*> Jeremy Du Croz, Numerical Algorithms Group Ltd. +*> Sven Hammarling, Numerical Algorithms Group Ltd. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) +* +* -- Reference BLAS level3 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX ALPHA,BETA + INTEGER K,LDA,LDC,N + CHARACTER TRANS,UPLO +* .. +* .. Array Arguments .. + COMPLEX A(LDA,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + COMPLEX TEMP + INTEGER I,INFO,J,L,NROWA + LOGICAL UPPER +* .. +* .. Parameters .. + COMPLEX ONE + PARAMETER (ONE= (1.0E+0,0.0E+0)) + COMPLEX ZERO + PARAMETER (ZERO= (0.0E+0,0.0E+0)) +* .. +* +* Test the input parameters. +* + IF (LSAME(TRANS,'N')) THEN + NROWA = N + ELSE + NROWA = K + END IF + UPPER = LSAME(UPLO,'U') +* + INFO = 0 + IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN + INFO = 1 + ELSE IF ((.NOT.LSAME(TRANS,'N')) .AND. + + (.NOT.LSAME(TRANS,'T'))) THEN + INFO = 2 + ELSE IF (N.LT.0) THEN + INFO = 3 + ELSE IF (K.LT.0) THEN + INFO = 4 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 7 + ELSE IF (LDC.LT.MAX(1,N)) THEN + INFO = 10 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('CSYRK ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR. + + (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + IF (UPPER) THEN + IF (BETA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,J + C(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1,N + DO 30 I = 1,J + C(I,J) = BETA*C(I,J) + 30 CONTINUE + 40 CONTINUE + END IF + ELSE + IF (BETA.EQ.ZERO) THEN + DO 60 J = 1,N + DO 50 I = J,N + C(I,J) = ZERO + 50 CONTINUE + 60 CONTINUE + ELSE + DO 80 J = 1,N + DO 70 I = J,N + C(I,J) = BETA*C(I,J) + 70 CONTINUE + 80 CONTINUE + END IF + END IF + RETURN + END IF +* +* Start the operations. +* + IF (LSAME(TRANS,'N')) THEN +* +* Form C := alpha*A*A**T + beta*C. +* + IF (UPPER) THEN + DO 130 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 90 I = 1,J + C(I,J) = ZERO + 90 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 100 I = 1,J + C(I,J) = BETA*C(I,J) + 100 CONTINUE + END IF + DO 120 L = 1,K + IF (A(J,L).NE.ZERO) THEN + TEMP = ALPHA*A(J,L) + DO 110 I = 1,J + C(I,J) = C(I,J) + TEMP*A(I,L) + 110 CONTINUE + END IF + 120 CONTINUE + 130 CONTINUE + ELSE + DO 180 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 140 I = J,N + C(I,J) = ZERO + 140 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 150 I = J,N + C(I,J) = BETA*C(I,J) + 150 CONTINUE + END IF + DO 170 L = 1,K + IF (A(J,L).NE.ZERO) THEN + TEMP = ALPHA*A(J,L) + DO 160 I = J,N + C(I,J) = C(I,J) + TEMP*A(I,L) + 160 CONTINUE + END IF + 170 CONTINUE + 180 CONTINUE + END IF + ELSE +* +* Form C := alpha*A**T*A + beta*C. +* + IF (UPPER) THEN + DO 210 J = 1,N + DO 200 I = 1,J + TEMP = ZERO + DO 190 L = 1,K + TEMP = TEMP + A(L,I)*A(L,J) + 190 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 200 CONTINUE + 210 CONTINUE + ELSE + DO 240 J = 1,N + DO 230 I = J,N + TEMP = ZERO + DO 220 L = 1,K + TEMP = TEMP + A(L,I)*A(L,J) + 220 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 230 CONTINUE + 240 CONTINUE + END IF + END IF +* + RETURN +* +* End of CSYRK +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/ctbmv.f b/fortran_implementation/external_libraries/BLAS/SRC/ctbmv.f new file mode 100644 index 0000000..2008d83 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/ctbmv.f @@ -0,0 +1,428 @@ +*> \brief \b CTBMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CTBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,K,LDA,N +* CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. +* COMPLEX A(LDA,*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CTBMV performs one of the matrix-vector operations +*> +*> x := A*x, or x := A**T*x, or x := A**H*x, +*> +*> where x is an n element vector and A is an n by n unit, or non-unit, +*> upper or lower triangular band matrix, with ( k + 1 ) diagonals. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the matrix is an upper or +*> lower triangular matrix as follows: +*> +*> UPLO = 'U' or 'u' A is an upper triangular matrix. +*> +*> UPLO = 'L' or 'l' A is a lower triangular matrix. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the operation to be performed as +*> follows: +*> +*> TRANS = 'N' or 'n' x := A*x. +*> +*> TRANS = 'T' or 't' x := A**T*x. +*> +*> TRANS = 'C' or 'c' x := A**H*x. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> On entry, DIAG specifies whether or not A is unit +*> triangular as follows: +*> +*> DIAG = 'U' or 'u' A is assumed to be unit triangular. +*> +*> DIAG = 'N' or 'n' A is not assumed to be unit +*> triangular. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry with UPLO = 'U' or 'u', K specifies the number of +*> super-diagonals of the matrix A. +*> On entry with UPLO = 'L' or 'l', K specifies the number of +*> sub-diagonals of the matrix A. +*> K must satisfy 0 .le. K. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX array, dimension ( LDA, N ). +*> Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) +*> by n part of the array A must contain the upper triangular +*> band part of the matrix of coefficients, supplied column by +*> column, with the leading diagonal of the matrix in row +*> ( k + 1 ) of the array, the first super-diagonal starting at +*> position 2 in row k, and so on. The top left k by k triangle +*> of the array A is not referenced. +*> The following program segment will transfer an upper +*> triangular band matrix from conventional full matrix storage +*> to band storage: +*> +*> DO 20, J = 1, N +*> M = K + 1 - J +*> DO 10, I = MAX( 1, J - K ), J +*> A( M + I, J ) = matrix( I, J ) +*> 10 CONTINUE +*> 20 CONTINUE +*> +*> Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) +*> by n part of the array A must contain the lower triangular +*> band part of the matrix of coefficients, supplied column by +*> column, with the leading diagonal of the matrix in row 1 of +*> the array, the first sub-diagonal starting at position 1 in +*> row 2, and so on. The bottom right k by k triangle of the +*> array A is not referenced. +*> The following program segment will transfer a lower +*> triangular band matrix from conventional full matrix storage +*> to band storage: +*> +*> DO 20, J = 1, N +*> M = 1 - J +*> DO 10, I = J, MIN( N, J + K ) +*> A( M + I, J ) = matrix( I, J ) +*> 10 CONTINUE +*> 20 CONTINUE +*> +*> Note that when DIAG = 'U' or 'u' the elements of the array A +*> corresponding to the diagonal elements of the matrix are not +*> referenced, but are assumed to be unity. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> ( k + 1 ). +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is COMPLEX array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element vector x. On exit, X is overwritten with the +*> transformed vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup tbmv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> The vector and matrix arguments are not referenced when N = 0, or M = 0 +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CTBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,K,LDA,N + CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. + COMPLEX A(LDA,*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX ZERO + PARAMETER (ZERO= (0.0E+0,0.0E+0)) +* .. +* .. Local Scalars .. + COMPLEX TEMP + INTEGER I,INFO,IX,J,JX,KPLUS1,KX,L + LOGICAL NOCONJ,NOUNIT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC CONJG,MAX,MIN +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (.NOT.LSAME(TRANS,'N') .AND. + + .NOT.LSAME(TRANS,'T') .AND. + + .NOT.LSAME(TRANS,'C')) THEN + INFO = 2 + ELSE IF (.NOT.LSAME(DIAG,'U') .AND. + + .NOT.LSAME(DIAG,'N')) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (K.LT.0) THEN + INFO = 5 + ELSE IF (LDA.LT. (K+1)) THEN + INFO = 7 + ELSE IF (INCX.EQ.0) THEN + INFO = 9 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('CTBMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (N.EQ.0) RETURN +* + NOCONJ = LSAME(TRANS,'T') + NOUNIT = LSAME(DIAG,'N') +* +* Set up the start point in X if the increment is not unity. This +* will be ( N - 1 )*INCX too small for descending loops. +* + IF (INCX.LE.0) THEN + KX = 1 - (N-1)*INCX + ELSE IF (INCX.NE.1) THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* + IF (LSAME(TRANS,'N')) THEN +* +* Form x := A*x. +* + IF (LSAME(UPLO,'U')) THEN + KPLUS1 = K + 1 + IF (INCX.EQ.1) THEN + DO 20 J = 1,N + IF (X(J).NE.ZERO) THEN + TEMP = X(J) + L = KPLUS1 - J + DO 10 I = MAX(1,J-K),J - 1 + X(I) = X(I) + TEMP*A(L+I,J) + 10 CONTINUE + IF (NOUNIT) X(J) = X(J)*A(KPLUS1,J) + END IF + 20 CONTINUE + ELSE + JX = KX + DO 40 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = X(JX) + IX = KX + L = KPLUS1 - J + DO 30 I = MAX(1,J-K),J - 1 + X(IX) = X(IX) + TEMP*A(L+I,J) + IX = IX + INCX + 30 CONTINUE + IF (NOUNIT) X(JX) = X(JX)*A(KPLUS1,J) + END IF + JX = JX + INCX + IF (J.GT.K) KX = KX + INCX + 40 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 60 J = N,1,-1 + IF (X(J).NE.ZERO) THEN + TEMP = X(J) + L = 1 - J + DO 50 I = MIN(N,J+K),J + 1,-1 + X(I) = X(I) + TEMP*A(L+I,J) + 50 CONTINUE + IF (NOUNIT) X(J) = X(J)*A(1,J) + END IF + 60 CONTINUE + ELSE + KX = KX + (N-1)*INCX + JX = KX + DO 80 J = N,1,-1 + IF (X(JX).NE.ZERO) THEN + TEMP = X(JX) + IX = KX + L = 1 - J + DO 70 I = MIN(N,J+K),J + 1,-1 + X(IX) = X(IX) + TEMP*A(L+I,J) + IX = IX - INCX + 70 CONTINUE + IF (NOUNIT) X(JX) = X(JX)*A(1,J) + END IF + JX = JX - INCX + IF ((N-J).GE.K) KX = KX - INCX + 80 CONTINUE + END IF + END IF + ELSE +* +* Form x := A**T*x or x := A**H*x. +* + IF (LSAME(UPLO,'U')) THEN + KPLUS1 = K + 1 + IF (INCX.EQ.1) THEN + DO 110 J = N,1,-1 + TEMP = X(J) + L = KPLUS1 - J + IF (NOCONJ) THEN + IF (NOUNIT) TEMP = TEMP*A(KPLUS1,J) + DO 90 I = J - 1,MAX(1,J-K),-1 + TEMP = TEMP + A(L+I,J)*X(I) + 90 CONTINUE + ELSE + IF (NOUNIT) TEMP = TEMP*CONJG(A(KPLUS1,J)) + DO 100 I = J - 1,MAX(1,J-K),-1 + TEMP = TEMP + CONJG(A(L+I,J))*X(I) + 100 CONTINUE + END IF + X(J) = TEMP + 110 CONTINUE + ELSE + KX = KX + (N-1)*INCX + JX = KX + DO 140 J = N,1,-1 + TEMP = X(JX) + KX = KX - INCX + IX = KX + L = KPLUS1 - J + IF (NOCONJ) THEN + IF (NOUNIT) TEMP = TEMP*A(KPLUS1,J) + DO 120 I = J - 1,MAX(1,J-K),-1 + TEMP = TEMP + A(L+I,J)*X(IX) + IX = IX - INCX + 120 CONTINUE + ELSE + IF (NOUNIT) TEMP = TEMP*CONJG(A(KPLUS1,J)) + DO 130 I = J - 1,MAX(1,J-K),-1 + TEMP = TEMP + CONJG(A(L+I,J))*X(IX) + IX = IX - INCX + 130 CONTINUE + END IF + X(JX) = TEMP + JX = JX - INCX + 140 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 170 J = 1,N + TEMP = X(J) + L = 1 - J + IF (NOCONJ) THEN + IF (NOUNIT) TEMP = TEMP*A(1,J) + DO 150 I = J + 1,MIN(N,J+K) + TEMP = TEMP + A(L+I,J)*X(I) + 150 CONTINUE + ELSE + IF (NOUNIT) TEMP = TEMP*CONJG(A(1,J)) + DO 160 I = J + 1,MIN(N,J+K) + TEMP = TEMP + CONJG(A(L+I,J))*X(I) + 160 CONTINUE + END IF + X(J) = TEMP + 170 CONTINUE + ELSE + JX = KX + DO 200 J = 1,N + TEMP = X(JX) + KX = KX + INCX + IX = KX + L = 1 - J + IF (NOCONJ) THEN + IF (NOUNIT) TEMP = TEMP*A(1,J) + DO 180 I = J + 1,MIN(N,J+K) + TEMP = TEMP + A(L+I,J)*X(IX) + IX = IX + INCX + 180 CONTINUE + ELSE + IF (NOUNIT) TEMP = TEMP*CONJG(A(1,J)) + DO 190 I = J + 1,MIN(N,J+K) + TEMP = TEMP + CONJG(A(L+I,J))*X(IX) + IX = IX + INCX + 190 CONTINUE + END IF + X(JX) = TEMP + JX = JX + INCX + 200 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of CTBMV +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/ctbsv.f b/fortran_implementation/external_libraries/BLAS/SRC/ctbsv.f new file mode 100644 index 0000000..2559241 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/ctbsv.f @@ -0,0 +1,431 @@ +*> \brief \b CTBSV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CTBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,K,LDA,N +* CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. +* COMPLEX A(LDA,*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CTBSV solves one of the systems of equations +*> +*> A*x = b, or A**T*x = b, or A**H*x = b, +*> +*> where b and x are n element vectors and A is an n by n unit, or +*> non-unit, upper or lower triangular band matrix, with ( k + 1 ) +*> diagonals. +*> +*> No test for singularity or near-singularity is included in this +*> routine. Such tests must be performed before calling this routine. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the matrix is an upper or +*> lower triangular matrix as follows: +*> +*> UPLO = 'U' or 'u' A is an upper triangular matrix. +*> +*> UPLO = 'L' or 'l' A is a lower triangular matrix. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the equations to be solved as +*> follows: +*> +*> TRANS = 'N' or 'n' A*x = b. +*> +*> TRANS = 'T' or 't' A**T*x = b. +*> +*> TRANS = 'C' or 'c' A**H*x = b. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> On entry, DIAG specifies whether or not A is unit +*> triangular as follows: +*> +*> DIAG = 'U' or 'u' A is assumed to be unit triangular. +*> +*> DIAG = 'N' or 'n' A is not assumed to be unit +*> triangular. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry with UPLO = 'U' or 'u', K specifies the number of +*> super-diagonals of the matrix A. +*> On entry with UPLO = 'L' or 'l', K specifies the number of +*> sub-diagonals of the matrix A. +*> K must satisfy 0 .le. K. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX array, dimension ( LDA, N ) +*> Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) +*> by n part of the array A must contain the upper triangular +*> band part of the matrix of coefficients, supplied column by +*> column, with the leading diagonal of the matrix in row +*> ( k + 1 ) of the array, the first super-diagonal starting at +*> position 2 in row k, and so on. The top left k by k triangle +*> of the array A is not referenced. +*> The following program segment will transfer an upper +*> triangular band matrix from conventional full matrix storage +*> to band storage: +*> +*> DO 20, J = 1, N +*> M = K + 1 - J +*> DO 10, I = MAX( 1, J - K ), J +*> A( M + I, J ) = matrix( I, J ) +*> 10 CONTINUE +*> 20 CONTINUE +*> +*> Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) +*> by n part of the array A must contain the lower triangular +*> band part of the matrix of coefficients, supplied column by +*> column, with the leading diagonal of the matrix in row 1 of +*> the array, the first sub-diagonal starting at position 1 in +*> row 2, and so on. The bottom right k by k triangle of the +*> array A is not referenced. +*> The following program segment will transfer a lower +*> triangular band matrix from conventional full matrix storage +*> to band storage: +*> +*> DO 20, J = 1, N +*> M = 1 - J +*> DO 10, I = J, MIN( N, J + K ) +*> A( M + I, J ) = matrix( I, J ) +*> 10 CONTINUE +*> 20 CONTINUE +*> +*> Note that when DIAG = 'U' or 'u' the elements of the array A +*> corresponding to the diagonal elements of the matrix are not +*> referenced, but are assumed to be unity. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> ( k + 1 ). +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is COMPLEX array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element right-hand side vector b. On exit, X is overwritten +*> with the solution vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup tbsv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CTBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,K,LDA,N + CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. + COMPLEX A(LDA,*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX ZERO + PARAMETER (ZERO= (0.0E+0,0.0E+0)) +* .. +* .. Local Scalars .. + COMPLEX TEMP + INTEGER I,INFO,IX,J,JX,KPLUS1,KX,L + LOGICAL NOCONJ,NOUNIT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC CONJG,MAX,MIN +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (.NOT.LSAME(TRANS,'N') .AND. + + .NOT.LSAME(TRANS,'T') .AND. + + .NOT.LSAME(TRANS,'C')) THEN + INFO = 2 + ELSE IF (.NOT.LSAME(DIAG,'U') .AND. + + .NOT.LSAME(DIAG,'N')) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (K.LT.0) THEN + INFO = 5 + ELSE IF (LDA.LT. (K+1)) THEN + INFO = 7 + ELSE IF (INCX.EQ.0) THEN + INFO = 9 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('CTBSV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (N.EQ.0) RETURN +* + NOCONJ = LSAME(TRANS,'T') + NOUNIT = LSAME(DIAG,'N') +* +* Set up the start point in X if the increment is not unity. This +* will be ( N - 1 )*INCX too small for descending loops. +* + IF (INCX.LE.0) THEN + KX = 1 - (N-1)*INCX + ELSE IF (INCX.NE.1) THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of A are +* accessed by sequentially with one pass through A. +* + IF (LSAME(TRANS,'N')) THEN +* +* Form x := inv( A )*x. +* + IF (LSAME(UPLO,'U')) THEN + KPLUS1 = K + 1 + IF (INCX.EQ.1) THEN + DO 20 J = N,1,-1 + IF (X(J).NE.ZERO) THEN + L = KPLUS1 - J + IF (NOUNIT) X(J) = X(J)/A(KPLUS1,J) + TEMP = X(J) + DO 10 I = J - 1,MAX(1,J-K),-1 + X(I) = X(I) - TEMP*A(L+I,J) + 10 CONTINUE + END IF + 20 CONTINUE + ELSE + KX = KX + (N-1)*INCX + JX = KX + DO 40 J = N,1,-1 + KX = KX - INCX + IF (X(JX).NE.ZERO) THEN + IX = KX + L = KPLUS1 - J + IF (NOUNIT) X(JX) = X(JX)/A(KPLUS1,J) + TEMP = X(JX) + DO 30 I = J - 1,MAX(1,J-K),-1 + X(IX) = X(IX) - TEMP*A(L+I,J) + IX = IX - INCX + 30 CONTINUE + END IF + JX = JX - INCX + 40 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 60 J = 1,N + IF (X(J).NE.ZERO) THEN + L = 1 - J + IF (NOUNIT) X(J) = X(J)/A(1,J) + TEMP = X(J) + DO 50 I = J + 1,MIN(N,J+K) + X(I) = X(I) - TEMP*A(L+I,J) + 50 CONTINUE + END IF + 60 CONTINUE + ELSE + JX = KX + DO 80 J = 1,N + KX = KX + INCX + IF (X(JX).NE.ZERO) THEN + IX = KX + L = 1 - J + IF (NOUNIT) X(JX) = X(JX)/A(1,J) + TEMP = X(JX) + DO 70 I = J + 1,MIN(N,J+K) + X(IX) = X(IX) - TEMP*A(L+I,J) + IX = IX + INCX + 70 CONTINUE + END IF + JX = JX + INCX + 80 CONTINUE + END IF + END IF + ELSE +* +* Form x := inv( A**T )*x or x := inv( A**H )*x. +* + IF (LSAME(UPLO,'U')) THEN + KPLUS1 = K + 1 + IF (INCX.EQ.1) THEN + DO 110 J = 1,N + TEMP = X(J) + L = KPLUS1 - J + IF (NOCONJ) THEN + DO 90 I = MAX(1,J-K),J - 1 + TEMP = TEMP - A(L+I,J)*X(I) + 90 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(KPLUS1,J) + ELSE + DO 100 I = MAX(1,J-K),J - 1 + TEMP = TEMP - CONJG(A(L+I,J))*X(I) + 100 CONTINUE + IF (NOUNIT) TEMP = TEMP/CONJG(A(KPLUS1,J)) + END IF + X(J) = TEMP + 110 CONTINUE + ELSE + JX = KX + DO 140 J = 1,N + TEMP = X(JX) + IX = KX + L = KPLUS1 - J + IF (NOCONJ) THEN + DO 120 I = MAX(1,J-K),J - 1 + TEMP = TEMP - A(L+I,J)*X(IX) + IX = IX + INCX + 120 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(KPLUS1,J) + ELSE + DO 130 I = MAX(1,J-K),J - 1 + TEMP = TEMP - CONJG(A(L+I,J))*X(IX) + IX = IX + INCX + 130 CONTINUE + IF (NOUNIT) TEMP = TEMP/CONJG(A(KPLUS1,J)) + END IF + X(JX) = TEMP + JX = JX + INCX + IF (J.GT.K) KX = KX + INCX + 140 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 170 J = N,1,-1 + TEMP = X(J) + L = 1 - J + IF (NOCONJ) THEN + DO 150 I = MIN(N,J+K),J + 1,-1 + TEMP = TEMP - A(L+I,J)*X(I) + 150 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(1,J) + ELSE + DO 160 I = MIN(N,J+K),J + 1,-1 + TEMP = TEMP - CONJG(A(L+I,J))*X(I) + 160 CONTINUE + IF (NOUNIT) TEMP = TEMP/CONJG(A(1,J)) + END IF + X(J) = TEMP + 170 CONTINUE + ELSE + KX = KX + (N-1)*INCX + JX = KX + DO 200 J = N,1,-1 + TEMP = X(JX) + IX = KX + L = 1 - J + IF (NOCONJ) THEN + DO 180 I = MIN(N,J+K),J + 1,-1 + TEMP = TEMP - A(L+I,J)*X(IX) + IX = IX - INCX + 180 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(1,J) + ELSE + DO 190 I = MIN(N,J+K),J + 1,-1 + TEMP = TEMP - CONJG(A(L+I,J))*X(IX) + IX = IX - INCX + 190 CONTINUE + IF (NOUNIT) TEMP = TEMP/CONJG(A(1,J)) + END IF + X(JX) = TEMP + JX = JX - INCX + IF ((N-J).GE.K) KX = KX - INCX + 200 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of CTBSV +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/ctpmv.f b/fortran_implementation/external_libraries/BLAS/SRC/ctpmv.f new file mode 100644 index 0000000..3187386 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/ctpmv.f @@ -0,0 +1,387 @@ +*> \brief \b CTPMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CTPMV(UPLO,TRANS,DIAG,N,AP,X,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,N +* CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. +* COMPLEX AP(*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CTPMV performs one of the matrix-vector operations +*> +*> x := A*x, or x := A**T*x, or x := A**H*x, +*> +*> where x is an n element vector and A is an n by n unit, or non-unit, +*> upper or lower triangular matrix, supplied in packed form. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the matrix is an upper or +*> lower triangular matrix as follows: +*> +*> UPLO = 'U' or 'u' A is an upper triangular matrix. +*> +*> UPLO = 'L' or 'l' A is a lower triangular matrix. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the operation to be performed as +*> follows: +*> +*> TRANS = 'N' or 'n' x := A*x. +*> +*> TRANS = 'T' or 't' x := A**T*x. +*> +*> TRANS = 'C' or 'c' x := A**H*x. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> On entry, DIAG specifies whether or not A is unit +*> triangular as follows: +*> +*> DIAG = 'U' or 'u' A is assumed to be unit triangular. +*> +*> DIAG = 'N' or 'n' A is not assumed to be unit +*> triangular. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] AP +*> \verbatim +*> AP is COMPLEX array, dimension at least +*> ( ( n*( n + 1 ) )/2 ). +*> Before entry with UPLO = 'U' or 'u', the array AP must +*> contain the upper triangular matrix packed sequentially, +*> column by column, so that AP( 1 ) contains a( 1, 1 ), +*> AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) +*> respectively, and so on. +*> Before entry with UPLO = 'L' or 'l', the array AP must +*> contain the lower triangular matrix packed sequentially, +*> column by column, so that AP( 1 ) contains a( 1, 1 ), +*> AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) +*> respectively, and so on. +*> Note that when DIAG = 'U' or 'u', the diagonal elements of +*> A are not referenced, but are assumed to be unity. +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is COMPLEX array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element vector x. On exit, X is overwritten with the +*> transformed vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup tpmv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> The vector and matrix arguments are not referenced when N = 0, or M = 0 +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CTPMV(UPLO,TRANS,DIAG,N,AP,X,INCX) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,N + CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. + COMPLEX AP(*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX ZERO + PARAMETER (ZERO= (0.0E+0,0.0E+0)) +* .. +* .. Local Scalars .. + COMPLEX TEMP + INTEGER I,INFO,IX,J,JX,K,KK,KX + LOGICAL NOCONJ,NOUNIT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC CONJG +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (.NOT.LSAME(TRANS,'N') .AND. + + .NOT.LSAME(TRANS,'T') .AND. + + .NOT.LSAME(TRANS,'C')) THEN + INFO = 2 + ELSE IF (.NOT.LSAME(DIAG,'U') .AND. + + .NOT.LSAME(DIAG,'N')) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (INCX.EQ.0) THEN + INFO = 7 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('CTPMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (N.EQ.0) RETURN +* + NOCONJ = LSAME(TRANS,'T') + NOUNIT = LSAME(DIAG,'N') +* +* Set up the start point in X if the increment is not unity. This +* will be ( N - 1 )*INCX too small for descending loops. +* + IF (INCX.LE.0) THEN + KX = 1 - (N-1)*INCX + ELSE IF (INCX.NE.1) THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of AP are +* accessed sequentially with one pass through AP. +* + IF (LSAME(TRANS,'N')) THEN +* +* Form x:= A*x. +* + IF (LSAME(UPLO,'U')) THEN + KK = 1 + IF (INCX.EQ.1) THEN + DO 20 J = 1,N + IF (X(J).NE.ZERO) THEN + TEMP = X(J) + K = KK + DO 10 I = 1,J - 1 + X(I) = X(I) + TEMP*AP(K) + K = K + 1 + 10 CONTINUE + IF (NOUNIT) X(J) = X(J)*AP(KK+J-1) + END IF + KK = KK + J + 20 CONTINUE + ELSE + JX = KX + DO 40 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = X(JX) + IX = KX + DO 30 K = KK,KK + J - 2 + X(IX) = X(IX) + TEMP*AP(K) + IX = IX + INCX + 30 CONTINUE + IF (NOUNIT) X(JX) = X(JX)*AP(KK+J-1) + END IF + JX = JX + INCX + KK = KK + J + 40 CONTINUE + END IF + ELSE + KK = (N* (N+1))/2 + IF (INCX.EQ.1) THEN + DO 60 J = N,1,-1 + IF (X(J).NE.ZERO) THEN + TEMP = X(J) + K = KK + DO 50 I = N,J + 1,-1 + X(I) = X(I) + TEMP*AP(K) + K = K - 1 + 50 CONTINUE + IF (NOUNIT) X(J) = X(J)*AP(KK-N+J) + END IF + KK = KK - (N-J+1) + 60 CONTINUE + ELSE + KX = KX + (N-1)*INCX + JX = KX + DO 80 J = N,1,-1 + IF (X(JX).NE.ZERO) THEN + TEMP = X(JX) + IX = KX + DO 70 K = KK,KK - (N- (J+1)),-1 + X(IX) = X(IX) + TEMP*AP(K) + IX = IX - INCX + 70 CONTINUE + IF (NOUNIT) X(JX) = X(JX)*AP(KK-N+J) + END IF + JX = JX - INCX + KK = KK - (N-J+1) + 80 CONTINUE + END IF + END IF + ELSE +* +* Form x := A**T*x or x := A**H*x. +* + IF (LSAME(UPLO,'U')) THEN + KK = (N* (N+1))/2 + IF (INCX.EQ.1) THEN + DO 110 J = N,1,-1 + TEMP = X(J) + K = KK - 1 + IF (NOCONJ) THEN + IF (NOUNIT) TEMP = TEMP*AP(KK) + DO 90 I = J - 1,1,-1 + TEMP = TEMP + AP(K)*X(I) + K = K - 1 + 90 CONTINUE + ELSE + IF (NOUNIT) TEMP = TEMP*CONJG(AP(KK)) + DO 100 I = J - 1,1,-1 + TEMP = TEMP + CONJG(AP(K))*X(I) + K = K - 1 + 100 CONTINUE + END IF + X(J) = TEMP + KK = KK - J + 110 CONTINUE + ELSE + JX = KX + (N-1)*INCX + DO 140 J = N,1,-1 + TEMP = X(JX) + IX = JX + IF (NOCONJ) THEN + IF (NOUNIT) TEMP = TEMP*AP(KK) + DO 120 K = KK - 1,KK - J + 1,-1 + IX = IX - INCX + TEMP = TEMP + AP(K)*X(IX) + 120 CONTINUE + ELSE + IF (NOUNIT) TEMP = TEMP*CONJG(AP(KK)) + DO 130 K = KK - 1,KK - J + 1,-1 + IX = IX - INCX + TEMP = TEMP + CONJG(AP(K))*X(IX) + 130 CONTINUE + END IF + X(JX) = TEMP + JX = JX - INCX + KK = KK - J + 140 CONTINUE + END IF + ELSE + KK = 1 + IF (INCX.EQ.1) THEN + DO 170 J = 1,N + TEMP = X(J) + K = KK + 1 + IF (NOCONJ) THEN + IF (NOUNIT) TEMP = TEMP*AP(KK) + DO 150 I = J + 1,N + TEMP = TEMP + AP(K)*X(I) + K = K + 1 + 150 CONTINUE + ELSE + IF (NOUNIT) TEMP = TEMP*CONJG(AP(KK)) + DO 160 I = J + 1,N + TEMP = TEMP + CONJG(AP(K))*X(I) + K = K + 1 + 160 CONTINUE + END IF + X(J) = TEMP + KK = KK + (N-J+1) + 170 CONTINUE + ELSE + JX = KX + DO 200 J = 1,N + TEMP = X(JX) + IX = JX + IF (NOCONJ) THEN + IF (NOUNIT) TEMP = TEMP*AP(KK) + DO 180 K = KK + 1,KK + N - J + IX = IX + INCX + TEMP = TEMP + AP(K)*X(IX) + 180 CONTINUE + ELSE + IF (NOUNIT) TEMP = TEMP*CONJG(AP(KK)) + DO 190 K = KK + 1,KK + N - J + IX = IX + INCX + TEMP = TEMP + CONJG(AP(K))*X(IX) + 190 CONTINUE + END IF + X(JX) = TEMP + JX = JX + INCX + KK = KK + (N-J+1) + 200 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of CTPMV +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/ctpsv.f b/fortran_implementation/external_libraries/BLAS/SRC/ctpsv.f new file mode 100644 index 0000000..c7ba280 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/ctpsv.f @@ -0,0 +1,389 @@ +*> \brief \b CTPSV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CTPSV(UPLO,TRANS,DIAG,N,AP,X,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,N +* CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. +* COMPLEX AP(*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CTPSV solves one of the systems of equations +*> +*> A*x = b, or A**T*x = b, or A**H*x = b, +*> +*> where b and x are n element vectors and A is an n by n unit, or +*> non-unit, upper or lower triangular matrix, supplied in packed form. +*> +*> No test for singularity or near-singularity is included in this +*> routine. Such tests must be performed before calling this routine. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the matrix is an upper or +*> lower triangular matrix as follows: +*> +*> UPLO = 'U' or 'u' A is an upper triangular matrix. +*> +*> UPLO = 'L' or 'l' A is a lower triangular matrix. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the equations to be solved as +*> follows: +*> +*> TRANS = 'N' or 'n' A*x = b. +*> +*> TRANS = 'T' or 't' A**T*x = b. +*> +*> TRANS = 'C' or 'c' A**H*x = b. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> On entry, DIAG specifies whether or not A is unit +*> triangular as follows: +*> +*> DIAG = 'U' or 'u' A is assumed to be unit triangular. +*> +*> DIAG = 'N' or 'n' A is not assumed to be unit +*> triangular. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] AP +*> \verbatim +*> AP is COMPLEX array, dimension at least +*> ( ( n*( n + 1 ) )/2 ). +*> Before entry with UPLO = 'U' or 'u', the array AP must +*> contain the upper triangular matrix packed sequentially, +*> column by column, so that AP( 1 ) contains a( 1, 1 ), +*> AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) +*> respectively, and so on. +*> Before entry with UPLO = 'L' or 'l', the array AP must +*> contain the lower triangular matrix packed sequentially, +*> column by column, so that AP( 1 ) contains a( 1, 1 ), +*> AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) +*> respectively, and so on. +*> Note that when DIAG = 'U' or 'u', the diagonal elements of +*> A are not referenced, but are assumed to be unity. +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is COMPLEX array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element right-hand side vector b. On exit, X is overwritten +*> with the solution vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup tpsv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CTPSV(UPLO,TRANS,DIAG,N,AP,X,INCX) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,N + CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. + COMPLEX AP(*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX ZERO + PARAMETER (ZERO= (0.0E+0,0.0E+0)) +* .. +* .. Local Scalars .. + COMPLEX TEMP + INTEGER I,INFO,IX,J,JX,K,KK,KX + LOGICAL NOCONJ,NOUNIT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC CONJG +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (.NOT.LSAME(TRANS,'N') .AND. + + .NOT.LSAME(TRANS,'T') .AND. + + .NOT.LSAME(TRANS,'C')) THEN + INFO = 2 + ELSE IF (.NOT.LSAME(DIAG,'U') .AND. + + .NOT.LSAME(DIAG,'N')) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (INCX.EQ.0) THEN + INFO = 7 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('CTPSV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (N.EQ.0) RETURN +* + NOCONJ = LSAME(TRANS,'T') + NOUNIT = LSAME(DIAG,'N') +* +* Set up the start point in X if the increment is not unity. This +* will be ( N - 1 )*INCX too small for descending loops. +* + IF (INCX.LE.0) THEN + KX = 1 - (N-1)*INCX + ELSE IF (INCX.NE.1) THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of AP are +* accessed sequentially with one pass through AP. +* + IF (LSAME(TRANS,'N')) THEN +* +* Form x := inv( A )*x. +* + IF (LSAME(UPLO,'U')) THEN + KK = (N* (N+1))/2 + IF (INCX.EQ.1) THEN + DO 20 J = N,1,-1 + IF (X(J).NE.ZERO) THEN + IF (NOUNIT) X(J) = X(J)/AP(KK) + TEMP = X(J) + K = KK - 1 + DO 10 I = J - 1,1,-1 + X(I) = X(I) - TEMP*AP(K) + K = K - 1 + 10 CONTINUE + END IF + KK = KK - J + 20 CONTINUE + ELSE + JX = KX + (N-1)*INCX + DO 40 J = N,1,-1 + IF (X(JX).NE.ZERO) THEN + IF (NOUNIT) X(JX) = X(JX)/AP(KK) + TEMP = X(JX) + IX = JX + DO 30 K = KK - 1,KK - J + 1,-1 + IX = IX - INCX + X(IX) = X(IX) - TEMP*AP(K) + 30 CONTINUE + END IF + JX = JX - INCX + KK = KK - J + 40 CONTINUE + END IF + ELSE + KK = 1 + IF (INCX.EQ.1) THEN + DO 60 J = 1,N + IF (X(J).NE.ZERO) THEN + IF (NOUNIT) X(J) = X(J)/AP(KK) + TEMP = X(J) + K = KK + 1 + DO 50 I = J + 1,N + X(I) = X(I) - TEMP*AP(K) + K = K + 1 + 50 CONTINUE + END IF + KK = KK + (N-J+1) + 60 CONTINUE + ELSE + JX = KX + DO 80 J = 1,N + IF (X(JX).NE.ZERO) THEN + IF (NOUNIT) X(JX) = X(JX)/AP(KK) + TEMP = X(JX) + IX = JX + DO 70 K = KK + 1,KK + N - J + IX = IX + INCX + X(IX) = X(IX) - TEMP*AP(K) + 70 CONTINUE + END IF + JX = JX + INCX + KK = KK + (N-J+1) + 80 CONTINUE + END IF + END IF + ELSE +* +* Form x := inv( A**T )*x or x := inv( A**H )*x. +* + IF (LSAME(UPLO,'U')) THEN + KK = 1 + IF (INCX.EQ.1) THEN + DO 110 J = 1,N + TEMP = X(J) + K = KK + IF (NOCONJ) THEN + DO 90 I = 1,J - 1 + TEMP = TEMP - AP(K)*X(I) + K = K + 1 + 90 CONTINUE + IF (NOUNIT) TEMP = TEMP/AP(KK+J-1) + ELSE + DO 100 I = 1,J - 1 + TEMP = TEMP - CONJG(AP(K))*X(I) + K = K + 1 + 100 CONTINUE + IF (NOUNIT) TEMP = TEMP/CONJG(AP(KK+J-1)) + END IF + X(J) = TEMP + KK = KK + J + 110 CONTINUE + ELSE + JX = KX + DO 140 J = 1,N + TEMP = X(JX) + IX = KX + IF (NOCONJ) THEN + DO 120 K = KK,KK + J - 2 + TEMP = TEMP - AP(K)*X(IX) + IX = IX + INCX + 120 CONTINUE + IF (NOUNIT) TEMP = TEMP/AP(KK+J-1) + ELSE + DO 130 K = KK,KK + J - 2 + TEMP = TEMP - CONJG(AP(K))*X(IX) + IX = IX + INCX + 130 CONTINUE + IF (NOUNIT) TEMP = TEMP/CONJG(AP(KK+J-1)) + END IF + X(JX) = TEMP + JX = JX + INCX + KK = KK + J + 140 CONTINUE + END IF + ELSE + KK = (N* (N+1))/2 + IF (INCX.EQ.1) THEN + DO 170 J = N,1,-1 + TEMP = X(J) + K = KK + IF (NOCONJ) THEN + DO 150 I = N,J + 1,-1 + TEMP = TEMP - AP(K)*X(I) + K = K - 1 + 150 CONTINUE + IF (NOUNIT) TEMP = TEMP/AP(KK-N+J) + ELSE + DO 160 I = N,J + 1,-1 + TEMP = TEMP - CONJG(AP(K))*X(I) + K = K - 1 + 160 CONTINUE + IF (NOUNIT) TEMP = TEMP/CONJG(AP(KK-N+J)) + END IF + X(J) = TEMP + KK = KK - (N-J+1) + 170 CONTINUE + ELSE + KX = KX + (N-1)*INCX + JX = KX + DO 200 J = N,1,-1 + TEMP = X(JX) + IX = KX + IF (NOCONJ) THEN + DO 180 K = KK,KK - (N- (J+1)),-1 + TEMP = TEMP - AP(K)*X(IX) + IX = IX - INCX + 180 CONTINUE + IF (NOUNIT) TEMP = TEMP/AP(KK-N+J) + ELSE + DO 190 K = KK,KK - (N- (J+1)),-1 + TEMP = TEMP - CONJG(AP(K))*X(IX) + IX = IX - INCX + 190 CONTINUE + IF (NOUNIT) TEMP = TEMP/CONJG(AP(KK-N+J)) + END IF + X(JX) = TEMP + JX = JX - INCX + KK = KK - (N-J+1) + 200 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of CTPSV +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/ctrmm.f b/fortran_implementation/external_libraries/BLAS/SRC/ctrmm.f new file mode 100644 index 0000000..c4c3b9a --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/ctrmm.f @@ -0,0 +1,450 @@ +*> \brief \b CTRMM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +* +* .. Scalar Arguments .. +* COMPLEX ALPHA +* INTEGER LDA,LDB,M,N +* CHARACTER DIAG,SIDE,TRANSA,UPLO +* .. +* .. Array Arguments .. +* COMPLEX A(LDA,*),B(LDB,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CTRMM performs one of the matrix-matrix operations +*> +*> B := alpha*op( A )*B, or B := alpha*B*op( A ) +*> +*> where alpha is a scalar, B is an m by n matrix, A is a unit, or +*> non-unit, upper or lower triangular matrix and op( A ) is one of +*> +*> op( A ) = A or op( A ) = A**T or op( A ) = A**H. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> On entry, SIDE specifies whether op( A ) multiplies B from +*> the left or right as follows: +*> +*> SIDE = 'L' or 'l' B := alpha*op( A )*B. +*> +*> SIDE = 'R' or 'r' B := alpha*B*op( A ). +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the matrix A is an upper or +*> lower triangular matrix as follows: +*> +*> UPLO = 'U' or 'u' A is an upper triangular matrix. +*> +*> UPLO = 'L' or 'l' A is a lower triangular matrix. +*> \endverbatim +*> +*> \param[in] TRANSA +*> \verbatim +*> TRANSA is CHARACTER*1 +*> On entry, TRANSA specifies the form of op( A ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSA = 'N' or 'n' op( A ) = A. +*> +*> TRANSA = 'T' or 't' op( A ) = A**T. +*> +*> TRANSA = 'C' or 'c' op( A ) = A**H. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> On entry, DIAG specifies whether or not A is unit triangular +*> as follows: +*> +*> DIAG = 'U' or 'u' A is assumed to be unit triangular. +*> +*> DIAG = 'N' or 'n' A is not assumed to be unit +*> triangular. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of B. M must be at +*> least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of B. N must be +*> at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX +*> On entry, ALPHA specifies the scalar alpha. When alpha is +*> zero then A is not referenced and B need not be set before +*> entry. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX array, dimension ( LDA, k ), where k is m +*> when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. +*> Before entry with UPLO = 'U' or 'u', the leading k by k +*> upper triangular part of the array A must contain the upper +*> triangular matrix and the strictly lower triangular part of +*> A is not referenced. +*> Before entry with UPLO = 'L' or 'l', the leading k by k +*> lower triangular part of the array A must contain the lower +*> triangular matrix and the strictly upper triangular part of +*> A is not referenced. +*> Note that when DIAG = 'U' or 'u', the diagonal elements of +*> A are not referenced either, but are assumed to be unity. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When SIDE = 'L' or 'l' then +*> LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' +*> then LDA must be at least max( 1, n ). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX array, dimension ( LDB, N ). +*> Before entry, the leading m by n part of the array B must +*> contain the matrix B, and on exit is overwritten by the +*> transformed matrix. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. LDB must be at least +*> max( 1, m ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup trmm +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> -- Written on 8-February-1989. +*> Jack Dongarra, Argonne National Laboratory. +*> Iain Duff, AERE Harwell. +*> Jeremy Du Croz, Numerical Algorithms Group Ltd. +*> Sven Hammarling, Numerical Algorithms Group Ltd. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +* +* -- Reference BLAS level3 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX ALPHA + INTEGER LDA,LDB,M,N + CHARACTER DIAG,SIDE,TRANSA,UPLO +* .. +* .. Array Arguments .. + COMPLEX A(LDA,*),B(LDB,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC CONJG,MAX +* .. +* .. Local Scalars .. + COMPLEX TEMP + INTEGER I,INFO,J,K,NROWA + LOGICAL LSIDE,NOCONJ,NOUNIT,UPPER +* .. +* .. Parameters .. + COMPLEX ONE + PARAMETER (ONE= (1.0E+0,0.0E+0)) + COMPLEX ZERO + PARAMETER (ZERO= (0.0E+0,0.0E+0)) +* .. +* +* Test the input parameters. +* + LSIDE = LSAME(SIDE,'L') + IF (LSIDE) THEN + NROWA = M + ELSE + NROWA = N + END IF + NOCONJ = LSAME(TRANSA,'T') + NOUNIT = LSAME(DIAG,'N') + UPPER = LSAME(UPLO,'U') +* + INFO = 0 + IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN + INFO = 1 + ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN + INFO = 2 + ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND. + + (.NOT.LSAME(TRANSA,'T')) .AND. + + (.NOT.LSAME(TRANSA,'C'))) THEN + INFO = 3 + ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. + + (.NOT.LSAME(DIAG,'N'))) THEN + INFO = 4 + ELSE IF (M.LT.0) THEN + INFO = 5 + ELSE IF (N.LT.0) THEN + INFO = 6 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 9 + ELSE IF (LDB.LT.MAX(1,M)) THEN + INFO = 11 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('CTRMM ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (M.EQ.0 .OR. N.EQ.0) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,M + B(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + RETURN + END IF +* +* Start the operations. +* + IF (LSIDE) THEN + IF (LSAME(TRANSA,'N')) THEN +* +* Form B := alpha*A*B. +* + IF (UPPER) THEN + DO 50 J = 1,N + DO 40 K = 1,M + IF (B(K,J).NE.ZERO) THEN + TEMP = ALPHA*B(K,J) + DO 30 I = 1,K - 1 + B(I,J) = B(I,J) + TEMP*A(I,K) + 30 CONTINUE + IF (NOUNIT) TEMP = TEMP*A(K,K) + B(K,J) = TEMP + END IF + 40 CONTINUE + 50 CONTINUE + ELSE + DO 80 J = 1,N + DO 70 K = M,1,-1 + IF (B(K,J).NE.ZERO) THEN + TEMP = ALPHA*B(K,J) + B(K,J) = TEMP + IF (NOUNIT) B(K,J) = B(K,J)*A(K,K) + DO 60 I = K + 1,M + B(I,J) = B(I,J) + TEMP*A(I,K) + 60 CONTINUE + END IF + 70 CONTINUE + 80 CONTINUE + END IF + ELSE +* +* Form B := alpha*A**T*B or B := alpha*A**H*B. +* + IF (UPPER) THEN + DO 120 J = 1,N + DO 110 I = M,1,-1 + TEMP = B(I,J) + IF (NOCONJ) THEN + IF (NOUNIT) TEMP = TEMP*A(I,I) + DO 90 K = 1,I - 1 + TEMP = TEMP + A(K,I)*B(K,J) + 90 CONTINUE + ELSE + IF (NOUNIT) TEMP = TEMP*CONJG(A(I,I)) + DO 100 K = 1,I - 1 + TEMP = TEMP + CONJG(A(K,I))*B(K,J) + 100 CONTINUE + END IF + B(I,J) = ALPHA*TEMP + 110 CONTINUE + 120 CONTINUE + ELSE + DO 160 J = 1,N + DO 150 I = 1,M + TEMP = B(I,J) + IF (NOCONJ) THEN + IF (NOUNIT) TEMP = TEMP*A(I,I) + DO 130 K = I + 1,M + TEMP = TEMP + A(K,I)*B(K,J) + 130 CONTINUE + ELSE + IF (NOUNIT) TEMP = TEMP*CONJG(A(I,I)) + DO 140 K = I + 1,M + TEMP = TEMP + CONJG(A(K,I))*B(K,J) + 140 CONTINUE + END IF + B(I,J) = ALPHA*TEMP + 150 CONTINUE + 160 CONTINUE + END IF + END IF + ELSE + IF (LSAME(TRANSA,'N')) THEN +* +* Form B := alpha*B*A. +* + IF (UPPER) THEN + DO 200 J = N,1,-1 + TEMP = ALPHA + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 170 I = 1,M + B(I,J) = TEMP*B(I,J) + 170 CONTINUE + DO 190 K = 1,J - 1 + IF (A(K,J).NE.ZERO) THEN + TEMP = ALPHA*A(K,J) + DO 180 I = 1,M + B(I,J) = B(I,J) + TEMP*B(I,K) + 180 CONTINUE + END IF + 190 CONTINUE + 200 CONTINUE + ELSE + DO 240 J = 1,N + TEMP = ALPHA + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 210 I = 1,M + B(I,J) = TEMP*B(I,J) + 210 CONTINUE + DO 230 K = J + 1,N + IF (A(K,J).NE.ZERO) THEN + TEMP = ALPHA*A(K,J) + DO 220 I = 1,M + B(I,J) = B(I,J) + TEMP*B(I,K) + 220 CONTINUE + END IF + 230 CONTINUE + 240 CONTINUE + END IF + ELSE +* +* Form B := alpha*B*A**T or B := alpha*B*A**H. +* + IF (UPPER) THEN + DO 280 K = 1,N + DO 260 J = 1,K - 1 + IF (A(J,K).NE.ZERO) THEN + IF (NOCONJ) THEN + TEMP = ALPHA*A(J,K) + ELSE + TEMP = ALPHA*CONJG(A(J,K)) + END IF + DO 250 I = 1,M + B(I,J) = B(I,J) + TEMP*B(I,K) + 250 CONTINUE + END IF + 260 CONTINUE + TEMP = ALPHA + IF (NOUNIT) THEN + IF (NOCONJ) THEN + TEMP = TEMP*A(K,K) + ELSE + TEMP = TEMP*CONJG(A(K,K)) + END IF + END IF + IF (TEMP.NE.ONE) THEN + DO 270 I = 1,M + B(I,K) = TEMP*B(I,K) + 270 CONTINUE + END IF + 280 CONTINUE + ELSE + DO 320 K = N,1,-1 + DO 300 J = K + 1,N + IF (A(J,K).NE.ZERO) THEN + IF (NOCONJ) THEN + TEMP = ALPHA*A(J,K) + ELSE + TEMP = ALPHA*CONJG(A(J,K)) + END IF + DO 290 I = 1,M + B(I,J) = B(I,J) + TEMP*B(I,K) + 290 CONTINUE + END IF + 300 CONTINUE + TEMP = ALPHA + IF (NOUNIT) THEN + IF (NOCONJ) THEN + TEMP = TEMP*A(K,K) + ELSE + TEMP = TEMP*CONJG(A(K,K)) + END IF + END IF + IF (TEMP.NE.ONE) THEN + DO 310 I = 1,M + B(I,K) = TEMP*B(I,K) + 310 CONTINUE + END IF + 320 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of CTRMM +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/ctrmv.f b/fortran_implementation/external_libraries/BLAS/SRC/ctrmv.f new file mode 100644 index 0000000..52ec618 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/ctrmv.f @@ -0,0 +1,372 @@ +*> \brief \b CTRMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,LDA,N +* CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. +* COMPLEX A(LDA,*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CTRMV performs one of the matrix-vector operations +*> +*> x := A*x, or x := A**T*x, or x := A**H*x, +*> +*> where x is an n element vector and A is an n by n unit, or non-unit, +*> upper or lower triangular matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the matrix is an upper or +*> lower triangular matrix as follows: +*> +*> UPLO = 'U' or 'u' A is an upper triangular matrix. +*> +*> UPLO = 'L' or 'l' A is a lower triangular matrix. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the operation to be performed as +*> follows: +*> +*> TRANS = 'N' or 'n' x := A*x. +*> +*> TRANS = 'T' or 't' x := A**T*x. +*> +*> TRANS = 'C' or 'c' x := A**H*x. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> On entry, DIAG specifies whether or not A is unit +*> triangular as follows: +*> +*> DIAG = 'U' or 'u' A is assumed to be unit triangular. +*> +*> DIAG = 'N' or 'n' A is not assumed to be unit +*> triangular. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX array, dimension ( LDA, N ). +*> Before entry with UPLO = 'U' or 'u', the leading n by n +*> upper triangular part of the array A must contain the upper +*> triangular matrix and the strictly lower triangular part of +*> A is not referenced. +*> Before entry with UPLO = 'L' or 'l', the leading n by n +*> lower triangular part of the array A must contain the lower +*> triangular matrix and the strictly upper triangular part of +*> A is not referenced. +*> Note that when DIAG = 'U' or 'u', the diagonal elements of +*> A are not referenced either, but are assumed to be unity. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> max( 1, n ). +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is COMPLEX array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element vector x. On exit, X is overwritten with the +*> transformed vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup trmv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> The vector and matrix arguments are not referenced when N = 0, or M = 0 +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,LDA,N + CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. + COMPLEX A(LDA,*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX ZERO + PARAMETER (ZERO= (0.0E+0,0.0E+0)) +* .. +* .. Local Scalars .. + COMPLEX TEMP + INTEGER I,INFO,IX,J,JX,KX + LOGICAL NOCONJ,NOUNIT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC CONJG,MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (.NOT.LSAME(TRANS,'N') .AND. + + .NOT.LSAME(TRANS,'T') .AND. + + .NOT.LSAME(TRANS,'C')) THEN + INFO = 2 + ELSE IF (.NOT.LSAME(DIAG,'U') .AND. + + .NOT.LSAME(DIAG,'N')) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (LDA.LT.MAX(1,N)) THEN + INFO = 6 + ELSE IF (INCX.EQ.0) THEN + INFO = 8 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('CTRMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (N.EQ.0) RETURN +* + NOCONJ = LSAME(TRANS,'T') + NOUNIT = LSAME(DIAG,'N') +* +* Set up the start point in X if the increment is not unity. This +* will be ( N - 1 )*INCX too small for descending loops. +* + IF (INCX.LE.0) THEN + KX = 1 - (N-1)*INCX + ELSE IF (INCX.NE.1) THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* + IF (LSAME(TRANS,'N')) THEN +* +* Form x := A*x. +* + IF (LSAME(UPLO,'U')) THEN + IF (INCX.EQ.1) THEN + DO 20 J = 1,N + IF (X(J).NE.ZERO) THEN + TEMP = X(J) + DO 10 I = 1,J - 1 + X(I) = X(I) + TEMP*A(I,J) + 10 CONTINUE + IF (NOUNIT) X(J) = X(J)*A(J,J) + END IF + 20 CONTINUE + ELSE + JX = KX + DO 40 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = X(JX) + IX = KX + DO 30 I = 1,J - 1 + X(IX) = X(IX) + TEMP*A(I,J) + IX = IX + INCX + 30 CONTINUE + IF (NOUNIT) X(JX) = X(JX)*A(J,J) + END IF + JX = JX + INCX + 40 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 60 J = N,1,-1 + IF (X(J).NE.ZERO) THEN + TEMP = X(J) + DO 50 I = N,J + 1,-1 + X(I) = X(I) + TEMP*A(I,J) + 50 CONTINUE + IF (NOUNIT) X(J) = X(J)*A(J,J) + END IF + 60 CONTINUE + ELSE + KX = KX + (N-1)*INCX + JX = KX + DO 80 J = N,1,-1 + IF (X(JX).NE.ZERO) THEN + TEMP = X(JX) + IX = KX + DO 70 I = N,J + 1,-1 + X(IX) = X(IX) + TEMP*A(I,J) + IX = IX - INCX + 70 CONTINUE + IF (NOUNIT) X(JX) = X(JX)*A(J,J) + END IF + JX = JX - INCX + 80 CONTINUE + END IF + END IF + ELSE +* +* Form x := A**T*x or x := A**H*x. +* + IF (LSAME(UPLO,'U')) THEN + IF (INCX.EQ.1) THEN + DO 110 J = N,1,-1 + TEMP = X(J) + IF (NOCONJ) THEN + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 90 I = J - 1,1,-1 + TEMP = TEMP + A(I,J)*X(I) + 90 CONTINUE + ELSE + IF (NOUNIT) TEMP = TEMP*CONJG(A(J,J)) + DO 100 I = J - 1,1,-1 + TEMP = TEMP + CONJG(A(I,J))*X(I) + 100 CONTINUE + END IF + X(J) = TEMP + 110 CONTINUE + ELSE + JX = KX + (N-1)*INCX + DO 140 J = N,1,-1 + TEMP = X(JX) + IX = JX + IF (NOCONJ) THEN + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 120 I = J - 1,1,-1 + IX = IX - INCX + TEMP = TEMP + A(I,J)*X(IX) + 120 CONTINUE + ELSE + IF (NOUNIT) TEMP = TEMP*CONJG(A(J,J)) + DO 130 I = J - 1,1,-1 + IX = IX - INCX + TEMP = TEMP + CONJG(A(I,J))*X(IX) + 130 CONTINUE + END IF + X(JX) = TEMP + JX = JX - INCX + 140 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 170 J = 1,N + TEMP = X(J) + IF (NOCONJ) THEN + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 150 I = J + 1,N + TEMP = TEMP + A(I,J)*X(I) + 150 CONTINUE + ELSE + IF (NOUNIT) TEMP = TEMP*CONJG(A(J,J)) + DO 160 I = J + 1,N + TEMP = TEMP + CONJG(A(I,J))*X(I) + 160 CONTINUE + END IF + X(J) = TEMP + 170 CONTINUE + ELSE + JX = KX + DO 200 J = 1,N + TEMP = X(JX) + IX = JX + IF (NOCONJ) THEN + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 180 I = J + 1,N + IX = IX + INCX + TEMP = TEMP + A(I,J)*X(IX) + 180 CONTINUE + ELSE + IF (NOUNIT) TEMP = TEMP*CONJG(A(J,J)) + DO 190 I = J + 1,N + IX = IX + INCX + TEMP = TEMP + CONJG(A(I,J))*X(IX) + 190 CONTINUE + END IF + X(JX) = TEMP + JX = JX + INCX + 200 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of CTRMV +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/ctrsm.f b/fortran_implementation/external_libraries/BLAS/SRC/ctrsm.f new file mode 100644 index 0000000..eff6163 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/ctrsm.f @@ -0,0 +1,475 @@ +*> \brief \b CTRSM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +* +* .. Scalar Arguments .. +* COMPLEX ALPHA +* INTEGER LDA,LDB,M,N +* CHARACTER DIAG,SIDE,TRANSA,UPLO +* .. +* .. Array Arguments .. +* COMPLEX A(LDA,*),B(LDB,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CTRSM solves one of the matrix equations +*> +*> op( A )*X = alpha*B, or X*op( A ) = alpha*B, +*> +*> where alpha is a scalar, X and B are m by n matrices, A is a unit, or +*> non-unit, upper or lower triangular matrix and op( A ) is one of +*> +*> op( A ) = A or op( A ) = A**T or op( A ) = A**H. +*> +*> The matrix X is overwritten on B. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> On entry, SIDE specifies whether op( A ) appears on the left +*> or right of X as follows: +*> +*> SIDE = 'L' or 'l' op( A )*X = alpha*B. +*> +*> SIDE = 'R' or 'r' X*op( A ) = alpha*B. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the matrix A is an upper or +*> lower triangular matrix as follows: +*> +*> UPLO = 'U' or 'u' A is an upper triangular matrix. +*> +*> UPLO = 'L' or 'l' A is a lower triangular matrix. +*> \endverbatim +*> +*> \param[in] TRANSA +*> \verbatim +*> TRANSA is CHARACTER*1 +*> On entry, TRANSA specifies the form of op( A ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSA = 'N' or 'n' op( A ) = A. +*> +*> TRANSA = 'T' or 't' op( A ) = A**T. +*> +*> TRANSA = 'C' or 'c' op( A ) = A**H. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> On entry, DIAG specifies whether or not A is unit triangular +*> as follows: +*> +*> DIAG = 'U' or 'u' A is assumed to be unit triangular. +*> +*> DIAG = 'N' or 'n' A is not assumed to be unit +*> triangular. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of B. M must be at +*> least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of B. N must be +*> at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX +*> On entry, ALPHA specifies the scalar alpha. When alpha is +*> zero then A is not referenced and B need not be set before +*> entry. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX array, dimension ( LDA, k ), +*> where k is m when SIDE = 'L' or 'l' +*> and k is n when SIDE = 'R' or 'r'. +*> Before entry with UPLO = 'U' or 'u', the leading k by k +*> upper triangular part of the array A must contain the upper +*> triangular matrix and the strictly lower triangular part of +*> A is not referenced. +*> Before entry with UPLO = 'L' or 'l', the leading k by k +*> lower triangular part of the array A must contain the lower +*> triangular matrix and the strictly upper triangular part of +*> A is not referenced. +*> Note that when DIAG = 'U' or 'u', the diagonal elements of +*> A are not referenced either, but are assumed to be unity. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When SIDE = 'L' or 'l' then +*> LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' +*> then LDA must be at least max( 1, n ). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX array, dimension ( LDB, N ) +*> Before entry, the leading m by n part of the array B must +*> contain the right-hand side matrix B, and on exit is +*> overwritten by the solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. LDB must be at least +*> max( 1, m ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup trsm +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> -- Written on 8-February-1989. +*> Jack Dongarra, Argonne National Laboratory. +*> Iain Duff, AERE Harwell. +*> Jeremy Du Croz, Numerical Algorithms Group Ltd. +*> Sven Hammarling, Numerical Algorithms Group Ltd. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +* +* -- Reference BLAS level3 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX ALPHA + INTEGER LDA,LDB,M,N + CHARACTER DIAG,SIDE,TRANSA,UPLO +* .. +* .. Array Arguments .. + COMPLEX A(LDA,*),B(LDB,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC CONJG,MAX +* .. +* .. Local Scalars .. + COMPLEX TEMP + INTEGER I,INFO,J,K,NROWA + LOGICAL LSIDE,NOCONJ,NOUNIT,UPPER +* .. +* .. Parameters .. + COMPLEX ONE + PARAMETER (ONE= (1.0E+0,0.0E+0)) + COMPLEX ZERO + PARAMETER (ZERO= (0.0E+0,0.0E+0)) +* .. +* +* Test the input parameters. +* + LSIDE = LSAME(SIDE,'L') + IF (LSIDE) THEN + NROWA = M + ELSE + NROWA = N + END IF + NOCONJ = LSAME(TRANSA,'T') + NOUNIT = LSAME(DIAG,'N') + UPPER = LSAME(UPLO,'U') +* + INFO = 0 + IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN + INFO = 1 + ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN + INFO = 2 + ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND. + + (.NOT.LSAME(TRANSA,'T')) .AND. + + (.NOT.LSAME(TRANSA,'C'))) THEN + INFO = 3 + ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. + + (.NOT.LSAME(DIAG,'N'))) THEN + INFO = 4 + ELSE IF (M.LT.0) THEN + INFO = 5 + ELSE IF (N.LT.0) THEN + INFO = 6 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 9 + ELSE IF (LDB.LT.MAX(1,M)) THEN + INFO = 11 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('CTRSM ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (M.EQ.0 .OR. N.EQ.0) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,M + B(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + RETURN + END IF +* +* Start the operations. +* + IF (LSIDE) THEN + IF (LSAME(TRANSA,'N')) THEN +* +* Form B := alpha*inv( A )*B. +* + IF (UPPER) THEN + DO 60 J = 1,N + IF (ALPHA.NE.ONE) THEN + DO 30 I = 1,M + B(I,J) = ALPHA*B(I,J) + 30 CONTINUE + END IF + DO 50 K = M,1,-1 + IF (B(K,J).NE.ZERO) THEN + IF (NOUNIT) B(K,J) = B(K,J)/A(K,K) + DO 40 I = 1,K - 1 + B(I,J) = B(I,J) - B(K,J)*A(I,K) + 40 CONTINUE + END IF + 50 CONTINUE + 60 CONTINUE + ELSE + DO 100 J = 1,N + IF (ALPHA.NE.ONE) THEN + DO 70 I = 1,M + B(I,J) = ALPHA*B(I,J) + 70 CONTINUE + END IF + DO 90 K = 1,M + IF (B(K,J).NE.ZERO) THEN + IF (NOUNIT) B(K,J) = B(K,J)/A(K,K) + DO 80 I = K + 1,M + B(I,J) = B(I,J) - B(K,J)*A(I,K) + 80 CONTINUE + END IF + 90 CONTINUE + 100 CONTINUE + END IF + ELSE +* +* Form B := alpha*inv( A**T )*B +* or B := alpha*inv( A**H )*B. +* + IF (UPPER) THEN + DO 140 J = 1,N + DO 130 I = 1,M + TEMP = ALPHA*B(I,J) + IF (NOCONJ) THEN + DO 110 K = 1,I - 1 + TEMP = TEMP - A(K,I)*B(K,J) + 110 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(I,I) + ELSE + DO 120 K = 1,I - 1 + TEMP = TEMP - CONJG(A(K,I))*B(K,J) + 120 CONTINUE + IF (NOUNIT) TEMP = TEMP/CONJG(A(I,I)) + END IF + B(I,J) = TEMP + 130 CONTINUE + 140 CONTINUE + ELSE + DO 180 J = 1,N + DO 170 I = M,1,-1 + TEMP = ALPHA*B(I,J) + IF (NOCONJ) THEN + DO 150 K = I + 1,M + TEMP = TEMP - A(K,I)*B(K,J) + 150 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(I,I) + ELSE + DO 160 K = I + 1,M + TEMP = TEMP - CONJG(A(K,I))*B(K,J) + 160 CONTINUE + IF (NOUNIT) TEMP = TEMP/CONJG(A(I,I)) + END IF + B(I,J) = TEMP + 170 CONTINUE + 180 CONTINUE + END IF + END IF + ELSE + IF (LSAME(TRANSA,'N')) THEN +* +* Form B := alpha*B*inv( A ). +* + IF (UPPER) THEN + DO 230 J = 1,N + IF (ALPHA.NE.ONE) THEN + DO 190 I = 1,M + B(I,J) = ALPHA*B(I,J) + 190 CONTINUE + END IF + DO 210 K = 1,J - 1 + IF (A(K,J).NE.ZERO) THEN + DO 200 I = 1,M + B(I,J) = B(I,J) - A(K,J)*B(I,K) + 200 CONTINUE + END IF + 210 CONTINUE + IF (NOUNIT) THEN + TEMP = ONE/A(J,J) + DO 220 I = 1,M + B(I,J) = TEMP*B(I,J) + 220 CONTINUE + END IF + 230 CONTINUE + ELSE + DO 280 J = N,1,-1 + IF (ALPHA.NE.ONE) THEN + DO 240 I = 1,M + B(I,J) = ALPHA*B(I,J) + 240 CONTINUE + END IF + DO 260 K = J + 1,N + IF (A(K,J).NE.ZERO) THEN + DO 250 I = 1,M + B(I,J) = B(I,J) - A(K,J)*B(I,K) + 250 CONTINUE + END IF + 260 CONTINUE + IF (NOUNIT) THEN + TEMP = ONE/A(J,J) + DO 270 I = 1,M + B(I,J) = TEMP*B(I,J) + 270 CONTINUE + END IF + 280 CONTINUE + END IF + ELSE +* +* Form B := alpha*B*inv( A**T ) +* or B := alpha*B*inv( A**H ). +* + IF (UPPER) THEN + DO 330 K = N,1,-1 + IF (NOUNIT) THEN + IF (NOCONJ) THEN + TEMP = ONE/A(K,K) + ELSE + TEMP = ONE/CONJG(A(K,K)) + END IF + DO 290 I = 1,M + B(I,K) = TEMP*B(I,K) + 290 CONTINUE + END IF + DO 310 J = 1,K - 1 + IF (A(J,K).NE.ZERO) THEN + IF (NOCONJ) THEN + TEMP = A(J,K) + ELSE + TEMP = CONJG(A(J,K)) + END IF + DO 300 I = 1,M + B(I,J) = B(I,J) - TEMP*B(I,K) + 300 CONTINUE + END IF + 310 CONTINUE + IF (ALPHA.NE.ONE) THEN + DO 320 I = 1,M + B(I,K) = ALPHA*B(I,K) + 320 CONTINUE + END IF + 330 CONTINUE + ELSE + DO 380 K = 1,N + IF (NOUNIT) THEN + IF (NOCONJ) THEN + TEMP = ONE/A(K,K) + ELSE + TEMP = ONE/CONJG(A(K,K)) + END IF + DO 340 I = 1,M + B(I,K) = TEMP*B(I,K) + 340 CONTINUE + END IF + DO 360 J = K + 1,N + IF (A(J,K).NE.ZERO) THEN + IF (NOCONJ) THEN + TEMP = A(J,K) + ELSE + TEMP = CONJG(A(J,K)) + END IF + DO 350 I = 1,M + B(I,J) = B(I,J) - TEMP*B(I,K) + 350 CONTINUE + END IF + 360 CONTINUE + IF (ALPHA.NE.ONE) THEN + DO 370 I = 1,M + B(I,K) = ALPHA*B(I,K) + 370 CONTINUE + END IF + 380 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of CTRSM +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/ctrsv.f b/fortran_implementation/external_libraries/BLAS/SRC/ctrsv.f new file mode 100644 index 0000000..3e80e44 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/ctrsv.f @@ -0,0 +1,374 @@ +*> \brief \b CTRSV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,LDA,N +* CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. +* COMPLEX A(LDA,*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CTRSV solves one of the systems of equations +*> +*> A*x = b, or A**T*x = b, or A**H*x = b, +*> +*> where b and x are n element vectors and A is an n by n unit, or +*> non-unit, upper or lower triangular matrix. +*> +*> No test for singularity or near-singularity is included in this +*> routine. Such tests must be performed before calling this routine. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the matrix is an upper or +*> lower triangular matrix as follows: +*> +*> UPLO = 'U' or 'u' A is an upper triangular matrix. +*> +*> UPLO = 'L' or 'l' A is a lower triangular matrix. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the equations to be solved as +*> follows: +*> +*> TRANS = 'N' or 'n' A*x = b. +*> +*> TRANS = 'T' or 't' A**T*x = b. +*> +*> TRANS = 'C' or 'c' A**H*x = b. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> On entry, DIAG specifies whether or not A is unit +*> triangular as follows: +*> +*> DIAG = 'U' or 'u' A is assumed to be unit triangular. +*> +*> DIAG = 'N' or 'n' A is not assumed to be unit +*> triangular. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX array, dimension ( LDA, N ) +*> Before entry with UPLO = 'U' or 'u', the leading n by n +*> upper triangular part of the array A must contain the upper +*> triangular matrix and the strictly lower triangular part of +*> A is not referenced. +*> Before entry with UPLO = 'L' or 'l', the leading n by n +*> lower triangular part of the array A must contain the lower +*> triangular matrix and the strictly upper triangular part of +*> A is not referenced. +*> Note that when DIAG = 'U' or 'u', the diagonal elements of +*> A are not referenced either, but are assumed to be unity. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> max( 1, n ). +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is COMPLEX array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element right-hand side vector b. On exit, X is overwritten +*> with the solution vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup trsv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,LDA,N + CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. + COMPLEX A(LDA,*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX ZERO + PARAMETER (ZERO= (0.0E+0,0.0E+0)) +* .. +* .. Local Scalars .. + COMPLEX TEMP + INTEGER I,INFO,IX,J,JX,KX + LOGICAL NOCONJ,NOUNIT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC CONJG,MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (.NOT.LSAME(TRANS,'N') .AND. + + .NOT.LSAME(TRANS,'T') .AND. + + .NOT.LSAME(TRANS,'C')) THEN + INFO = 2 + ELSE IF (.NOT.LSAME(DIAG,'U') .AND. + + .NOT.LSAME(DIAG,'N')) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (LDA.LT.MAX(1,N)) THEN + INFO = 6 + ELSE IF (INCX.EQ.0) THEN + INFO = 8 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('CTRSV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (N.EQ.0) RETURN +* + NOCONJ = LSAME(TRANS,'T') + NOUNIT = LSAME(DIAG,'N') +* +* Set up the start point in X if the increment is not unity. This +* will be ( N - 1 )*INCX too small for descending loops. +* + IF (INCX.LE.0) THEN + KX = 1 - (N-1)*INCX + ELSE IF (INCX.NE.1) THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* + IF (LSAME(TRANS,'N')) THEN +* +* Form x := inv( A )*x. +* + IF (LSAME(UPLO,'U')) THEN + IF (INCX.EQ.1) THEN + DO 20 J = N,1,-1 + IF (X(J).NE.ZERO) THEN + IF (NOUNIT) X(J) = X(J)/A(J,J) + TEMP = X(J) + DO 10 I = J - 1,1,-1 + X(I) = X(I) - TEMP*A(I,J) + 10 CONTINUE + END IF + 20 CONTINUE + ELSE + JX = KX + (N-1)*INCX + DO 40 J = N,1,-1 + IF (X(JX).NE.ZERO) THEN + IF (NOUNIT) X(JX) = X(JX)/A(J,J) + TEMP = X(JX) + IX = JX + DO 30 I = J - 1,1,-1 + IX = IX - INCX + X(IX) = X(IX) - TEMP*A(I,J) + 30 CONTINUE + END IF + JX = JX - INCX + 40 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 60 J = 1,N + IF (X(J).NE.ZERO) THEN + IF (NOUNIT) X(J) = X(J)/A(J,J) + TEMP = X(J) + DO 50 I = J + 1,N + X(I) = X(I) - TEMP*A(I,J) + 50 CONTINUE + END IF + 60 CONTINUE + ELSE + JX = KX + DO 80 J = 1,N + IF (X(JX).NE.ZERO) THEN + IF (NOUNIT) X(JX) = X(JX)/A(J,J) + TEMP = X(JX) + IX = JX + DO 70 I = J + 1,N + IX = IX + INCX + X(IX) = X(IX) - TEMP*A(I,J) + 70 CONTINUE + END IF + JX = JX + INCX + 80 CONTINUE + END IF + END IF + ELSE +* +* Form x := inv( A**T )*x or x := inv( A**H )*x. +* + IF (LSAME(UPLO,'U')) THEN + IF (INCX.EQ.1) THEN + DO 110 J = 1,N + TEMP = X(J) + IF (NOCONJ) THEN + DO 90 I = 1,J - 1 + TEMP = TEMP - A(I,J)*X(I) + 90 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(J,J) + ELSE + DO 100 I = 1,J - 1 + TEMP = TEMP - CONJG(A(I,J))*X(I) + 100 CONTINUE + IF (NOUNIT) TEMP = TEMP/CONJG(A(J,J)) + END IF + X(J) = TEMP + 110 CONTINUE + ELSE + JX = KX + DO 140 J = 1,N + IX = KX + TEMP = X(JX) + IF (NOCONJ) THEN + DO 120 I = 1,J - 1 + TEMP = TEMP - A(I,J)*X(IX) + IX = IX + INCX + 120 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(J,J) + ELSE + DO 130 I = 1,J - 1 + TEMP = TEMP - CONJG(A(I,J))*X(IX) + IX = IX + INCX + 130 CONTINUE + IF (NOUNIT) TEMP = TEMP/CONJG(A(J,J)) + END IF + X(JX) = TEMP + JX = JX + INCX + 140 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 170 J = N,1,-1 + TEMP = X(J) + IF (NOCONJ) THEN + DO 150 I = N,J + 1,-1 + TEMP = TEMP - A(I,J)*X(I) + 150 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(J,J) + ELSE + DO 160 I = N,J + 1,-1 + TEMP = TEMP - CONJG(A(I,J))*X(I) + 160 CONTINUE + IF (NOUNIT) TEMP = TEMP/CONJG(A(J,J)) + END IF + X(J) = TEMP + 170 CONTINUE + ELSE + KX = KX + (N-1)*INCX + JX = KX + DO 200 J = N,1,-1 + IX = KX + TEMP = X(JX) + IF (NOCONJ) THEN + DO 180 I = N,J + 1,-1 + TEMP = TEMP - A(I,J)*X(IX) + IX = IX - INCX + 180 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(J,J) + ELSE + DO 190 I = N,J + 1,-1 + TEMP = TEMP - CONJG(A(I,J))*X(IX) + IX = IX - INCX + 190 CONTINUE + IF (NOUNIT) TEMP = TEMP/CONJG(A(J,J)) + END IF + X(JX) = TEMP + JX = JX - INCX + 200 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of CTRSV +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/dasum.f b/fortran_implementation/external_libraries/BLAS/SRC/dasum.f new file mode 100644 index 0000000..7a1c208 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/dasum.f @@ -0,0 +1,131 @@ +*> \brief \b DASUM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION DX(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DASUM takes the sum of the absolute values. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] DX +*> \verbatim +*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of DX +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup asum +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, linpack, 3/11/78. +*> modified 3/93 to return if incx .le. 0. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DX(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + DOUBLE PRECISION DTEMP + INTEGER I,M,MP1,NINCX +* .. +* .. Intrinsic Functions .. + INTRINSIC DABS,MOD +* .. + DASUM = 0.0d0 + DTEMP = 0.0d0 + IF (N.LE.0 .OR. INCX.LE.0) RETURN + IF (INCX.EQ.1) THEN +* code for increment equal to 1 +* +* +* clean-up loop +* + M = MOD(N,6) + IF (M.NE.0) THEN + DO I = 1,M + DTEMP = DTEMP + DABS(DX(I)) + END DO + IF (N.LT.6) THEN + DASUM = DTEMP + RETURN + END IF + END IF + MP1 = M + 1 + DO I = MP1,N,6 + DTEMP = DTEMP + DABS(DX(I)) + DABS(DX(I+1)) + + $ DABS(DX(I+2)) + DABS(DX(I+3)) + + $ DABS(DX(I+4)) + DABS(DX(I+5)) + END DO + ELSE +* +* code for increment not equal to 1 +* + NINCX = N*INCX + DO I = 1,NINCX,INCX + DTEMP = DTEMP + DABS(DX(I)) + END DO + END IF + DASUM = DTEMP + RETURN +* +* End of DASUM +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/daxpy.f b/fortran_implementation/external_libraries/BLAS/SRC/daxpy.f new file mode 100644 index 0000000..1a6dab4 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/daxpy.f @@ -0,0 +1,152 @@ +*> \brief \b DAXPY +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION DA +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION DX(*),DY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DAXPY constant times a vector plus a vector. +*> uses unrolled loops for increments equal to one. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] DA +*> \verbatim +*> DA is DOUBLE PRECISION +*> On entry, DA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] DX +*> \verbatim +*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of DX +*> \endverbatim +*> +*> \param[in,out] DY +*> \verbatim +*> DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of DY +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup axpy +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, linpack, 3/11/78. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + DOUBLE PRECISION DA + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DX(*),DY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,IX,IY,M,MP1 +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. + IF (N.LE.0) RETURN + IF (DA.EQ.0.0d0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* +* +* clean-up loop +* + M = MOD(N,4) + IF (M.NE.0) THEN + DO I = 1,M + DY(I) = DY(I) + DA*DX(I) + END DO + END IF + IF (N.LT.4) RETURN + MP1 = M + 1 + DO I = MP1,N,4 + DY(I) = DY(I) + DA*DX(I) + DY(I+1) = DY(I+1) + DA*DX(I+1) + DY(I+2) = DY(I+2) + DA*DX(I+2) + DY(I+3) = DY(I+3) + DA*DX(I+3) + END DO + ELSE +* +* code for unequal increments or equal increments +* not equal to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + DY(IY) = DY(IY) + DA*DX(IX) + IX = IX + INCX + IY = IY + INCY + END DO + END IF + RETURN +* +* End of DAXPY +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/dcabs1.f b/fortran_implementation/external_libraries/BLAS/SRC/dcabs1.f new file mode 100644 index 0000000..6505ffc --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/dcabs1.f @@ -0,0 +1,66 @@ +*> \brief \b DCABS1 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DCABS1(Z) +* +* .. Scalar Arguments .. +* COMPLEX*16 Z +* .. +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DCABS1 computes |Re(.)| + |Im(.)| of a double complex number +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] Z +*> \verbatim +*> Z is COMPLEX*16 +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup abs1 +* +* ===================================================================== + DOUBLE PRECISION FUNCTION DCABS1(Z) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX*16 Z +* .. +* .. +* ===================================================================== +* +* .. Intrinsic Functions .. + INTRINSIC ABS,DBLE,DIMAG +* + DCABS1 = ABS(DBLE(Z)) + ABS(DIMAG(Z)) + RETURN +* +* End of DCABS1 +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/dcopy.f b/fortran_implementation/external_libraries/BLAS/SRC/dcopy.f new file mode 100644 index 0000000..1bf4fd2 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/dcopy.f @@ -0,0 +1,146 @@ +*> \brief \b DCOPY +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DCOPY(N,DX,INCX,DY,INCY) +* +* .. Scalar Arguments .. +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION DX(*),DY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DCOPY copies a vector, x, to a vector, y. +*> uses unrolled loops for increments equal to 1. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] DX +*> \verbatim +*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of DX +*> \endverbatim +*> +*> \param[out] DY +*> \verbatim +*> DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of DY +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup copy +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, linpack, 3/11/78. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DCOPY(N,DX,INCX,DY,INCY) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DX(*),DY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,IX,IY,M,MP1 +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* +* +* clean-up loop +* + M = MOD(N,7) + IF (M.NE.0) THEN + DO I = 1,M + DY(I) = DX(I) + END DO + IF (N.LT.7) RETURN + END IF + MP1 = M + 1 + DO I = MP1,N,7 + DY(I) = DX(I) + DY(I+1) = DX(I+1) + DY(I+2) = DX(I+2) + DY(I+3) = DX(I+3) + DY(I+4) = DX(I+4) + DY(I+5) = DX(I+5) + DY(I+6) = DX(I+6) + END DO + ELSE +* +* code for unequal increments or equal increments +* not equal to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + DY(IY) = DX(IX) + IX = IX + INCX + IY = IY + INCY + END DO + END IF + RETURN +* +* End of DCOPY +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/ddot.f b/fortran_implementation/external_libraries/BLAS/SRC/ddot.f new file mode 100644 index 0000000..4f85fcd --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/ddot.f @@ -0,0 +1,148 @@ +*> \brief \b DDOT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY) +* +* .. Scalar Arguments .. +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION DX(*),DY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DDOT forms the dot product of two vectors. +*> uses unrolled loops for increments equal to one. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] DX +*> \verbatim +*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of DX +*> \endverbatim +*> +*> \param[in] DY +*> \verbatim +*> DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of DY +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup dot +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, linpack, 3/11/78. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DX(*),DY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + DOUBLE PRECISION DTEMP + INTEGER I,IX,IY,M,MP1 +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. + DDOT = 0.0d0 + DTEMP = 0.0d0 + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* +* +* clean-up loop +* + M = MOD(N,5) + IF (M.NE.0) THEN + DO I = 1,M + DTEMP = DTEMP + DX(I)*DY(I) + END DO + IF (N.LT.5) THEN + DDOT=DTEMP + RETURN + END IF + END IF + MP1 = M + 1 + DO I = MP1,N,5 + DTEMP = DTEMP + DX(I)*DY(I) + DX(I+1)*DY(I+1) + + $ DX(I+2)*DY(I+2) + DX(I+3)*DY(I+3) + DX(I+4)*DY(I+4) + END DO + ELSE +* +* code for unequal increments or equal increments +* not equal to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + DTEMP = DTEMP + DX(IX)*DY(IY) + IX = IX + INCX + IY = IY + INCY + END DO + END IF + DDOT = DTEMP + RETURN +* +* End of DDOT +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/dgbmv.f b/fortran_implementation/external_libraries/BLAS/SRC/dgbmv.f new file mode 100644 index 0000000..d2353a8 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/dgbmv.f @@ -0,0 +1,370 @@ +*> \brief \b DGBMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION ALPHA,BETA +* INTEGER INCX,INCY,KL,KU,LDA,M,N +* CHARACTER TRANS +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGBMV performs one of the matrix-vector operations +*> +*> y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, +*> +*> where alpha and beta are scalars, x and y are vectors and A is an +*> m by n band matrix, with kl sub-diagonals and ku super-diagonals. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the operation to be performed as +*> follows: +*> +*> TRANS = 'N' or 'n' y := alpha*A*x + beta*y. +*> +*> TRANS = 'T' or 't' y := alpha*A**T*x + beta*y. +*> +*> TRANS = 'C' or 'c' y := alpha*A**T*x + beta*y. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix A. +*> M must be at least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] KL +*> \verbatim +*> KL is INTEGER +*> On entry, KL specifies the number of sub-diagonals of the +*> matrix A. KL must satisfy 0 .le. KL. +*> \endverbatim +*> +*> \param[in] KU +*> \verbatim +*> KU is INTEGER +*> On entry, KU specifies the number of super-diagonals of the +*> matrix A. KU must satisfy 0 .le. KU. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is DOUBLE PRECISION. +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension ( LDA, N ) +*> Before entry, the leading ( kl + ku + 1 ) by n part of the +*> array A must contain the matrix of coefficients, supplied +*> column by column, with the leading diagonal of the matrix in +*> row ( ku + 1 ) of the array, the first super-diagonal +*> starting at position 2 in row ku, the first sub-diagonal +*> starting at position 1 in row ( ku + 2 ), and so on. +*> Elements in the array A that do not correspond to elements +*> in the band matrix (such as the top left ku by ku triangle) +*> are not referenced. +*> The following program segment will transfer a band matrix +*> from conventional full matrix storage to band storage: +*> +*> DO 20, J = 1, N +*> K = KU + 1 - J +*> DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL ) +*> A( K + I, J ) = matrix( I, J ) +*> 10 CONTINUE +*> 20 CONTINUE +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> ( kl + ku + 1 ). +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' +*> and at least +*> ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. +*> Before entry, the incremented array X must contain the +*> vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is DOUBLE PRECISION. +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then Y need not be set on input. +*> \endverbatim +*> +*> \param[in,out] Y +*> \verbatim +*> Y is DOUBLE PRECISION array, dimension at least +*> ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' +*> and at least +*> ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. +*> Before entry, the incremented array Y must contain the +*> vector y. On exit, Y is overwritten by the updated vector y. +*> If either m or n is zero, then Y not referenced and the function +*> performs a quick return. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> Y. INCY must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup gbmv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> The vector and matrix arguments are not referenced when N = 0, or M = 0 +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX, + + BETA,Y,INCY) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA,BETA + INTEGER INCX,INCY,KL,KU,LDA,M,N + CHARACTER TRANS +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,IX,IY,J,JX,JY,K,KUP1,KX,KY,LENX,LENY +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX,MIN +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. + + .NOT.LSAME(TRANS,'C')) THEN + INFO = 1 + ELSE IF (M.LT.0) THEN + INFO = 2 + ELSE IF (N.LT.0) THEN + INFO = 3 + ELSE IF (KL.LT.0) THEN + INFO = 4 + ELSE IF (KU.LT.0) THEN + INFO = 5 + ELSE IF (LDA.LT. (KL+KU+1)) THEN + INFO = 8 + ELSE IF (INCX.EQ.0) THEN + INFO = 10 + ELSE IF (INCY.EQ.0) THEN + INFO = 13 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DGBMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. + + ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN +* +* Set LENX and LENY, the lengths of the vectors x and y, and set +* up the start points in X and Y. +* + IF (LSAME(TRANS,'N')) THEN + LENX = N + LENY = M + ELSE + LENX = M + LENY = N + END IF + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (LENX-1)*INCX + END IF + IF (INCY.GT.0) THEN + KY = 1 + ELSE + KY = 1 - (LENY-1)*INCY + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through the band part of A. +* +* First form y := beta*y. +* + IF (BETA.NE.ONE) THEN + IF (INCY.EQ.1) THEN + IF (BETA.EQ.ZERO) THEN + DO 10 I = 1,LENY + Y(I) = ZERO + 10 CONTINUE + ELSE + DO 20 I = 1,LENY + Y(I) = BETA*Y(I) + 20 CONTINUE + END IF + ELSE + IY = KY + IF (BETA.EQ.ZERO) THEN + DO 30 I = 1,LENY + Y(IY) = ZERO + IY = IY + INCY + 30 CONTINUE + ELSE + DO 40 I = 1,LENY + Y(IY) = BETA*Y(IY) + IY = IY + INCY + 40 CONTINUE + END IF + END IF + END IF + IF (ALPHA.EQ.ZERO) RETURN + KUP1 = KU + 1 + IF (LSAME(TRANS,'N')) THEN +* +* Form y := alpha*A*x + y. +* + JX = KX + IF (INCY.EQ.1) THEN + DO 60 J = 1,N + TEMP = ALPHA*X(JX) + K = KUP1 - J + DO 50 I = MAX(1,J-KU),MIN(M,J+KL) + Y(I) = Y(I) + TEMP*A(K+I,J) + 50 CONTINUE + JX = JX + INCX + 60 CONTINUE + ELSE + DO 80 J = 1,N + TEMP = ALPHA*X(JX) + IY = KY + K = KUP1 - J + DO 70 I = MAX(1,J-KU),MIN(M,J+KL) + Y(IY) = Y(IY) + TEMP*A(K+I,J) + IY = IY + INCY + 70 CONTINUE + JX = JX + INCX + IF (J.GT.KU) KY = KY + INCY + 80 CONTINUE + END IF + ELSE +* +* Form y := alpha*A**T*x + y. +* + JY = KY + IF (INCX.EQ.1) THEN + DO 100 J = 1,N + TEMP = ZERO + K = KUP1 - J + DO 90 I = MAX(1,J-KU),MIN(M,J+KL) + TEMP = TEMP + A(K+I,J)*X(I) + 90 CONTINUE + Y(JY) = Y(JY) + ALPHA*TEMP + JY = JY + INCY + 100 CONTINUE + ELSE + DO 120 J = 1,N + TEMP = ZERO + IX = KX + K = KUP1 - J + DO 110 I = MAX(1,J-KU),MIN(M,J+KL) + TEMP = TEMP + A(K+I,J)*X(IX) + IX = IX + INCX + 110 CONTINUE + Y(JY) = Y(JY) + ALPHA*TEMP + JY = JY + INCY + IF (J.GT.KU) KX = KX + INCX + 120 CONTINUE + END IF + END IF +* + RETURN +* +* End of DGBMV +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/dgemm.f b/fortran_implementation/external_libraries/BLAS/SRC/dgemm.f new file mode 100644 index 0000000..1484b19 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/dgemm.f @@ -0,0 +1,380 @@ +*> \brief \b DGEMM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION ALPHA,BETA +* INTEGER K,LDA,LDB,LDC,M,N +* CHARACTER TRANSA,TRANSB +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGEMM performs one of the matrix-matrix operations +*> +*> C := alpha*op( A )*op( B ) + beta*C, +*> +*> where op( X ) is one of +*> +*> op( X ) = X or op( X ) = X**T, +*> +*> alpha and beta are scalars, and A, B and C are matrices, with op( A ) +*> an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANSA +*> \verbatim +*> TRANSA is CHARACTER*1 +*> On entry, TRANSA specifies the form of op( A ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSA = 'N' or 'n', op( A ) = A. +*> +*> TRANSA = 'T' or 't', op( A ) = A**T. +*> +*> TRANSA = 'C' or 'c', op( A ) = A**T. +*> \endverbatim +*> +*> \param[in] TRANSB +*> \verbatim +*> TRANSB is CHARACTER*1 +*> On entry, TRANSB specifies the form of op( B ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSB = 'N' or 'n', op( B ) = B. +*> +*> TRANSB = 'T' or 't', op( B ) = B**T. +*> +*> TRANSB = 'C' or 'c', op( B ) = B**T. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix +*> op( A ) and of the matrix C. M must be at least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of the matrix +*> op( B ) and the number of columns of the matrix C. N must be +*> at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry, K specifies the number of columns of the matrix +*> op( A ) and the number of rows of the matrix op( B ). K must +*> be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is DOUBLE PRECISION. +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension ( LDA, ka ), where ka is +*> k when TRANSA = 'N' or 'n', and is m otherwise. +*> Before entry with TRANSA = 'N' or 'n', the leading m by k +*> part of the array A must contain the matrix A, otherwise +*> the leading k by m part of the array A must contain the +*> matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When TRANSA = 'N' or 'n' then +*> LDA must be at least max( 1, m ), otherwise LDA must be at +*> least max( 1, k ). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension ( LDB, kb ), where kb is +*> n when TRANSB = 'N' or 'n', and is k otherwise. +*> Before entry with TRANSB = 'N' or 'n', the leading k by n +*> part of the array B must contain the matrix B, otherwise +*> the leading n by k part of the array B must contain the +*> matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. When TRANSB = 'N' or 'n' then +*> LDB must be at least max( 1, k ), otherwise LDB must be at +*> least max( 1, n ). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is DOUBLE PRECISION. +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then C need not be set on input. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension ( LDC, N ) +*> Before entry, the leading m by n part of the array C must +*> contain the matrix C, except when beta is zero, in which +*> case C need not be set on entry. +*> On exit, the array C is overwritten by the m by n matrix +*> ( alpha*op( A )*op( B ) + beta*C ). +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> On entry, LDC specifies the first dimension of C as declared +*> in the calling (sub) program. LDC must be at least +*> max( 1, m ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup gemm +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> -- Written on 8-February-1989. +*> Jack Dongarra, Argonne National Laboratory. +*> Iain Duff, AERE Harwell. +*> Jeremy Du Croz, Numerical Algorithms Group Ltd. +*> Sven Hammarling, Numerical Algorithms Group Ltd. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB, + + BETA,C,LDC) +* +* -- Reference BLAS level3 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA,BETA + INTEGER K,LDA,LDB,LDC,M,N + CHARACTER TRANSA,TRANSB +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,J,L,NROWA,NROWB + LOGICAL NOTA,NOTB +* .. +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) +* .. +* +* Set NOTA and NOTB as true if A and B respectively are not +* transposed and set NROWA and NROWB as the number of rows of A +* and B respectively. +* + NOTA = LSAME(TRANSA,'N') + NOTB = LSAME(TRANSB,'N') + IF (NOTA) THEN + NROWA = M + ELSE + NROWA = K + END IF + IF (NOTB) THEN + NROWB = K + ELSE + NROWB = N + END IF +* +* Test the input parameters. +* + INFO = 0 + IF ((.NOT.NOTA) .AND. (.NOT.LSAME(TRANSA,'C')) .AND. + + (.NOT.LSAME(TRANSA,'T'))) THEN + INFO = 1 + ELSE IF ((.NOT.NOTB) .AND. (.NOT.LSAME(TRANSB,'C')) .AND. + + (.NOT.LSAME(TRANSB,'T'))) THEN + INFO = 2 + ELSE IF (M.LT.0) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (K.LT.0) THEN + INFO = 5 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 8 + ELSE IF (LDB.LT.MAX(1,NROWB)) THEN + INFO = 10 + ELSE IF (LDC.LT.MAX(1,M)) THEN + INFO = 13 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DGEMM ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. + + (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN +* +* And if alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + IF (BETA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,M + C(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1,N + DO 30 I = 1,M + C(I,J) = BETA*C(I,J) + 30 CONTINUE + 40 CONTINUE + END IF + RETURN + END IF +* +* Start the operations. +* + IF (NOTB) THEN + IF (NOTA) THEN +* +* Form C := alpha*A*B + beta*C. +* + DO 90 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 50 I = 1,M + C(I,J) = ZERO + 50 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 60 I = 1,M + C(I,J) = BETA*C(I,J) + 60 CONTINUE + END IF + DO 80 L = 1,K + TEMP = ALPHA*B(L,J) + DO 70 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + ELSE +* +* Form C := alpha*A**T*B + beta*C +* + DO 120 J = 1,N + DO 110 I = 1,M + TEMP = ZERO + DO 100 L = 1,K + TEMP = TEMP + A(L,I)*B(L,J) + 100 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 110 CONTINUE + 120 CONTINUE + END IF + ELSE + IF (NOTA) THEN +* +* Form C := alpha*A*B**T + beta*C +* + DO 170 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 130 I = 1,M + C(I,J) = ZERO + 130 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 140 I = 1,M + C(I,J) = BETA*C(I,J) + 140 CONTINUE + END IF + DO 160 L = 1,K + TEMP = ALPHA*B(J,L) + DO 150 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE + ELSE +* +* Form C := alpha*A**T*B**T + beta*C +* + DO 200 J = 1,N + DO 190 I = 1,M + TEMP = ZERO + DO 180 L = 1,K + TEMP = TEMP + A(L,I)*B(J,L) + 180 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 190 CONTINUE + 200 CONTINUE + END IF + END IF +* + RETURN +* +* End of DGEMM +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/dgemmtr.f b/fortran_implementation/external_libraries/BLAS/SRC/dgemmtr.f new file mode 100644 index 0000000..cab5b71 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/dgemmtr.f @@ -0,0 +1,431 @@ +*> \brief \b DGEMMTR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DGEMMTR(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB,BETA, +* C,LDC) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION ALPHA,BETA +* INTEGER K,LDA,LDB,LDC,N +* CHARACTER TRANSA,TRANSB, UPLO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGEMMTR performs one of the matrix-matrix operations +*> +*> C := alpha*op( A )*op( B ) + beta*C, +*> +*> where op( X ) is one of +*> +*> op( X ) = X or op( X ) = X**T, +*> +*> alpha and beta are scalars, and A, B and C are matrices, with op( A ) +*> an n by k matrix, op( B ) a k by n matrix and C an n by n matrix. +*> Thereby, the routine only accesses and updates the upper or lower +*> triangular part of the result matrix C. This behaviour can be used if +*> the resulting matrix C is known to be symmetric. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the lower or the upper +*> triangular part of C is access and updated. +*> +*> UPLO = 'L' or 'l', the lower triangular part of C is used. +*> +*> UPLO = 'U' or 'u', the upper triangular part of C is used. +*> \endverbatim +* +*> \param[in] TRANSA +*> \verbatim +*> TRANSA is CHARACTER*1 +*> On entry, TRANSA specifies the form of op( A ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSA = 'N' or 'n', op( A ) = A. +*> +*> TRANSA = 'T' or 't', op( A ) = A**T. +*> +*> TRANSA = 'C' or 'c', op( A ) = A**T. +*> \endverbatim +*> +*> \param[in] TRANSB +*> \verbatim +*> TRANSB is CHARACTER*1 +*> On entry, TRANSB specifies the form of op( B ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSB = 'N' or 'n', op( B ) = B. +*> +*> TRANSB = 'T' or 't', op( B ) = B**T. +*> +*> TRANSB = 'C' or 'c', op( B ) = B**T. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of rows and columns of +*> the matrix C, the number of columns of op(B) and the number +*> of rows of op(A). N must be at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry, K specifies the number of columns of the matrix +*> op( A ) and the number of rows of the matrix op( B ). K must +*> be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is DOUBLE PRECISION. +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension ( LDA, ka ), where ka is +*> k when TRANSA = 'N' or 'n', and is n otherwise. +*> Before entry with TRANSA = 'N' or 'n', the leading n by k +*> part of the array A must contain the matrix A, otherwise +*> the leading k by m part of the array A must contain the +*> matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When TRANSA = 'N' or 'n' then +*> LDA must be at least max( 1, n ), otherwise LDA must be at +*> least max( 1, k ). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension ( LDB, kb ), where kb is +*> n when TRANSB = 'N' or 'n', and is k otherwise. +*> Before entry with TRANSB = 'N' or 'n', the leading k by n +*> part of the array B must contain the matrix B, otherwise +*> the leading n by k part of the array B must contain the +*> matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. When TRANSB = 'N' or 'n' then +*> LDB must be at least max( 1, k ), otherwise LDB must be at +*> least max( 1, n ). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is DOUBLE PRECISION. +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then C need not be set on input. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension ( LDC, N ) +*> Before entry, the leading n by n part of the array C must +*> contain the matrix C, except when beta is zero, in which +*> case C need not be set on entry. +*> On exit, the upper or lower triangular part of the matrix +*> C is overwritten by the n by n matrix +*> ( alpha*op( A )*op( B ) + beta*C ). +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> On entry, LDC specifies the first dimension of C as declared +*> in the calling (sub) program. LDC must be at least +*> max( 1, n ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Martin Koehler +* +*> \ingroup gemmtr +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> -- Written on 19-July-2023. +*> Martin Koehler, MPI Magdeburg +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGEMMTR(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB, + + BETA,C,LDC) + IMPLICIT NONE +* +* -- Reference BLAS level3 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA,BETA + INTEGER K,LDA,LDB,LDC,N + CHARACTER TRANSA,TRANSB,UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,J,L,NROWA,NROWB, ISTART, ISTOP + LOGICAL NOTA,NOTB, UPPER +* .. +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) +* .. +* +* Set NOTA and NOTB as true if A and B respectively are not +* transposed and set NROWA and NROWB as the number of rows of A +* and B respectively. +* + NOTA = LSAME(TRANSA,'N') + NOTB = LSAME(TRANSB,'N') + IF (NOTA) THEN + NROWA = N + ELSE + NROWA = K + END IF + IF (NOTB) THEN + NROWB = K + ELSE + NROWB = N + END IF + UPPER = LSAME(UPLO, 'U') +* +* Test the input parameters. +* + INFO = 0 + IF ((.NOT. UPPER) .AND. (.NOT. LSAME(UPLO, 'L'))) THEN + INFO = 1 + ELSE IF ((.NOT.NOTA) .AND. (.NOT.LSAME(TRANSA,'C')) .AND. + + (.NOT.LSAME(TRANSA,'T'))) THEN + INFO = 2 + ELSE IF ((.NOT.NOTB) .AND. (.NOT.LSAME(TRANSB,'C')) .AND. + + (.NOT.LSAME(TRANSB,'T'))) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (K.LT.0) THEN + INFO = 5 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 8 + ELSE IF (LDB.LT.MAX(1,NROWB)) THEN + INFO = 10 + ELSE IF (LDC.LT.MAX(1,N)) THEN + INFO = 13 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DGEMMTR',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (N.EQ.0) RETURN +* +* And if alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + IF (BETA.EQ.ZERO) THEN + DO 20 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + DO 10 I = ISTART, ISTOP + C(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + DO 30 I = ISTART, ISTOP + C(I,J) = BETA*C(I,J) + 30 CONTINUE + 40 CONTINUE + END IF + RETURN + END IF +* +* Start the operations. +* + IF (NOTB) THEN + IF (NOTA) THEN +* +* Form C := alpha*A*B + beta*C. +* + DO 90 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + IF (BETA.EQ.ZERO) THEN + DO 50 I = ISTART, ISTOP + C(I,J) = ZERO + 50 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 60 I = ISTART, ISTOP + C(I,J) = BETA*C(I,J) + 60 CONTINUE + END IF + DO 80 L = 1,K + TEMP = ALPHA*B(L,J) + DO 70 I = ISTART, ISTOP + C(I,J) = C(I,J) + TEMP*A(I,L) + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + ELSE +* +* Form C := alpha*A**T*B + beta*C +* + DO 120 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + DO 110 I = ISTART, ISTOP + TEMP = ZERO + DO 100 L = 1,K + TEMP = TEMP + A(L,I)*B(L,J) + 100 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 110 CONTINUE + 120 CONTINUE + END IF + ELSE + IF (NOTA) THEN +* +* Form C := alpha*A*B**T + beta*C +* + DO 170 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + IF (BETA.EQ.ZERO) THEN + DO 130 I = ISTART,ISTOP + C(I,J) = ZERO + 130 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 140 I = ISTART,ISTOP + C(I,J) = BETA*C(I,J) + 140 CONTINUE + END IF + DO 160 L = 1,K + TEMP = ALPHA*B(J,L) + DO 150 I = ISTART,ISTOP + C(I,J) = C(I,J) + TEMP*A(I,L) + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE + ELSE +* +* Form C := alpha*A**T*B**T + beta*C +* + DO 200 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + DO 190 I = ISTART, ISTOP + TEMP = ZERO + DO 180 L = 1,K + TEMP = TEMP + A(L,I)*B(J,L) + 180 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 190 CONTINUE + 200 CONTINUE + END IF + END IF +* + RETURN +* +* End of SGEMM +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/dgemv.f b/fortran_implementation/external_libraries/BLAS/SRC/dgemv.f new file mode 100644 index 0000000..b2c9cde --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/dgemv.f @@ -0,0 +1,329 @@ +*> \brief \b DGEMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION ALPHA,BETA +* INTEGER INCX,INCY,LDA,M,N +* CHARACTER TRANS +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGEMV performs one of the matrix-vector operations +*> +*> y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, +*> +*> where alpha and beta are scalars, x and y are vectors and A is an +*> m by n matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the operation to be performed as +*> follows: +*> +*> TRANS = 'N' or 'n' y := alpha*A*x + beta*y. +*> +*> TRANS = 'T' or 't' y := alpha*A**T*x + beta*y. +*> +*> TRANS = 'C' or 'c' y := alpha*A**T*x + beta*y. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix A. +*> M must be at least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is DOUBLE PRECISION. +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension ( LDA, N ) +*> Before entry, the leading m by n part of the array A must +*> contain the matrix of coefficients. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> max( 1, m ). +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' +*> and at least +*> ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. +*> Before entry, the incremented array X must contain the +*> vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is DOUBLE PRECISION. +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then Y need not be set on input. +*> \endverbatim +*> +*> \param[in,out] Y +*> \verbatim +*> Y is DOUBLE PRECISION array, dimension at least +*> ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' +*> and at least +*> ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. +*> Before entry with BETA non-zero, the incremented array Y +*> must contain the vector y. On exit, Y is overwritten by the +*> updated vector y. +*> If either m or n is zero, then Y not referenced and the function +*> performs a quick return. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> Y. INCY must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup gemv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> The vector and matrix arguments are not referenced when N = 0, or M = 0 +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA,BETA + INTEGER INCX,INCY,LDA,M,N + CHARACTER TRANS +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY,LENX,LENY +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. + + .NOT.LSAME(TRANS,'C')) THEN + INFO = 1 + ELSE IF (M.LT.0) THEN + INFO = 2 + ELSE IF (N.LT.0) THEN + INFO = 3 + ELSE IF (LDA.LT.MAX(1,M)) THEN + INFO = 6 + ELSE IF (INCX.EQ.0) THEN + INFO = 8 + ELSE IF (INCY.EQ.0) THEN + INFO = 11 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DGEMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. + + ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN +* +* Set LENX and LENY, the lengths of the vectors x and y, and set +* up the start points in X and Y. +* + IF (LSAME(TRANS,'N')) THEN + LENX = N + LENY = M + ELSE + LENX = M + LENY = N + END IF + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (LENX-1)*INCX + END IF + IF (INCY.GT.0) THEN + KY = 1 + ELSE + KY = 1 - (LENY-1)*INCY + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* +* First form y := beta*y. +* + IF (BETA.NE.ONE) THEN + IF (INCY.EQ.1) THEN + IF (BETA.EQ.ZERO) THEN + DO 10 I = 1,LENY + Y(I) = ZERO + 10 CONTINUE + ELSE + DO 20 I = 1,LENY + Y(I) = BETA*Y(I) + 20 CONTINUE + END IF + ELSE + IY = KY + IF (BETA.EQ.ZERO) THEN + DO 30 I = 1,LENY + Y(IY) = ZERO + IY = IY + INCY + 30 CONTINUE + ELSE + DO 40 I = 1,LENY + Y(IY) = BETA*Y(IY) + IY = IY + INCY + 40 CONTINUE + END IF + END IF + END IF + IF (ALPHA.EQ.ZERO) RETURN + IF (LSAME(TRANS,'N')) THEN +* +* Form y := alpha*A*x + y. +* + JX = KX + IF (INCY.EQ.1) THEN + DO 60 J = 1,N + TEMP = ALPHA*X(JX) + DO 50 I = 1,M + Y(I) = Y(I) + TEMP*A(I,J) + 50 CONTINUE + JX = JX + INCX + 60 CONTINUE + ELSE + DO 80 J = 1,N + TEMP = ALPHA*X(JX) + IY = KY + DO 70 I = 1,M + Y(IY) = Y(IY) + TEMP*A(I,J) + IY = IY + INCY + 70 CONTINUE + JX = JX + INCX + 80 CONTINUE + END IF + ELSE +* +* Form y := alpha*A**T*x + y. +* + JY = KY + IF (INCX.EQ.1) THEN + DO 100 J = 1,N + TEMP = ZERO + DO 90 I = 1,M + TEMP = TEMP + A(I,J)*X(I) + 90 CONTINUE + Y(JY) = Y(JY) + ALPHA*TEMP + JY = JY + INCY + 100 CONTINUE + ELSE + DO 120 J = 1,N + TEMP = ZERO + IX = KX + DO 110 I = 1,M + TEMP = TEMP + A(I,J)*X(IX) + IX = IX + INCX + 110 CONTINUE + Y(JY) = Y(JY) + ALPHA*TEMP + JY = JY + INCY + 120 CONTINUE + END IF + END IF +* + RETURN +* +* End of DGEMV +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/dger.f b/fortran_implementation/external_libraries/BLAS/SRC/dger.f new file mode 100644 index 0000000..32bfc0d --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/dger.f @@ -0,0 +1,224 @@ +*> \brief \b DGER +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION ALPHA +* INTEGER INCX,INCY,LDA,M,N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGER performs the rank 1 operation +*> +*> A := alpha*x*y**T + A, +*> +*> where alpha is a scalar, x is an m element vector, y is an n element +*> vector and A is an m by n matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix A. +*> M must be at least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is DOUBLE PRECISION. +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension at least +*> ( 1 + ( m - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the m +*> element vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in] Y +*> \verbatim +*> Y is DOUBLE PRECISION array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCY ) ). +*> Before entry, the incremented array Y must contain the n +*> element vector y. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> Y. INCY must not be zero. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension ( LDA, N ) +*> Before entry, the leading m by n part of the array A must +*> contain the matrix of coefficients. On exit, A is +*> overwritten by the updated matrix. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> max( 1, m ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup ger +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA + INTEGER INCX,INCY,LDA,M,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER (ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,IX,J,JY,KX +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (M.LT.0) THEN + INFO = 1 + ELSE IF (N.LT.0) THEN + INFO = 2 + ELSE IF (INCX.EQ.0) THEN + INFO = 5 + ELSE IF (INCY.EQ.0) THEN + INFO = 7 + ELSE IF (LDA.LT.MAX(1,M)) THEN + INFO = 9 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DGER ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* + IF (INCY.GT.0) THEN + JY = 1 + ELSE + JY = 1 - (N-1)*INCY + END IF + IF (INCX.EQ.1) THEN + DO 20 J = 1,N + IF (Y(JY).NE.ZERO) THEN + TEMP = ALPHA*Y(JY) + DO 10 I = 1,M + A(I,J) = A(I,J) + X(I)*TEMP + 10 CONTINUE + END IF + JY = JY + INCY + 20 CONTINUE + ELSE + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (M-1)*INCX + END IF + DO 40 J = 1,N + IF (Y(JY).NE.ZERO) THEN + TEMP = ALPHA*Y(JY) + IX = KX + DO 30 I = 1,M + A(I,J) = A(I,J) + X(IX)*TEMP + IX = IX + INCX + 30 CONTINUE + END IF + JY = JY + INCY + 40 CONTINUE + END IF +* + RETURN +* +* End of DGER +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/dnrm2.f90 b/fortran_implementation/external_libraries/BLAS/SRC/dnrm2.f90 new file mode 100644 index 0000000..be071ed --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/dnrm2.f90 @@ -0,0 +1,199 @@ +!> \brief \b DNRM2 +! +! =========== DOCUMENTATION =========== +! +! Online html documentation available at +! http://www.netlib.org/lapack/explore-html/ +! +! Definition: +! =========== +! +! DOUBLE PRECISION FUNCTION DNRM2(N,X,INCX) +! +! .. Scalar Arguments .. +! INTEGER INCX,N +! .. +! .. Array Arguments .. +! DOUBLE PRECISION X(*) +! .. +! +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> DNRM2 returns the euclidean norm of a vector via the function +!> name, so that +!> +!> DNRM2 := sqrt( x'*x ) +!> \endverbatim +! +! Arguments: +! ========== +! +!> \param[in] N +!> \verbatim +!> N is INTEGER +!> number of elements in input vector(s) +!> \endverbatim +!> +!> \param[in] X +!> \verbatim +!> X is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +!> \endverbatim +!> +!> \param[in] INCX +!> \verbatim +!> INCX is INTEGER, storage spacing between elements of X +!> If INCX > 0, X(1+(i-1)*INCX) = x(i) for 1 <= i <= n +!> If INCX < 0, X(1-(n-i)*INCX) = x(i) for 1 <= i <= n +!> If INCX = 0, x isn't a vector so there is no need to call +!> this subroutine. If you call it anyway, it will count x(1) +!> in the vector norm N times. +!> \endverbatim +! +! Authors: +! ======== +! +!> \author Edward Anderson, Lockheed Martin +! +!> \date August 2016 +! +!> \ingroup nrm2 +! +!> \par Contributors: +! ================== +!> +!> Weslley Pereira, University of Colorado Denver, USA +! +!> \par Further Details: +! ===================== +!> +!> \verbatim +!> +!> Anderson E. (2017) +!> Algorithm 978: Safe Scaling in the Level 1 BLAS +!> ACM Trans Math Softw 44:1--28 +!> https://doi.org/10.1145/3061665 +!> +!> Blue, James L. (1978) +!> A Portable Fortran Program to Find the Euclidean Norm of a Vector +!> ACM Trans Math Softw 4:15--23 +!> https://doi.org/10.1145/355769.355771 +!> +!> \endverbatim +!> +! ===================================================================== +function DNRM2( n, x, incx ) + integer, parameter :: wp = kind(1.d0) + real(wp) :: DNRM2 +! +! -- Reference BLAS level1 routine (version 3.9.1) -- +! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +! March 2021 +! +! .. Constants .. + real(wp), parameter :: zero = 0.0_wp + real(wp), parameter :: one = 1.0_wp + real(wp), parameter :: maxN = huge(0.0_wp) +! .. +! .. Blue's scaling constants .. + real(wp), parameter :: tsml = real(radix(0._wp), wp)**ceiling( & + (minexponent(0._wp) - 1) * 0.5_wp) + real(wp), parameter :: tbig = real(radix(0._wp), wp)**floor( & + (maxexponent(0._wp) - digits(0._wp) + 1) * 0.5_wp) + real(wp), parameter :: ssml = real(radix(0._wp), wp)**( - floor( & + (minexponent(0._wp) - digits(0._wp)) * 0.5_wp)) + real(wp), parameter :: sbig = real(radix(0._wp), wp)**( - ceiling( & + (maxexponent(0._wp) + digits(0._wp) - 1) * 0.5_wp)) +! .. +! .. Scalar Arguments .. + integer :: incx, n +! .. +! .. Array Arguments .. + real(wp) :: x(*) +! .. +! .. Local Scalars .. + integer :: i, ix + logical :: notbig + real(wp) :: abig, amed, asml, ax, scl, sumsq, ymax, ymin +! +! Quick return if possible +! + DNRM2 = zero + if( n <= 0 ) return +! + scl = one + sumsq = zero +! +! Compute the sum of squares in 3 accumulators: +! abig -- sums of squares scaled down to avoid overflow +! asml -- sums of squares scaled up to avoid underflow +! amed -- sums of squares that do not require scaling +! The thresholds and multipliers are +! tbig -- values bigger than this are scaled down by sbig +! tsml -- values smaller than this are scaled up by ssml +! + notbig = .true. + asml = zero + amed = zero + abig = zero + ix = 1 + if( incx < 0 ) ix = 1 - (n-1)*incx + do i = 1, n + ax = abs(x(ix)) + if (ax > tbig) then + abig = abig + (ax*sbig)**2 + notbig = .false. + else if (ax < tsml) then + if (notbig) asml = asml + (ax*ssml)**2 + else + amed = amed + ax**2 + end if + ix = ix + incx + end do +! +! Combine abig and amed or amed and asml if more than one +! accumulator was used. +! + if (abig > zero) then +! +! Combine abig and amed if abig > 0. +! + if ( (amed > zero) .or. (amed > maxN) .or. (amed /= amed) ) then + abig = abig + (amed*sbig)*sbig + end if + scl = one / sbig + sumsq = abig + else if (asml > zero) then +! +! Combine amed and asml if asml > 0. +! + if ( (amed > zero) .or. (amed > maxN) .or. (amed /= amed) ) then + amed = sqrt(amed) + asml = sqrt(asml) / ssml + if (asml > amed) then + ymin = amed + ymax = asml + else + ymin = asml + ymax = amed + end if + scl = one + sumsq = ymax**2*( one + (ymin/ymax)**2 ) + else + scl = one / ssml + sumsq = asml + end if + else +! +! Otherwise all values are mid-range +! + scl = one + sumsq = amed + end if + DNRM2 = scl*sqrt( sumsq ) + return +end function diff --git a/fortran_implementation/external_libraries/BLAS/SRC/drot.f b/fortran_implementation/external_libraries/BLAS/SRC/drot.f new file mode 100644 index 0000000..e50e151 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/drot.f @@ -0,0 +1,142 @@ +*> \brief \b DROT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DROT(N,DX,INCX,DY,INCY,C,S) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION C,S +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION DX(*),DY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DROT applies a plane rotation. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in,out] DX +*> \verbatim +*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of DX +*> \endverbatim +*> +*> \param[in,out] DY +*> \verbatim +*> DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of DY +*> \endverbatim +*> +*> \param[in] C +*> \verbatim +*> C is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] S +*> \verbatim +*> S is DOUBLE PRECISION +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup rot +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, linpack, 3/11/78. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DROT(N,DX,INCX,DY,INCY,C,S) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + DOUBLE PRECISION C,S + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DX(*),DY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + DOUBLE PRECISION DTEMP + INTEGER I,IX,IY +* .. + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* + DO I = 1,N + DTEMP = C*DX(I) + S*DY(I) + DY(I) = C*DY(I) - S*DX(I) + DX(I) = DTEMP + END DO + ELSE +* +* code for unequal increments or equal increments not equal +* to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + DTEMP = C*DX(IX) + S*DY(IY) + DY(IY) = C*DY(IY) - S*DX(IX) + DX(IX) = DTEMP + IX = IX + INCX + IY = IY + INCY + END DO + END IF + RETURN +* +* End of DROT +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/drotg.f90 b/fortran_implementation/external_libraries/BLAS/SRC/drotg.f90 new file mode 100644 index 0000000..fa1f7c0 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/drotg.f90 @@ -0,0 +1,150 @@ +!> \brief \b DROTG +! +! =========== DOCUMENTATION =========== +! +! Online html documentation available at +! http://www.netlib.org/lapack/explore-html/ +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> DROTG constructs a plane rotation +!> [ c s ] [ a ] = [ r ] +!> [ -s c ] [ b ] [ 0 ] +!> satisfying c**2 + s**2 = 1. +!> +!> The computation uses the formulas +!> sigma = sgn(a) if |a| > |b| +!> = sgn(b) if |b| >= |a| +!> r = sigma*sqrt( a**2 + b**2 ) +!> c = 1; s = 0 if r = 0 +!> c = a/r; s = b/r if r != 0 +!> The subroutine also computes +!> z = s if |a| > |b|, +!> = 1/c if |b| >= |a| and c != 0 +!> = 1 if c = 0 +!> This allows c and s to be reconstructed from z as follows: +!> If z = 1, set c = 0, s = 1. +!> If |z| < 1, set c = sqrt(1 - z**2) and s = z. +!> If |z| > 1, set c = 1/z and s = sqrt( 1 - c**2). +!> +!> \endverbatim +!> +!> @see lartg, @see lartgp +! +! Arguments: +! ========== +! +!> \param[in,out] A +!> \verbatim +!> A is DOUBLE PRECISION +!> On entry, the scalar a. +!> On exit, the scalar r. +!> \endverbatim +!> +!> \param[in,out] B +!> \verbatim +!> B is DOUBLE PRECISION +!> On entry, the scalar b. +!> On exit, the scalar z. +!> \endverbatim +!> +!> \param[out] C +!> \verbatim +!> C is DOUBLE PRECISION +!> The scalar c. +!> \endverbatim +!> +!> \param[out] S +!> \verbatim +!> S is DOUBLE PRECISION +!> The scalar s. +!> \endverbatim +! +! Authors: +! ======== +! +!> \author Edward Anderson, Lockheed Martin +! +!> \par Contributors: +! ================== +!> +!> Weslley Pereira, University of Colorado Denver, USA +! +!> \ingroup rotg +! +!> \par Further Details: +! ===================== +!> +!> \verbatim +!> +!> Anderson E. (2017) +!> Algorithm 978: Safe Scaling in the Level 1 BLAS +!> ACM Trans Math Softw 44:1--28 +!> https://doi.org/10.1145/3061665 +!> +!> \endverbatim +! +! ===================================================================== +subroutine DROTG( a, b, c, s ) + integer, parameter :: wp = kind(1.d0) +! +! -- Reference BLAS level1 routine -- +! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +! +! .. Constants .. + real(wp), parameter :: zero = 0.0_wp + real(wp), parameter :: one = 1.0_wp +! .. +! .. Scaling constants .. + real(wp), parameter :: safmin = real(radix(0._wp),wp)**max( & + minexponent(0._wp)-1, & + 1-maxexponent(0._wp) & + ) + real(wp), parameter :: safmax = real(radix(0._wp),wp)**max( & + 1-minexponent(0._wp), & + maxexponent(0._wp)-1 & + ) +! .. +! .. Scalar Arguments .. + real(wp) :: a, b, c, s +! .. +! .. Local Scalars .. + real(wp) :: anorm, bnorm, scl, sigma, r, z +! .. + anorm = abs(a) + bnorm = abs(b) + if( bnorm == zero ) then + c = one + s = zero + b = zero + else if( anorm == zero ) then + c = zero + s = one + a = b + b = one + else + scl = min( safmax, max( safmin, anorm, bnorm ) ) + if( anorm > bnorm ) then + sigma = sign(one,a) + else + sigma = sign(one,b) + end if + r = sigma*( scl*sqrt((a/scl)**2 + (b/scl)**2) ) + c = a/r + s = b/r + if( anorm > bnorm ) then + z = s + else if( c /= zero ) then + z = one/c + else + z = one + end if + a = r + b = z + end if + return +end subroutine diff --git a/fortran_implementation/external_libraries/BLAS/SRC/drotm.f b/fortran_implementation/external_libraries/BLAS/SRC/drotm.f new file mode 100644 index 0000000..450510d --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/drotm.f @@ -0,0 +1,200 @@ +*> \brief \b DROTM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DROTM(N,DX,INCX,DY,INCY,DPARAM) +* +* .. Scalar Arguments .. +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION DPARAM(5),DX(*),DY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX +*> +*> (DX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF DX ARE IN +*> (DY**T) +*> +*> DX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE +*> LX = (-INCX)*N, AND SIMILARLY FOR SY USING LY AND INCY. +*> WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS.. +*> +*> DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 +*> +*> (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) +*> H=( ) ( ) ( ) ( ) +*> (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). +*> SEE DROTMG FOR A DESCRIPTION OF DATA STORAGE IN DPARAM. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in,out] DX +*> \verbatim +*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of DX +*> \endverbatim +*> +*> \param[in,out] DY +*> \verbatim +*> DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of DY +*> \endverbatim +*> +*> \param[in] DPARAM +*> \verbatim +*> DPARAM is DOUBLE PRECISION array, dimension (5) +*> DPARAM(1)=DFLAG +*> DPARAM(2)=DH11 +*> DPARAM(3)=DH21 +*> DPARAM(4)=DH12 +*> DPARAM(5)=DH22 +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup rotm +* +* ===================================================================== + SUBROUTINE DROTM(N,DX,INCX,DY,INCY,DPARAM) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DPARAM(5),DX(*),DY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + DOUBLE PRECISION DFLAG,DH11,DH12,DH21,DH22,TWO,W,Z,ZERO + INTEGER I,KX,KY,NSTEPS +* .. +* .. Data statements .. + DATA ZERO,TWO/0.D0,2.D0/ +* .. +* + DFLAG = DPARAM(1) + IF (N.LE.0 .OR. (DFLAG+TWO.EQ.ZERO)) RETURN + IF (INCX.EQ.INCY.AND.INCX.GT.0) THEN +* + NSTEPS = N*INCX + IF (DFLAG.LT.ZERO) THEN + DH11 = DPARAM(2) + DH12 = DPARAM(4) + DH21 = DPARAM(3) + DH22 = DPARAM(5) + DO I = 1,NSTEPS,INCX + W = DX(I) + Z = DY(I) + DX(I) = W*DH11 + Z*DH12 + DY(I) = W*DH21 + Z*DH22 + END DO + ELSE IF (DFLAG.EQ.ZERO) THEN + DH12 = DPARAM(4) + DH21 = DPARAM(3) + DO I = 1,NSTEPS,INCX + W = DX(I) + Z = DY(I) + DX(I) = W + Z*DH12 + DY(I) = W*DH21 + Z + END DO + ELSE + DH11 = DPARAM(2) + DH22 = DPARAM(5) + DO I = 1,NSTEPS,INCX + W = DX(I) + Z = DY(I) + DX(I) = W*DH11 + Z + DY(I) = -W + DH22*Z + END DO + END IF + ELSE + KX = 1 + KY = 1 + IF (INCX.LT.0) KX = 1 + (1-N)*INCX + IF (INCY.LT.0) KY = 1 + (1-N)*INCY +* + IF (DFLAG.LT.ZERO) THEN + DH11 = DPARAM(2) + DH12 = DPARAM(4) + DH21 = DPARAM(3) + DH22 = DPARAM(5) + DO I = 1,N + W = DX(KX) + Z = DY(KY) + DX(KX) = W*DH11 + Z*DH12 + DY(KY) = W*DH21 + Z*DH22 + KX = KX + INCX + KY = KY + INCY + END DO + ELSE IF (DFLAG.EQ.ZERO) THEN + DH12 = DPARAM(4) + DH21 = DPARAM(3) + DO I = 1,N + W = DX(KX) + Z = DY(KY) + DX(KX) = W + Z*DH12 + DY(KY) = W*DH21 + Z + KX = KX + INCX + KY = KY + INCY + END DO + ELSE + DH11 = DPARAM(2) + DH22 = DPARAM(5) + DO I = 1,N + W = DX(KX) + Z = DY(KY) + DX(KX) = W*DH11 + Z + DY(KY) = -W + DH22*Z + KX = KX + INCX + KY = KY + INCY + END DO + END IF + END IF + RETURN +* +* End of DROTM +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/drotmg.f b/fortran_implementation/external_libraries/BLAS/SRC/drotmg.f new file mode 100644 index 0000000..920734a --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/drotmg.f @@ -0,0 +1,260 @@ +*> \brief \b DROTMG +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DROTMG(DD1,DD2,DX1,DY1,DPARAM) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION DD1,DD2,DX1,DY1 +* .. +* .. Array Arguments .. +* DOUBLE PRECISION DPARAM(5) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS +*> THE SECOND COMPONENT OF THE 2-VECTOR (DSQRT(DD1)*DX1,DSQRT(DD2)*> DY2)**T. +*> WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS.. +*> +*> DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 +*> +*> (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) +*> H=( ) ( ) ( ) ( ) +*> (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). +*> LOCATIONS 2-4 OF DPARAM CONTAIN DH11, DH21, DH12, AND DH22 +*> RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE +*> VALUE OF DPARAM(1) ARE NOT STORED IN DPARAM.) +*> +*> THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE +*> INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE +*> OF DD1 AND DD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in,out] DD1 +*> \verbatim +*> DD1 is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in,out] DD2 +*> \verbatim +*> DD2 is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in,out] DX1 +*> \verbatim +*> DX1 is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] DY1 +*> \verbatim +*> DY1 is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[out] DPARAM +*> \verbatim +*> DPARAM is DOUBLE PRECISION array, dimension (5) +*> DPARAM(1)=DFLAG +*> DPARAM(2)=DH11 +*> DPARAM(3)=DH21 +*> DPARAM(4)=DH12 +*> DPARAM(5)=DH22 +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup rotmg +* +* ===================================================================== + SUBROUTINE DROTMG(DD1,DD2,DX1,DY1,DPARAM) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + DOUBLE PRECISION DD1,DD2,DX1,DY1 +* .. +* .. Array Arguments .. + DOUBLE PRECISION DPARAM(5) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + DOUBLE PRECISION DFLAG,DH11,DH12,DH21,DH22,DP1,DP2,DQ1,DQ2,DTEMP, + $ DU,GAM,GAMSQ,ONE,RGAMSQ,TWO,ZERO +* .. +* .. Intrinsic Functions .. + INTRINSIC DABS +* .. +* .. Data statements .. +* + DATA ZERO,ONE,TWO/0.D0,1.D0,2.D0/ + DATA GAM,GAMSQ,RGAMSQ/4096.D0,16777216.D0,5.9604645D-8/ +* .. + + IF (DD1.LT.ZERO) THEN +* GO ZERO-H-D-AND-DX1.. + DFLAG = -ONE + DH11 = ZERO + DH12 = ZERO + DH21 = ZERO + DH22 = ZERO +* + DD1 = ZERO + DD2 = ZERO + DX1 = ZERO + ELSE +* CASE-DD1-NONNEGATIVE + DP2 = DD2*DY1 + IF (DP2.EQ.ZERO) THEN + DFLAG = -TWO + DPARAM(1) = DFLAG + RETURN + END IF +* REGULAR-CASE.. + DP1 = DD1*DX1 + DQ2 = DP2*DY1 + DQ1 = DP1*DX1 +* + IF (DABS(DQ1).GT.DABS(DQ2)) THEN + DH21 = -DY1/DX1 + DH12 = DP2/DP1 +* + DU = ONE - DH12*DH21 +* + IF (DU.GT.ZERO) THEN + DFLAG = ZERO + DD1 = DD1/DU + DD2 = DD2/DU + DX1 = DX1*DU + ELSE +* This code path if here for safety. We do not expect this +* condition to ever hold except in edge cases with rounding +* errors. See DOI: 10.1145/355841.355847 + DFLAG = -ONE + DH11 = ZERO + DH12 = ZERO + DH21 = ZERO + DH22 = ZERO +* + DD1 = ZERO + DD2 = ZERO + DX1 = ZERO + END IF + ELSE + + IF (DQ2.LT.ZERO) THEN +* GO ZERO-H-D-AND-DX1.. + DFLAG = -ONE + DH11 = ZERO + DH12 = ZERO + DH21 = ZERO + DH22 = ZERO +* + DD1 = ZERO + DD2 = ZERO + DX1 = ZERO + ELSE + DFLAG = ONE + DH11 = DP1/DP2 + DH22 = DX1/DY1 + DU = ONE + DH11*DH22 + DTEMP = DD2/DU + DD2 = DD1/DU + DD1 = DTEMP + DX1 = DY1*DU + END IF + END IF + +* PROCEDURE..SCALE-CHECK + IF (DD1.NE.ZERO) THEN + DO WHILE ((DD1.LE.RGAMSQ) .OR. (DD1.GE.GAMSQ)) + IF (DFLAG.EQ.ZERO) THEN + DH11 = ONE + DH22 = ONE + DFLAG = -ONE + ELSE + DH21 = -ONE + DH12 = ONE + DFLAG = -ONE + END IF + IF (DD1.LE.RGAMSQ) THEN + DD1 = DD1*GAM**2 + DX1 = DX1/GAM + DH11 = DH11/GAM + DH12 = DH12/GAM + ELSE + DD1 = DD1/GAM**2 + DX1 = DX1*GAM + DH11 = DH11*GAM + DH12 = DH12*GAM + END IF + ENDDO + END IF + + IF (DD2.NE.ZERO) THEN + DO WHILE ( (DABS(DD2).LE.RGAMSQ) .OR. (DABS(DD2).GE.GAMSQ) ) + IF (DFLAG.EQ.ZERO) THEN + DH11 = ONE + DH22 = ONE + DFLAG = -ONE + ELSE + DH21 = -ONE + DH12 = ONE + DFLAG = -ONE + END IF + IF (DABS(DD2).LE.RGAMSQ) THEN + DD2 = DD2*GAM**2 + DH21 = DH21/GAM + DH22 = DH22/GAM + ELSE + DD2 = DD2/GAM**2 + DH21 = DH21*GAM + DH22 = DH22*GAM + END IF + END DO + END IF + + END IF + + IF (DFLAG.LT.ZERO) THEN + DPARAM(2) = DH11 + DPARAM(3) = DH21 + DPARAM(4) = DH12 + DPARAM(5) = DH22 + ELSE IF (DFLAG.EQ.ZERO) THEN + DPARAM(3) = DH21 + DPARAM(4) = DH12 + ELSE + DPARAM(2) = DH11 + DPARAM(5) = DH22 + END IF + + DPARAM(1) = DFLAG + RETURN +* +* End of DROTMG +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/dsbmv.f b/fortran_implementation/external_libraries/BLAS/SRC/dsbmv.f new file mode 100644 index 0000000..fdf2062 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/dsbmv.f @@ -0,0 +1,372 @@ +*> \brief \b DSBMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DSBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION ALPHA,BETA +* INTEGER INCX,INCY,K,LDA,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSBMV performs the matrix-vector operation +*> +*> y := alpha*A*x + beta*y, +*> +*> where alpha and beta are scalars, x and y are n element vectors and +*> A is an n by n symmetric band matrix, with k super-diagonals. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the band matrix A is being supplied as +*> follows: +*> +*> UPLO = 'U' or 'u' The upper triangular part of A is +*> being supplied. +*> +*> UPLO = 'L' or 'l' The lower triangular part of A is +*> being supplied. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry, K specifies the number of super-diagonals of the +*> matrix A. K must satisfy 0 .le. K. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is DOUBLE PRECISION. +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension ( LDA, N ) +*> Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) +*> by n part of the array A must contain the upper triangular +*> band part of the symmetric matrix, supplied column by +*> column, with the leading diagonal of the matrix in row +*> ( k + 1 ) of the array, the first super-diagonal starting at +*> position 2 in row k, and so on. The top left k by k triangle +*> of the array A is not referenced. +*> The following program segment will transfer the upper +*> triangular part of a symmetric band matrix from conventional +*> full matrix storage to band storage: +*> +*> DO 20, J = 1, N +*> M = K + 1 - J +*> DO 10, I = MAX( 1, J - K ), J +*> A( M + I, J ) = matrix( I, J ) +*> 10 CONTINUE +*> 20 CONTINUE +*> +*> Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) +*> by n part of the array A must contain the lower triangular +*> band part of the symmetric matrix, supplied column by +*> column, with the leading diagonal of the matrix in row 1 of +*> the array, the first sub-diagonal starting at position 1 in +*> row 2, and so on. The bottom right k by k triangle of the +*> array A is not referenced. +*> The following program segment will transfer the lower +*> triangular part of a symmetric band matrix from conventional +*> full matrix storage to band storage: +*> +*> DO 20, J = 1, N +*> M = 1 - J +*> DO 10, I = J, MIN( N, J + K ) +*> A( M + I, J ) = matrix( I, J ) +*> 10 CONTINUE +*> 20 CONTINUE +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> ( k + 1 ). +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the +*> vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is DOUBLE PRECISION. +*> On entry, BETA specifies the scalar beta. +*> \endverbatim +*> +*> \param[in,out] Y +*> \verbatim +*> Y is DOUBLE PRECISION array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCY ) ). +*> Before entry, the incremented array Y must contain the +*> vector y. On exit, Y is overwritten by the updated vector y. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> Y. INCY must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup hbmv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> The vector and matrix arguments are not referenced when N = 0, or M = 0 +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DSBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA,BETA + INTEGER INCX,INCY,K,LDA,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP1,TEMP2 + INTEGER I,INFO,IX,IY,J,JX,JY,KPLUS1,KX,KY,L +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX,MIN +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (N.LT.0) THEN + INFO = 2 + ELSE IF (K.LT.0) THEN + INFO = 3 + ELSE IF (LDA.LT. (K+1)) THEN + INFO = 6 + ELSE IF (INCX.EQ.0) THEN + INFO = 8 + ELSE IF (INCY.EQ.0) THEN + INFO = 11 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DSBMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN +* +* Set up the start points in X and Y. +* + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (N-1)*INCX + END IF + IF (INCY.GT.0) THEN + KY = 1 + ELSE + KY = 1 - (N-1)*INCY + END IF +* +* Start the operations. In this version the elements of the array A +* are accessed sequentially with one pass through A. +* +* First form y := beta*y. +* + IF (BETA.NE.ONE) THEN + IF (INCY.EQ.1) THEN + IF (BETA.EQ.ZERO) THEN + DO 10 I = 1,N + Y(I) = ZERO + 10 CONTINUE + ELSE + DO 20 I = 1,N + Y(I) = BETA*Y(I) + 20 CONTINUE + END IF + ELSE + IY = KY + IF (BETA.EQ.ZERO) THEN + DO 30 I = 1,N + Y(IY) = ZERO + IY = IY + INCY + 30 CONTINUE + ELSE + DO 40 I = 1,N + Y(IY) = BETA*Y(IY) + IY = IY + INCY + 40 CONTINUE + END IF + END IF + END IF + IF (ALPHA.EQ.ZERO) RETURN + IF (LSAME(UPLO,'U')) THEN +* +* Form y when upper triangle of A is stored. +* + KPLUS1 = K + 1 + IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN + DO 60 J = 1,N + TEMP1 = ALPHA*X(J) + TEMP2 = ZERO + L = KPLUS1 - J + DO 50 I = MAX(1,J-K),J - 1 + Y(I) = Y(I) + TEMP1*A(L+I,J) + TEMP2 = TEMP2 + A(L+I,J)*X(I) + 50 CONTINUE + Y(J) = Y(J) + TEMP1*A(KPLUS1,J) + ALPHA*TEMP2 + 60 CONTINUE + ELSE + JX = KX + JY = KY + DO 80 J = 1,N + TEMP1 = ALPHA*X(JX) + TEMP2 = ZERO + IX = KX + IY = KY + L = KPLUS1 - J + DO 70 I = MAX(1,J-K),J - 1 + Y(IY) = Y(IY) + TEMP1*A(L+I,J) + TEMP2 = TEMP2 + A(L+I,J)*X(IX) + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + Y(JY) = Y(JY) + TEMP1*A(KPLUS1,J) + ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + IF (J.GT.K) THEN + KX = KX + INCX + KY = KY + INCY + END IF + 80 CONTINUE + END IF + ELSE +* +* Form y when lower triangle of A is stored. +* + IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN + DO 100 J = 1,N + TEMP1 = ALPHA*X(J) + TEMP2 = ZERO + Y(J) = Y(J) + TEMP1*A(1,J) + L = 1 - J + DO 90 I = J + 1,MIN(N,J+K) + Y(I) = Y(I) + TEMP1*A(L+I,J) + TEMP2 = TEMP2 + A(L+I,J)*X(I) + 90 CONTINUE + Y(J) = Y(J) + ALPHA*TEMP2 + 100 CONTINUE + ELSE + JX = KX + JY = KY + DO 120 J = 1,N + TEMP1 = ALPHA*X(JX) + TEMP2 = ZERO + Y(JY) = Y(JY) + TEMP1*A(1,J) + L = 1 - J + IX = JX + IY = JY + DO 110 I = J + 1,MIN(N,J+K) + IX = IX + INCX + IY = IY + INCY + Y(IY) = Y(IY) + TEMP1*A(L+I,J) + TEMP2 = TEMP2 + A(L+I,J)*X(IX) + 110 CONTINUE + Y(JY) = Y(JY) + ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + 120 CONTINUE + END IF + END IF +* + RETURN +* +* End of DSBMV +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/dscal.f b/fortran_implementation/external_libraries/BLAS/SRC/dscal.f new file mode 100644 index 0000000..625afba --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/dscal.f @@ -0,0 +1,139 @@ +*> \brief \b DSCAL +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DSCAL(N,DA,DX,INCX) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION DA +* INTEGER INCX,N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION DX(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSCAL scales a vector by a constant. +*> uses unrolled loops for increment equal to 1. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] DA +*> \verbatim +*> DA is DOUBLE PRECISION +*> On entry, DA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in,out] DX +*> \verbatim +*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of DX +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup scal +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, linpack, 3/11/78. +*> modified 3/93 to return if incx .le. 0. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DSCAL(N,DA,DX,INCX) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + DOUBLE PRECISION DA + INTEGER INCX,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DX(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,M,MP1,NINCX +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER (ONE=1.0D+0) +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. + IF (N.LE.0 .OR. INCX.LE.0 .OR. DA.EQ.ONE) RETURN + IF (INCX.EQ.1) THEN +* +* code for increment equal to 1 +* +* +* clean-up loop +* + M = MOD(N,5) + IF (M.NE.0) THEN + DO I = 1,M + DX(I) = DA*DX(I) + END DO + IF (N.LT.5) RETURN + END IF + MP1 = M + 1 + DO I = MP1,N,5 + DX(I) = DA*DX(I) + DX(I+1) = DA*DX(I+1) + DX(I+2) = DA*DX(I+2) + DX(I+3) = DA*DX(I+3) + DX(I+4) = DA*DX(I+4) + END DO + ELSE +* +* code for increment not equal to 1 +* + NINCX = N*INCX + DO I = 1,NINCX,INCX + DX(I) = DA*DX(I) + END DO + END IF + RETURN +* +* End of DSCAL +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/dsdot.f b/fortran_implementation/external_libraries/BLAS/SRC/dsdot.f new file mode 100644 index 0000000..fcfa1aa --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/dsdot.f @@ -0,0 +1,172 @@ +*> \brief \b DSDOT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DSDOT(N,SX,INCX,SY,INCY) +* +* .. Scalar Arguments .. +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* REAL SX(*),SY(*) +* .. +* +* AUTHORS +* ======= +* Lawson, C. L., (JPL), Hanson, R. J., (SNLA), +* Kincaid, D. R., (U. of Texas), Krogh, F. T., (JPL) +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> Compute the inner product of two vectors with extended +*> precision accumulation and result. +*> +*> Returns D.P. dot product accumulated in D.P., for S.P. SX and SY +*> DSDOT = sum for I = 0 to N-1 of SX(LX+I*INCX) * SY(LY+I*INCY), +*> where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is +*> defined in a similar way using INCY. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] SX +*> \verbatim +*> SX is REAL array, dimension(N) +*> single precision vector with N elements +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of SX +*> \endverbatim +*> +*> \param[in] SY +*> \verbatim +*> SY is REAL array, dimension(N) +*> single precision vector with N elements +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of SY +*> \endverbatim +*> +*> \result DSDOT +*> \verbatim +*> DSDOT is DOUBLE PRECISION +*> DSDOT double precision dot product (zero if N.LE.0) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup dot +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> \endverbatim +* +*> \par References: +* ================ +*> +*> \verbatim +*> +*> +*> C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. +*> Krogh, Basic linear algebra subprograms for Fortran +*> usage, Algorithm No. 539, Transactions on Mathematical +*> Software 5, 3 (September 1979), pp. 308-323. +*> +*> REVISION HISTORY (YYMMDD) +*> +*> 791001 DATE WRITTEN +*> 890831 Modified array declarations. (WRB) +*> 890831 REVISION DATE from Version 3.2 +*> 891214 Prologue converted to Version 4.0 format. (BAB) +*> 920310 Corrected definition of LX in DESCRIPTION. (WRB) +*> 920501 Reformatted the REFERENCES section. (WRB) +*> 070118 Reformat to LAPACK style (JL) +*> \endverbatim +*> +* ===================================================================== + DOUBLE PRECISION FUNCTION DSDOT(N,SX,INCX,SY,INCY) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + REAL SX(*),SY(*) +* .. +* +* Authors: +* ======== +* Lawson, C. L., (JPL), Hanson, R. J., (SNLA), +* Kincaid, D. R., (U. of Texas), Krogh, F. T., (JPL) +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,KX,KY,NS +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE +* .. + DSDOT = 0.0D0 + IF (N.LE.0) RETURN + IF (INCX.EQ.INCY .AND. INCX.GT.0) THEN +* +* Code for equal, positive, non-unit increments. +* + NS = N*INCX + DO I = 1,NS,INCX + DSDOT = DSDOT + DBLE(SX(I))*DBLE(SY(I)) + END DO + ELSE +* +* Code for unequal or nonpositive increments. +* + KX = 1 + KY = 1 + IF (INCX.LT.0) KX = 1 + (1-N)*INCX + IF (INCY.LT.0) KY = 1 + (1-N)*INCY + DO I = 1,N + DSDOT = DSDOT + DBLE(SX(KX))*DBLE(SY(KY)) + KX = KX + INCX + KY = KY + INCY + END DO + END IF + RETURN +* +* End of DSDOT +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/dspmv.f b/fortran_implementation/external_libraries/BLAS/SRC/dspmv.f new file mode 100644 index 0000000..518ab77 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/dspmv.f @@ -0,0 +1,328 @@ +*> \brief \b DSPMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DSPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION ALPHA,BETA +* INTEGER INCX,INCY,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AP(*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSPMV performs the matrix-vector operation +*> +*> y := alpha*A*x + beta*y, +*> +*> where alpha and beta are scalars, x and y are n element vectors and +*> A is an n by n symmetric matrix, supplied in packed form. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the matrix A is supplied in the packed +*> array AP as follows: +*> +*> UPLO = 'U' or 'u' The upper triangular part of A is +*> supplied in AP. +*> +*> UPLO = 'L' or 'l' The lower triangular part of A is +*> supplied in AP. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is DOUBLE PRECISION. +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] AP +*> \verbatim +*> AP is DOUBLE PRECISION array, dimension at least +*> ( ( n*( n + 1 ) )/2 ). +*> Before entry with UPLO = 'U' or 'u', the array AP must +*> contain the upper triangular part of the symmetric matrix +*> packed sequentially, column by column, so that AP( 1 ) +*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) +*> and a( 2, 2 ) respectively, and so on. +*> Before entry with UPLO = 'L' or 'l', the array AP must +*> contain the lower triangular part of the symmetric matrix +*> packed sequentially, column by column, so that AP( 1 ) +*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) +*> and a( 3, 1 ) respectively, and so on. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is DOUBLE PRECISION. +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then Y need not be set on input. +*> \endverbatim +*> +*> \param[in,out] Y +*> \verbatim +*> Y is DOUBLE PRECISION array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCY ) ). +*> Before entry, the incremented array Y must contain the n +*> element vector y. On exit, Y is overwritten by the updated +*> vector y. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> Y. INCY must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup hpmv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> The vector and matrix arguments are not referenced when N = 0, or M = 0 +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DSPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA,BETA + INTEGER INCX,INCY,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION AP(*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP1,TEMP2 + INTEGER I,INFO,IX,IY,J,JX,JY,K,KK,KX,KY +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (N.LT.0) THEN + INFO = 2 + ELSE IF (INCX.EQ.0) THEN + INFO = 6 + ELSE IF (INCY.EQ.0) THEN + INFO = 9 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DSPMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN +* +* Set up the start points in X and Y. +* + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (N-1)*INCX + END IF + IF (INCY.GT.0) THEN + KY = 1 + ELSE + KY = 1 - (N-1)*INCY + END IF +* +* Start the operations. In this version the elements of the array AP +* are accessed sequentially with one pass through AP. +* +* First form y := beta*y. +* + IF (BETA.NE.ONE) THEN + IF (INCY.EQ.1) THEN + IF (BETA.EQ.ZERO) THEN + DO 10 I = 1,N + Y(I) = ZERO + 10 CONTINUE + ELSE + DO 20 I = 1,N + Y(I) = BETA*Y(I) + 20 CONTINUE + END IF + ELSE + IY = KY + IF (BETA.EQ.ZERO) THEN + DO 30 I = 1,N + Y(IY) = ZERO + IY = IY + INCY + 30 CONTINUE + ELSE + DO 40 I = 1,N + Y(IY) = BETA*Y(IY) + IY = IY + INCY + 40 CONTINUE + END IF + END IF + END IF + IF (ALPHA.EQ.ZERO) RETURN + KK = 1 + IF (LSAME(UPLO,'U')) THEN +* +* Form y when AP contains the upper triangle. +* + IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN + DO 60 J = 1,N + TEMP1 = ALPHA*X(J) + TEMP2 = ZERO + K = KK + DO 50 I = 1,J - 1 + Y(I) = Y(I) + TEMP1*AP(K) + TEMP2 = TEMP2 + AP(K)*X(I) + K = K + 1 + 50 CONTINUE + Y(J) = Y(J) + TEMP1*AP(KK+J-1) + ALPHA*TEMP2 + KK = KK + J + 60 CONTINUE + ELSE + JX = KX + JY = KY + DO 80 J = 1,N + TEMP1 = ALPHA*X(JX) + TEMP2 = ZERO + IX = KX + IY = KY + DO 70 K = KK,KK + J - 2 + Y(IY) = Y(IY) + TEMP1*AP(K) + TEMP2 = TEMP2 + AP(K)*X(IX) + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + Y(JY) = Y(JY) + TEMP1*AP(KK+J-1) + ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + KK = KK + J + 80 CONTINUE + END IF + ELSE +* +* Form y when AP contains the lower triangle. +* + IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN + DO 100 J = 1,N + TEMP1 = ALPHA*X(J) + TEMP2 = ZERO + Y(J) = Y(J) + TEMP1*AP(KK) + K = KK + 1 + DO 90 I = J + 1,N + Y(I) = Y(I) + TEMP1*AP(K) + TEMP2 = TEMP2 + AP(K)*X(I) + K = K + 1 + 90 CONTINUE + Y(J) = Y(J) + ALPHA*TEMP2 + KK = KK + (N-J+1) + 100 CONTINUE + ELSE + JX = KX + JY = KY + DO 120 J = 1,N + TEMP1 = ALPHA*X(JX) + TEMP2 = ZERO + Y(JY) = Y(JY) + TEMP1*AP(KK) + IX = JX + IY = JY + DO 110 K = KK + 1,KK + N - J + IX = IX + INCX + IY = IY + INCY + Y(IY) = Y(IY) + TEMP1*AP(K) + TEMP2 = TEMP2 + AP(K)*X(IX) + 110 CONTINUE + Y(JY) = Y(JY) + ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + KK = KK + (N-J+1) + 120 CONTINUE + END IF + END IF +* + RETURN +* +* End of DSPMV +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/dspr.f b/fortran_implementation/external_libraries/BLAS/SRC/dspr.f new file mode 100644 index 0000000..2bc025e --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/dspr.f @@ -0,0 +1,258 @@ +*> \brief \b DSPR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DSPR(UPLO,N,ALPHA,X,INCX,AP) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION ALPHA +* INTEGER INCX,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AP(*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSPR performs the symmetric rank 1 operation +*> +*> A := alpha*x*x**T + A, +*> +*> where alpha is a real scalar, x is an n element vector and A is an +*> n by n symmetric matrix, supplied in packed form. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the matrix A is supplied in the packed +*> array AP as follows: +*> +*> UPLO = 'U' or 'u' The upper triangular part of A is +*> supplied in AP. +*> +*> UPLO = 'L' or 'l' The lower triangular part of A is +*> supplied in AP. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is DOUBLE PRECISION. +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in,out] AP +*> \verbatim +*> AP is DOUBLE PRECISION array, dimension at least +*> ( ( n*( n + 1 ) )/2 ). +*> Before entry with UPLO = 'U' or 'u', the array AP must +*> contain the upper triangular part of the symmetric matrix +*> packed sequentially, column by column, so that AP( 1 ) +*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) +*> and a( 2, 2 ) respectively, and so on. On exit, the array +*> AP is overwritten by the upper triangular part of the +*> updated matrix. +*> Before entry with UPLO = 'L' or 'l', the array AP must +*> contain the lower triangular part of the symmetric matrix +*> packed sequentially, column by column, so that AP( 1 ) +*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) +*> and a( 3, 1 ) respectively, and so on. On exit, the array +*> AP is overwritten by the lower triangular part of the +*> updated matrix. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup hpr +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DSPR(UPLO,N,ALPHA,X,INCX,AP) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA + INTEGER INCX,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION AP(*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER (ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,IX,J,JX,K,KK,KX +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (N.LT.0) THEN + INFO = 2 + ELSE IF (INCX.EQ.0) THEN + INFO = 5 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DSPR ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN +* +* Set the start point in X if the increment is not unity. +* + IF (INCX.LE.0) THEN + KX = 1 - (N-1)*INCX + ELSE IF (INCX.NE.1) THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of the array AP +* are accessed sequentially with one pass through AP. +* + KK = 1 + IF (LSAME(UPLO,'U')) THEN +* +* Form A when upper triangle is stored in AP. +* + IF (INCX.EQ.1) THEN + DO 20 J = 1,N + IF (X(J).NE.ZERO) THEN + TEMP = ALPHA*X(J) + K = KK + DO 10 I = 1,J + AP(K) = AP(K) + X(I)*TEMP + K = K + 1 + 10 CONTINUE + END IF + KK = KK + J + 20 CONTINUE + ELSE + JX = KX + DO 40 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = ALPHA*X(JX) + IX = KX + DO 30 K = KK,KK + J - 1 + AP(K) = AP(K) + X(IX)*TEMP + IX = IX + INCX + 30 CONTINUE + END IF + JX = JX + INCX + KK = KK + J + 40 CONTINUE + END IF + ELSE +* +* Form A when lower triangle is stored in AP. +* + IF (INCX.EQ.1) THEN + DO 60 J = 1,N + IF (X(J).NE.ZERO) THEN + TEMP = ALPHA*X(J) + K = KK + DO 50 I = J,N + AP(K) = AP(K) + X(I)*TEMP + K = K + 1 + 50 CONTINUE + END IF + KK = KK + N - J + 1 + 60 CONTINUE + ELSE + JX = KX + DO 80 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = ALPHA*X(JX) + IX = JX + DO 70 K = KK,KK + N - J + AP(K) = AP(K) + X(IX)*TEMP + IX = IX + INCX + 70 CONTINUE + END IF + JX = JX + INCX + KK = KK + N - J + 1 + 80 CONTINUE + END IF + END IF +* + RETURN +* +* End of DSPR +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/dspr2.f b/fortran_implementation/external_libraries/BLAS/SRC/dspr2.f new file mode 100644 index 0000000..32c9cd5 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/dspr2.f @@ -0,0 +1,293 @@ +*> \brief \b DSPR2 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DSPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION ALPHA +* INTEGER INCX,INCY,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AP(*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSPR2 performs the symmetric rank 2 operation +*> +*> A := alpha*x*y**T + alpha*y*x**T + A, +*> +*> where alpha is a scalar, x and y are n element vectors and A is an +*> n by n symmetric matrix, supplied in packed form. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the matrix A is supplied in the packed +*> array AP as follows: +*> +*> UPLO = 'U' or 'u' The upper triangular part of A is +*> supplied in AP. +*> +*> UPLO = 'L' or 'l' The lower triangular part of A is +*> supplied in AP. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is DOUBLE PRECISION. +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in] Y +*> \verbatim +*> Y is DOUBLE PRECISION array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCY ) ). +*> Before entry, the incremented array Y must contain the n +*> element vector y. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> Y. INCY must not be zero. +*> \endverbatim +*> +*> \param[in,out] AP +*> \verbatim +*> AP is DOUBLE PRECISION array, dimension at least +*> ( ( n*( n + 1 ) )/2 ). +*> Before entry with UPLO = 'U' or 'u', the array AP must +*> contain the upper triangular part of the symmetric matrix +*> packed sequentially, column by column, so that AP( 1 ) +*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) +*> and a( 2, 2 ) respectively, and so on. On exit, the array +*> AP is overwritten by the upper triangular part of the +*> updated matrix. +*> Before entry with UPLO = 'L' or 'l', the array AP must +*> contain the lower triangular part of the symmetric matrix +*> packed sequentially, column by column, so that AP( 1 ) +*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) +*> and a( 3, 1 ) respectively, and so on. On exit, the array +*> AP is overwritten by the lower triangular part of the +*> updated matrix. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup hpr2 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DSPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA + INTEGER INCX,INCY,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION AP(*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER (ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP1,TEMP2 + INTEGER I,INFO,IX,IY,J,JX,JY,K,KK,KX,KY +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (N.LT.0) THEN + INFO = 2 + ELSE IF (INCX.EQ.0) THEN + INFO = 5 + ELSE IF (INCY.EQ.0) THEN + INFO = 7 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DSPR2 ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN +* +* Set up the start points in X and Y if the increments are not both +* unity. +* + IF ((INCX.NE.1) .OR. (INCY.NE.1)) THEN + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (N-1)*INCX + END IF + IF (INCY.GT.0) THEN + KY = 1 + ELSE + KY = 1 - (N-1)*INCY + END IF + JX = KX + JY = KY + END IF +* +* Start the operations. In this version the elements of the array AP +* are accessed sequentially with one pass through AP. +* + KK = 1 + IF (LSAME(UPLO,'U')) THEN +* +* Form A when upper triangle is stored in AP. +* + IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN + DO 20 J = 1,N + IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN + TEMP1 = ALPHA*Y(J) + TEMP2 = ALPHA*X(J) + K = KK + DO 10 I = 1,J + AP(K) = AP(K) + X(I)*TEMP1 + Y(I)*TEMP2 + K = K + 1 + 10 CONTINUE + END IF + KK = KK + J + 20 CONTINUE + ELSE + DO 40 J = 1,N + IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN + TEMP1 = ALPHA*Y(JY) + TEMP2 = ALPHA*X(JX) + IX = KX + IY = KY + DO 30 K = KK,KK + J - 1 + AP(K) = AP(K) + X(IX)*TEMP1 + Y(IY)*TEMP2 + IX = IX + INCX + IY = IY + INCY + 30 CONTINUE + END IF + JX = JX + INCX + JY = JY + INCY + KK = KK + J + 40 CONTINUE + END IF + ELSE +* +* Form A when lower triangle is stored in AP. +* + IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN + DO 60 J = 1,N + IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN + TEMP1 = ALPHA*Y(J) + TEMP2 = ALPHA*X(J) + K = KK + DO 50 I = J,N + AP(K) = AP(K) + X(I)*TEMP1 + Y(I)*TEMP2 + K = K + 1 + 50 CONTINUE + END IF + KK = KK + N - J + 1 + 60 CONTINUE + ELSE + DO 80 J = 1,N + IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN + TEMP1 = ALPHA*Y(JY) + TEMP2 = ALPHA*X(JX) + IX = JX + IY = JY + DO 70 K = KK,KK + N - J + AP(K) = AP(K) + X(IX)*TEMP1 + Y(IY)*TEMP2 + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + END IF + JX = JX + INCX + JY = JY + INCY + KK = KK + N - J + 1 + 80 CONTINUE + END IF + END IF +* + RETURN +* +* End of DSPR2 +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/dswap.f b/fortran_implementation/external_libraries/BLAS/SRC/dswap.f new file mode 100644 index 0000000..ae85389 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/dswap.f @@ -0,0 +1,153 @@ +*> \brief \b DSWAP +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DSWAP(N,DX,INCX,DY,INCY) +* +* .. Scalar Arguments .. +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION DX(*),DY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSWAP interchanges two vectors. +*> uses unrolled loops for increments equal to 1. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in,out] DX +*> \verbatim +*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of DX +*> \endverbatim +*> +*> \param[in,out] DY +*> \verbatim +*> DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of DY +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup swap +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, linpack, 3/11/78. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DSWAP(N,DX,INCX,DY,INCY) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DX(*),DY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + DOUBLE PRECISION DTEMP + INTEGER I,IX,IY,M,MP1 +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* +* +* clean-up loop +* + M = MOD(N,3) + IF (M.NE.0) THEN + DO I = 1,M + DTEMP = DX(I) + DX(I) = DY(I) + DY(I) = DTEMP + END DO + IF (N.LT.3) RETURN + END IF + MP1 = M + 1 + DO I = MP1,N,3 + DTEMP = DX(I) + DX(I) = DY(I) + DY(I) = DTEMP + DTEMP = DX(I+1) + DX(I+1) = DY(I+1) + DY(I+1) = DTEMP + DTEMP = DX(I+2) + DX(I+2) = DY(I+2) + DY(I+2) = DTEMP + END DO + ELSE +* +* code for unequal increments or equal increments not equal +* to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + DTEMP = DX(IX) + DX(IX) = DY(IY) + DY(IY) = DTEMP + IX = IX + INCX + IY = IY + INCY + END DO + END IF + RETURN +* +* End of DSWAP +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/dsymm.f b/fortran_implementation/external_libraries/BLAS/SRC/dsymm.f new file mode 100644 index 0000000..8027389 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/dsymm.f @@ -0,0 +1,365 @@ +*> \brief \b DSYMM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION ALPHA,BETA +* INTEGER LDA,LDB,LDC,M,N +* CHARACTER SIDE,UPLO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYMM performs one of the matrix-matrix operations +*> +*> C := alpha*A*B + beta*C, +*> +*> or +*> +*> C := alpha*B*A + beta*C, +*> +*> where alpha and beta are scalars, A is a symmetric matrix and B and +*> C are m by n matrices. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> On entry, SIDE specifies whether the symmetric matrix A +*> appears on the left or right in the operation as follows: +*> +*> SIDE = 'L' or 'l' C := alpha*A*B + beta*C, +*> +*> SIDE = 'R' or 'r' C := alpha*B*A + beta*C, +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the symmetric matrix A is to be +*> referenced as follows: +*> +*> UPLO = 'U' or 'u' Only the upper triangular part of the +*> symmetric matrix is to be referenced. +*> +*> UPLO = 'L' or 'l' Only the lower triangular part of the +*> symmetric matrix is to be referenced. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix C. +*> M must be at least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of the matrix C. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is DOUBLE PRECISION. +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension ( LDA, ka ), where ka is +*> m when SIDE = 'L' or 'l' and is n otherwise. +*> Before entry with SIDE = 'L' or 'l', the m by m part of +*> the array A must contain the symmetric matrix, such that +*> when UPLO = 'U' or 'u', the leading m by m upper triangular +*> part of the array A must contain the upper triangular part +*> of the symmetric matrix and the strictly lower triangular +*> part of A is not referenced, and when UPLO = 'L' or 'l', +*> the leading m by m lower triangular part of the array A +*> must contain the lower triangular part of the symmetric +*> matrix and the strictly upper triangular part of A is not +*> referenced. +*> Before entry with SIDE = 'R' or 'r', the n by n part of +*> the array A must contain the symmetric matrix, such that +*> when UPLO = 'U' or 'u', the leading n by n upper triangular +*> part of the array A must contain the upper triangular part +*> of the symmetric matrix and the strictly lower triangular +*> part of A is not referenced, and when UPLO = 'L' or 'l', +*> the leading n by n lower triangular part of the array A +*> must contain the lower triangular part of the symmetric +*> matrix and the strictly upper triangular part of A is not +*> referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When SIDE = 'L' or 'l' then +*> LDA must be at least max( 1, m ), otherwise LDA must be at +*> least max( 1, n ). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension ( LDB, N ) +*> Before entry, the leading m by n part of the array B must +*> contain the matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. LDB must be at least +*> max( 1, m ). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is DOUBLE PRECISION. +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then C need not be set on input. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension ( LDC, N ) +*> Before entry, the leading m by n part of the array C must +*> contain the matrix C, except when beta is zero, in which +*> case C need not be set on entry. +*> On exit, the array C is overwritten by the m by n updated +*> matrix. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> On entry, LDC specifies the first dimension of C as declared +*> in the calling (sub) program. LDC must be at least +*> max( 1, m ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup hemm +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> -- Written on 8-February-1989. +*> Jack Dongarra, Argonne National Laboratory. +*> Iain Duff, AERE Harwell. +*> Jeremy Du Croz, Numerical Algorithms Group Ltd. +*> Sven Hammarling, Numerical Algorithms Group Ltd. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* -- Reference BLAS level3 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA,BETA + INTEGER LDA,LDB,LDC,M,N + CHARACTER SIDE,UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP1,TEMP2 + INTEGER I,INFO,J,K,NROWA + LOGICAL UPPER +* .. +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) +* .. +* +* Set NROWA as the number of rows of A. +* + IF (LSAME(SIDE,'L')) THEN + NROWA = M + ELSE + NROWA = N + END IF + UPPER = LSAME(UPLO,'U') +* +* Test the input parameters. +* + INFO = 0 + IF ((.NOT.LSAME(SIDE,'L')) .AND. + + (.NOT.LSAME(SIDE,'R'))) THEN + INFO = 1 + ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN + INFO = 2 + ELSE IF (M.LT.0) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 7 + ELSE IF (LDB.LT.MAX(1,M)) THEN + INFO = 9 + ELSE IF (LDC.LT.MAX(1,M)) THEN + INFO = 12 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DSYMM ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. + + ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + IF (BETA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,M + C(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1,N + DO 30 I = 1,M + C(I,J) = BETA*C(I,J) + 30 CONTINUE + 40 CONTINUE + END IF + RETURN + END IF +* +* Start the operations. +* + IF (LSAME(SIDE,'L')) THEN +* +* Form C := alpha*A*B + beta*C. +* + IF (UPPER) THEN + DO 70 J = 1,N + DO 60 I = 1,M + TEMP1 = ALPHA*B(I,J) + TEMP2 = ZERO + DO 50 K = 1,I - 1 + C(K,J) = C(K,J) + TEMP1*A(K,I) + TEMP2 = TEMP2 + B(K,J)*A(K,I) + 50 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = TEMP1*A(I,I) + ALPHA*TEMP2 + ELSE + C(I,J) = BETA*C(I,J) + TEMP1*A(I,I) + + + ALPHA*TEMP2 + END IF + 60 CONTINUE + 70 CONTINUE + ELSE + DO 100 J = 1,N + DO 90 I = M,1,-1 + TEMP1 = ALPHA*B(I,J) + TEMP2 = ZERO + DO 80 K = I + 1,M + C(K,J) = C(K,J) + TEMP1*A(K,I) + TEMP2 = TEMP2 + B(K,J)*A(K,I) + 80 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = TEMP1*A(I,I) + ALPHA*TEMP2 + ELSE + C(I,J) = BETA*C(I,J) + TEMP1*A(I,I) + + + ALPHA*TEMP2 + END IF + 90 CONTINUE + 100 CONTINUE + END IF + ELSE +* +* Form C := alpha*B*A + beta*C. +* + DO 170 J = 1,N + TEMP1 = ALPHA*A(J,J) + IF (BETA.EQ.ZERO) THEN + DO 110 I = 1,M + C(I,J) = TEMP1*B(I,J) + 110 CONTINUE + ELSE + DO 120 I = 1,M + C(I,J) = BETA*C(I,J) + TEMP1*B(I,J) + 120 CONTINUE + END IF + DO 140 K = 1,J - 1 + IF (UPPER) THEN + TEMP1 = ALPHA*A(K,J) + ELSE + TEMP1 = ALPHA*A(J,K) + END IF + DO 130 I = 1,M + C(I,J) = C(I,J) + TEMP1*B(I,K) + 130 CONTINUE + 140 CONTINUE + DO 160 K = J + 1,N + IF (UPPER) THEN + TEMP1 = ALPHA*A(J,K) + ELSE + TEMP1 = ALPHA*A(K,J) + END IF + DO 150 I = 1,M + C(I,J) = C(I,J) + TEMP1*B(I,K) + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE + END IF +* + RETURN +* +* End of DSYMM +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/dsymv.f b/fortran_implementation/external_libraries/BLAS/SRC/dsymv.f new file mode 100644 index 0000000..ebd6e9e --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/dsymv.f @@ -0,0 +1,330 @@ +*> \brief \b DSYMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DSYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION ALPHA,BETA +* INTEGER INCX,INCY,LDA,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYMV performs the matrix-vector operation +*> +*> y := alpha*A*x + beta*y, +*> +*> where alpha and beta are scalars, x and y are n element vectors and +*> A is an n by n symmetric matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the array A is to be referenced as +*> follows: +*> +*> UPLO = 'U' or 'u' Only the upper triangular part of A +*> is to be referenced. +*> +*> UPLO = 'L' or 'l' Only the lower triangular part of A +*> is to be referenced. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is DOUBLE PRECISION. +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension ( LDA, N ) +*> Before entry with UPLO = 'U' or 'u', the leading n by n +*> upper triangular part of the array A must contain the upper +*> triangular part of the symmetric matrix and the strictly +*> lower triangular part of A is not referenced. +*> Before entry with UPLO = 'L' or 'l', the leading n by n +*> lower triangular part of the array A must contain the lower +*> triangular part of the symmetric matrix and the strictly +*> upper triangular part of A is not referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> max( 1, n ). +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is DOUBLE PRECISION. +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then Y need not be set on input. +*> \endverbatim +*> +*> \param[in,out] Y +*> \verbatim +*> Y is DOUBLE PRECISION array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCY ) ). +*> Before entry, the incremented array Y must contain the n +*> element vector y. On exit, Y is overwritten by the updated +*> vector y. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> Y. INCY must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup hemv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> The vector and matrix arguments are not referenced when N = 0, or M = 0 +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DSYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA,BETA + INTEGER INCX,INCY,LDA,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP1,TEMP2 + INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (N.LT.0) THEN + INFO = 2 + ELSE IF (LDA.LT.MAX(1,N)) THEN + INFO = 5 + ELSE IF (INCX.EQ.0) THEN + INFO = 7 + ELSE IF (INCY.EQ.0) THEN + INFO = 10 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DSYMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN +* +* Set up the start points in X and Y. +* + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (N-1)*INCX + END IF + IF (INCY.GT.0) THEN + KY = 1 + ELSE + KY = 1 - (N-1)*INCY + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through the triangular part +* of A. +* +* First form y := beta*y. +* + IF (BETA.NE.ONE) THEN + IF (INCY.EQ.1) THEN + IF (BETA.EQ.ZERO) THEN + DO 10 I = 1,N + Y(I) = ZERO + 10 CONTINUE + ELSE + DO 20 I = 1,N + Y(I) = BETA*Y(I) + 20 CONTINUE + END IF + ELSE + IY = KY + IF (BETA.EQ.ZERO) THEN + DO 30 I = 1,N + Y(IY) = ZERO + IY = IY + INCY + 30 CONTINUE + ELSE + DO 40 I = 1,N + Y(IY) = BETA*Y(IY) + IY = IY + INCY + 40 CONTINUE + END IF + END IF + END IF + IF (ALPHA.EQ.ZERO) RETURN + IF (LSAME(UPLO,'U')) THEN +* +* Form y when A is stored in upper triangle. +* + IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN + DO 60 J = 1,N + TEMP1 = ALPHA*X(J) + TEMP2 = ZERO + DO 50 I = 1,J - 1 + Y(I) = Y(I) + TEMP1*A(I,J) + TEMP2 = TEMP2 + A(I,J)*X(I) + 50 CONTINUE + Y(J) = Y(J) + TEMP1*A(J,J) + ALPHA*TEMP2 + 60 CONTINUE + ELSE + JX = KX + JY = KY + DO 80 J = 1,N + TEMP1 = ALPHA*X(JX) + TEMP2 = ZERO + IX = KX + IY = KY + DO 70 I = 1,J - 1 + Y(IY) = Y(IY) + TEMP1*A(I,J) + TEMP2 = TEMP2 + A(I,J)*X(IX) + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + Y(JY) = Y(JY) + TEMP1*A(J,J) + ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + 80 CONTINUE + END IF + ELSE +* +* Form y when A is stored in lower triangle. +* + IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN + DO 100 J = 1,N + TEMP1 = ALPHA*X(J) + TEMP2 = ZERO + Y(J) = Y(J) + TEMP1*A(J,J) + DO 90 I = J + 1,N + Y(I) = Y(I) + TEMP1*A(I,J) + TEMP2 = TEMP2 + A(I,J)*X(I) + 90 CONTINUE + Y(J) = Y(J) + ALPHA*TEMP2 + 100 CONTINUE + ELSE + JX = KX + JY = KY + DO 120 J = 1,N + TEMP1 = ALPHA*X(JX) + TEMP2 = ZERO + Y(JY) = Y(JY) + TEMP1*A(J,J) + IX = JX + IY = JY + DO 110 I = J + 1,N + IX = IX + INCX + IY = IY + INCY + Y(IY) = Y(IY) + TEMP1*A(I,J) + TEMP2 = TEMP2 + A(I,J)*X(IX) + 110 CONTINUE + Y(JY) = Y(JY) + ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + 120 CONTINUE + END IF + END IF +* + RETURN +* +* End of DSYMV +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/dsyr.f b/fortran_implementation/external_libraries/BLAS/SRC/dsyr.f new file mode 100644 index 0000000..dd722c4 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/dsyr.f @@ -0,0 +1,260 @@ +*> \brief \b DSYR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DSYR(UPLO,N,ALPHA,X,INCX,A,LDA) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION ALPHA +* INTEGER INCX,LDA,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A(LDA,*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYR performs the symmetric rank 1 operation +*> +*> A := alpha*x*x**T + A, +*> +*> where alpha is a real scalar, x is an n element vector and A is an +*> n by n symmetric matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the array A is to be referenced as +*> follows: +*> +*> UPLO = 'U' or 'u' Only the upper triangular part of A +*> is to be referenced. +*> +*> UPLO = 'L' or 'l' Only the lower triangular part of A +*> is to be referenced. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is DOUBLE PRECISION. +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension ( LDA, N ) +*> Before entry with UPLO = 'U' or 'u', the leading n by n +*> upper triangular part of the array A must contain the upper +*> triangular part of the symmetric matrix and the strictly +*> lower triangular part of A is not referenced. On exit, the +*> upper triangular part of the array A is overwritten by the +*> upper triangular part of the updated matrix. +*> Before entry with UPLO = 'L' or 'l', the leading n by n +*> lower triangular part of the array A must contain the lower +*> triangular part of the symmetric matrix and the strictly +*> upper triangular part of A is not referenced. On exit, the +*> lower triangular part of the array A is overwritten by the +*> lower triangular part of the updated matrix. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> max( 1, n ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup her +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DSYR(UPLO,N,ALPHA,X,INCX,A,LDA) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA + INTEGER INCX,LDA,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER (ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,IX,J,JX,KX +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (N.LT.0) THEN + INFO = 2 + ELSE IF (INCX.EQ.0) THEN + INFO = 5 + ELSE IF (LDA.LT.MAX(1,N)) THEN + INFO = 7 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DSYR ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN +* +* Set the start point in X if the increment is not unity. +* + IF (INCX.LE.0) THEN + KX = 1 - (N-1)*INCX + ELSE IF (INCX.NE.1) THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through the triangular part +* of A. +* + IF (LSAME(UPLO,'U')) THEN +* +* Form A when A is stored in upper triangle. +* + IF (INCX.EQ.1) THEN + DO 20 J = 1,N + IF (X(J).NE.ZERO) THEN + TEMP = ALPHA*X(J) + DO 10 I = 1,J + A(I,J) = A(I,J) + X(I)*TEMP + 10 CONTINUE + END IF + 20 CONTINUE + ELSE + JX = KX + DO 40 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = ALPHA*X(JX) + IX = KX + DO 30 I = 1,J + A(I,J) = A(I,J) + X(IX)*TEMP + IX = IX + INCX + 30 CONTINUE + END IF + JX = JX + INCX + 40 CONTINUE + END IF + ELSE +* +* Form A when A is stored in lower triangle. +* + IF (INCX.EQ.1) THEN + DO 60 J = 1,N + IF (X(J).NE.ZERO) THEN + TEMP = ALPHA*X(J) + DO 50 I = J,N + A(I,J) = A(I,J) + X(I)*TEMP + 50 CONTINUE + END IF + 60 CONTINUE + ELSE + JX = KX + DO 80 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = ALPHA*X(JX) + IX = JX + DO 70 I = J,N + A(I,J) = A(I,J) + X(IX)*TEMP + IX = IX + INCX + 70 CONTINUE + END IF + JX = JX + INCX + 80 CONTINUE + END IF + END IF +* + RETURN +* +* End of DSYR +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/dsyr2.f b/fortran_implementation/external_libraries/BLAS/SRC/dsyr2.f new file mode 100644 index 0000000..93616ff --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/dsyr2.f @@ -0,0 +1,295 @@ +*> \brief \b DSYR2 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DSYR2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION ALPHA +* INTEGER INCX,INCY,LDA,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYR2 performs the symmetric rank 2 operation +*> +*> A := alpha*x*y**T + alpha*y*x**T + A, +*> +*> where alpha is a scalar, x and y are n element vectors and A is an n +*> by n symmetric matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the array A is to be referenced as +*> follows: +*> +*> UPLO = 'U' or 'u' Only the upper triangular part of A +*> is to be referenced. +*> +*> UPLO = 'L' or 'l' Only the lower triangular part of A +*> is to be referenced. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is DOUBLE PRECISION. +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in] Y +*> \verbatim +*> Y is DOUBLE PRECISION array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCY ) ). +*> Before entry, the incremented array Y must contain the n +*> element vector y. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> Y. INCY must not be zero. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension ( LDA, N ) +*> Before entry with UPLO = 'U' or 'u', the leading n by n +*> upper triangular part of the array A must contain the upper +*> triangular part of the symmetric matrix and the strictly +*> lower triangular part of A is not referenced. On exit, the +*> upper triangular part of the array A is overwritten by the +*> upper triangular part of the updated matrix. +*> Before entry with UPLO = 'L' or 'l', the leading n by n +*> lower triangular part of the array A must contain the lower +*> triangular part of the symmetric matrix and the strictly +*> upper triangular part of A is not referenced. On exit, the +*> lower triangular part of the array A is overwritten by the +*> lower triangular part of the updated matrix. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> max( 1, n ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup her2 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DSYR2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA + INTEGER INCX,INCY,LDA,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER (ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP1,TEMP2 + INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (N.LT.0) THEN + INFO = 2 + ELSE IF (INCX.EQ.0) THEN + INFO = 5 + ELSE IF (INCY.EQ.0) THEN + INFO = 7 + ELSE IF (LDA.LT.MAX(1,N)) THEN + INFO = 9 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DSYR2 ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN +* +* Set up the start points in X and Y if the increments are not both +* unity. +* + IF ((INCX.NE.1) .OR. (INCY.NE.1)) THEN + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (N-1)*INCX + END IF + IF (INCY.GT.0) THEN + KY = 1 + ELSE + KY = 1 - (N-1)*INCY + END IF + JX = KX + JY = KY + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through the triangular part +* of A. +* + IF (LSAME(UPLO,'U')) THEN +* +* Form A when A is stored in the upper triangle. +* + IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN + DO 20 J = 1,N + IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN + TEMP1 = ALPHA*Y(J) + TEMP2 = ALPHA*X(J) + DO 10 I = 1,J + A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2 + 10 CONTINUE + END IF + 20 CONTINUE + ELSE + DO 40 J = 1,N + IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN + TEMP1 = ALPHA*Y(JY) + TEMP2 = ALPHA*X(JX) + IX = KX + IY = KY + DO 30 I = 1,J + A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2 + IX = IX + INCX + IY = IY + INCY + 30 CONTINUE + END IF + JX = JX + INCX + JY = JY + INCY + 40 CONTINUE + END IF + ELSE +* +* Form A when A is stored in the lower triangle. +* + IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN + DO 60 J = 1,N + IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN + TEMP1 = ALPHA*Y(J) + TEMP2 = ALPHA*X(J) + DO 50 I = J,N + A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2 + 50 CONTINUE + END IF + 60 CONTINUE + ELSE + DO 80 J = 1,N + IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN + TEMP1 = ALPHA*Y(JY) + TEMP2 = ALPHA*X(JX) + IX = JX + IY = JY + DO 70 I = J,N + A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2 + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + END IF + JX = JX + INCX + JY = JY + INCY + 80 CONTINUE + END IF + END IF +* + RETURN +* +* End of DSYR2 +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/dsyr2k.f b/fortran_implementation/external_libraries/BLAS/SRC/dsyr2k.f new file mode 100644 index 0000000..54e4ea7 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/dsyr2k.f @@ -0,0 +1,396 @@ +*> \brief \b DSYR2K +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION ALPHA,BETA +* INTEGER K,LDA,LDB,LDC,N +* CHARACTER TRANS,UPLO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYR2K performs one of the symmetric rank 2k operations +*> +*> C := alpha*A*B**T + alpha*B*A**T + beta*C, +*> +*> or +*> +*> C := alpha*A**T*B + alpha*B**T*A + beta*C, +*> +*> where alpha and beta are scalars, C is an n by n symmetric matrix +*> and A and B are n by k matrices in the first case and k by n +*> matrices in the second case. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the array C is to be referenced as +*> follows: +*> +*> UPLO = 'U' or 'u' Only the upper triangular part of C +*> is to be referenced. +*> +*> UPLO = 'L' or 'l' Only the lower triangular part of C +*> is to be referenced. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the operation to be performed as +*> follows: +*> +*> TRANS = 'N' or 'n' C := alpha*A*B**T + alpha*B*A**T + +*> beta*C. +*> +*> TRANS = 'T' or 't' C := alpha*A**T*B + alpha*B**T*A + +*> beta*C. +*> +*> TRANS = 'C' or 'c' C := alpha*A**T*B + alpha*B**T*A + +*> beta*C. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix C. N must be +*> at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry with TRANS = 'N' or 'n', K specifies the number +*> of columns of the matrices A and B, and on entry with +*> TRANS = 'T' or 't' or 'C' or 'c', K specifies the number +*> of rows of the matrices A and B. K must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is DOUBLE PRECISION. +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension ( LDA, ka ), where ka is +*> k when TRANS = 'N' or 'n', and is n otherwise. +*> Before entry with TRANS = 'N' or 'n', the leading n by k +*> part of the array A must contain the matrix A, otherwise +*> the leading k by n part of the array A must contain the +*> matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When TRANS = 'N' or 'n' +*> then LDA must be at least max( 1, n ), otherwise LDA must +*> be at least max( 1, k ). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension ( LDB, kb ), where kb is +*> k when TRANS = 'N' or 'n', and is n otherwise. +*> Before entry with TRANS = 'N' or 'n', the leading n by k +*> part of the array B must contain the matrix B, otherwise +*> the leading k by n part of the array B must contain the +*> matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. When TRANS = 'N' or 'n' +*> then LDB must be at least max( 1, n ), otherwise LDB must +*> be at least max( 1, k ). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is DOUBLE PRECISION. +*> On entry, BETA specifies the scalar beta. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension ( LDC, N ) +*> Before entry with UPLO = 'U' or 'u', the leading n by n +*> upper triangular part of the array C must contain the upper +*> triangular part of the symmetric matrix and the strictly +*> lower triangular part of C is not referenced. On exit, the +*> upper triangular part of the array C is overwritten by the +*> upper triangular part of the updated matrix. +*> Before entry with UPLO = 'L' or 'l', the leading n by n +*> lower triangular part of the array C must contain the lower +*> triangular part of the symmetric matrix and the strictly +*> upper triangular part of C is not referenced. On exit, the +*> lower triangular part of the array C is overwritten by the +*> lower triangular part of the updated matrix. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> On entry, LDC specifies the first dimension of C as declared +*> in the calling (sub) program. LDC must be at least +*> max( 1, n ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup her2k +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> +*> -- Written on 8-February-1989. +*> Jack Dongarra, Argonne National Laboratory. +*> Iain Duff, AERE Harwell. +*> Jeremy Du Croz, Numerical Algorithms Group Ltd. +*> Sven Hammarling, Numerical Algorithms Group Ltd. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* -- Reference BLAS level3 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA,BETA + INTEGER K,LDA,LDB,LDC,N + CHARACTER TRANS,UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP1,TEMP2 + INTEGER I,INFO,J,L,NROWA + LOGICAL UPPER +* .. +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) +* .. +* +* Test the input parameters. +* + IF (LSAME(TRANS,'N')) THEN + NROWA = N + ELSE + NROWA = K + END IF + UPPER = LSAME(UPLO,'U') +* + INFO = 0 + IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN + INFO = 1 + ELSE IF ((.NOT.LSAME(TRANS,'N')) .AND. + + (.NOT.LSAME(TRANS,'T')) .AND. + + (.NOT.LSAME(TRANS,'C'))) THEN + INFO = 2 + ELSE IF (N.LT.0) THEN + INFO = 3 + ELSE IF (K.LT.0) THEN + INFO = 4 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 7 + ELSE IF (LDB.LT.MAX(1,NROWA)) THEN + INFO = 9 + ELSE IF (LDC.LT.MAX(1,N)) THEN + INFO = 12 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DSYR2K',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR. + + (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + IF (UPPER) THEN + IF (BETA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,J + C(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1,N + DO 30 I = 1,J + C(I,J) = BETA*C(I,J) + 30 CONTINUE + 40 CONTINUE + END IF + ELSE + IF (BETA.EQ.ZERO) THEN + DO 60 J = 1,N + DO 50 I = J,N + C(I,J) = ZERO + 50 CONTINUE + 60 CONTINUE + ELSE + DO 80 J = 1,N + DO 70 I = J,N + C(I,J) = BETA*C(I,J) + 70 CONTINUE + 80 CONTINUE + END IF + END IF + RETURN + END IF +* +* Start the operations. +* + IF (LSAME(TRANS,'N')) THEN +* +* Form C := alpha*A*B**T + alpha*B*A**T + C. +* + IF (UPPER) THEN + DO 130 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 90 I = 1,J + C(I,J) = ZERO + 90 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 100 I = 1,J + C(I,J) = BETA*C(I,J) + 100 CONTINUE + END IF + DO 120 L = 1,K + IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN + TEMP1 = ALPHA*B(J,L) + TEMP2 = ALPHA*A(J,L) + DO 110 I = 1,J + C(I,J) = C(I,J) + A(I,L)*TEMP1 + + + B(I,L)*TEMP2 + 110 CONTINUE + END IF + 120 CONTINUE + 130 CONTINUE + ELSE + DO 180 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 140 I = J,N + C(I,J) = ZERO + 140 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 150 I = J,N + C(I,J) = BETA*C(I,J) + 150 CONTINUE + END IF + DO 170 L = 1,K + IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN + TEMP1 = ALPHA*B(J,L) + TEMP2 = ALPHA*A(J,L) + DO 160 I = J,N + C(I,J) = C(I,J) + A(I,L)*TEMP1 + + + B(I,L)*TEMP2 + 160 CONTINUE + END IF + 170 CONTINUE + 180 CONTINUE + END IF + ELSE +* +* Form C := alpha*A**T*B + alpha*B**T*A + C. +* + IF (UPPER) THEN + DO 210 J = 1,N + DO 200 I = 1,J + TEMP1 = ZERO + TEMP2 = ZERO + DO 190 L = 1,K + TEMP1 = TEMP1 + A(L,I)*B(L,J) + TEMP2 = TEMP2 + B(L,I)*A(L,J) + 190 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP1 + ALPHA*TEMP2 + ELSE + C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 + + + ALPHA*TEMP2 + END IF + 200 CONTINUE + 210 CONTINUE + ELSE + DO 240 J = 1,N + DO 230 I = J,N + TEMP1 = ZERO + TEMP2 = ZERO + DO 220 L = 1,K + TEMP1 = TEMP1 + A(L,I)*B(L,J) + TEMP2 = TEMP2 + B(L,I)*A(L,J) + 220 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP1 + ALPHA*TEMP2 + ELSE + C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 + + + ALPHA*TEMP2 + END IF + 230 CONTINUE + 240 CONTINUE + END IF + END IF +* + RETURN +* +* End of DSYR2K +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/dsyrk.f b/fortran_implementation/external_libraries/BLAS/SRC/dsyrk.f new file mode 100644 index 0000000..b62fb6d --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/dsyrk.f @@ -0,0 +1,361 @@ +*> \brief \b DSYRK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION ALPHA,BETA +* INTEGER K,LDA,LDC,N +* CHARACTER TRANS,UPLO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A(LDA,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYRK performs one of the symmetric rank k operations +*> +*> C := alpha*A*A**T + beta*C, +*> +*> or +*> +*> C := alpha*A**T*A + beta*C, +*> +*> where alpha and beta are scalars, C is an n by n symmetric matrix +*> and A is an n by k matrix in the first case and a k by n matrix +*> in the second case. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the array C is to be referenced as +*> follows: +*> +*> UPLO = 'U' or 'u' Only the upper triangular part of C +*> is to be referenced. +*> +*> UPLO = 'L' or 'l' Only the lower triangular part of C +*> is to be referenced. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the operation to be performed as +*> follows: +*> +*> TRANS = 'N' or 'n' C := alpha*A*A**T + beta*C. +*> +*> TRANS = 'T' or 't' C := alpha*A**T*A + beta*C. +*> +*> TRANS = 'C' or 'c' C := alpha*A**T*A + beta*C. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix C. N must be +*> at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry with TRANS = 'N' or 'n', K specifies the number +*> of columns of the matrix A, and on entry with +*> TRANS = 'T' or 't' or 'C' or 'c', K specifies the number +*> of rows of the matrix A. K must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is DOUBLE PRECISION. +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension ( LDA, ka ), where ka is +*> k when TRANS = 'N' or 'n', and is n otherwise. +*> Before entry with TRANS = 'N' or 'n', the leading n by k +*> part of the array A must contain the matrix A, otherwise +*> the leading k by n part of the array A must contain the +*> matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When TRANS = 'N' or 'n' +*> then LDA must be at least max( 1, n ), otherwise LDA must +*> be at least max( 1, k ). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is DOUBLE PRECISION. +*> On entry, BETA specifies the scalar beta. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension ( LDC, N ) +*> Before entry with UPLO = 'U' or 'u', the leading n by n +*> upper triangular part of the array C must contain the upper +*> triangular part of the symmetric matrix and the strictly +*> lower triangular part of C is not referenced. On exit, the +*> upper triangular part of the array C is overwritten by the +*> upper triangular part of the updated matrix. +*> Before entry with UPLO = 'L' or 'l', the leading n by n +*> lower triangular part of the array C must contain the lower +*> triangular part of the symmetric matrix and the strictly +*> upper triangular part of C is not referenced. On exit, the +*> lower triangular part of the array C is overwritten by the +*> lower triangular part of the updated matrix. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> On entry, LDC specifies the first dimension of C as declared +*> in the calling (sub) program. LDC must be at least +*> max( 1, n ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup herk +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> -- Written on 8-February-1989. +*> Jack Dongarra, Argonne National Laboratory. +*> Iain Duff, AERE Harwell. +*> Jeremy Du Croz, Numerical Algorithms Group Ltd. +*> Sven Hammarling, Numerical Algorithms Group Ltd. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) +* +* -- Reference BLAS level3 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA,BETA + INTEGER K,LDA,LDC,N + CHARACTER TRANS,UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,J,L,NROWA + LOGICAL UPPER +* .. +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) +* .. +* +* Test the input parameters. +* + IF (LSAME(TRANS,'N')) THEN + NROWA = N + ELSE + NROWA = K + END IF + UPPER = LSAME(UPLO,'U') +* + INFO = 0 + IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN + INFO = 1 + ELSE IF ((.NOT.LSAME(TRANS,'N')) .AND. + + (.NOT.LSAME(TRANS,'T')) .AND. + + (.NOT.LSAME(TRANS,'C'))) THEN + INFO = 2 + ELSE IF (N.LT.0) THEN + INFO = 3 + ELSE IF (K.LT.0) THEN + INFO = 4 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 7 + ELSE IF (LDC.LT.MAX(1,N)) THEN + INFO = 10 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DSYRK ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR. + + (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + IF (UPPER) THEN + IF (BETA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,J + C(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1,N + DO 30 I = 1,J + C(I,J) = BETA*C(I,J) + 30 CONTINUE + 40 CONTINUE + END IF + ELSE + IF (BETA.EQ.ZERO) THEN + DO 60 J = 1,N + DO 50 I = J,N + C(I,J) = ZERO + 50 CONTINUE + 60 CONTINUE + ELSE + DO 80 J = 1,N + DO 70 I = J,N + C(I,J) = BETA*C(I,J) + 70 CONTINUE + 80 CONTINUE + END IF + END IF + RETURN + END IF +* +* Start the operations. +* + IF (LSAME(TRANS,'N')) THEN +* +* Form C := alpha*A*A**T + beta*C. +* + IF (UPPER) THEN + DO 130 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 90 I = 1,J + C(I,J) = ZERO + 90 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 100 I = 1,J + C(I,J) = BETA*C(I,J) + 100 CONTINUE + END IF + DO 120 L = 1,K + IF (A(J,L).NE.ZERO) THEN + TEMP = ALPHA*A(J,L) + DO 110 I = 1,J + C(I,J) = C(I,J) + TEMP*A(I,L) + 110 CONTINUE + END IF + 120 CONTINUE + 130 CONTINUE + ELSE + DO 180 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 140 I = J,N + C(I,J) = ZERO + 140 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 150 I = J,N + C(I,J) = BETA*C(I,J) + 150 CONTINUE + END IF + DO 170 L = 1,K + IF (A(J,L).NE.ZERO) THEN + TEMP = ALPHA*A(J,L) + DO 160 I = J,N + C(I,J) = C(I,J) + TEMP*A(I,L) + 160 CONTINUE + END IF + 170 CONTINUE + 180 CONTINUE + END IF + ELSE +* +* Form C := alpha*A**T*A + beta*C. +* + IF (UPPER) THEN + DO 210 J = 1,N + DO 200 I = 1,J + TEMP = ZERO + DO 190 L = 1,K + TEMP = TEMP + A(L,I)*A(L,J) + 190 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 200 CONTINUE + 210 CONTINUE + ELSE + DO 240 J = 1,N + DO 230 I = J,N + TEMP = ZERO + DO 220 L = 1,K + TEMP = TEMP + A(L,I)*A(L,J) + 220 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 230 CONTINUE + 240 CONTINUE + END IF + END IF +* + RETURN +* +* End of DSYRK +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/dtbmv.f b/fortran_implementation/external_libraries/BLAS/SRC/dtbmv.f new file mode 100644 index 0000000..cdf1e8b --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/dtbmv.f @@ -0,0 +1,397 @@ +*> \brief \b DTBMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DTBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,K,LDA,N +* CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A(LDA,*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTBMV performs one of the matrix-vector operations +*> +*> x := A*x, or x := A**T*x, +*> +*> where x is an n element vector and A is an n by n unit, or non-unit, +*> upper or lower triangular band matrix, with ( k + 1 ) diagonals. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the matrix is an upper or +*> lower triangular matrix as follows: +*> +*> UPLO = 'U' or 'u' A is an upper triangular matrix. +*> +*> UPLO = 'L' or 'l' A is a lower triangular matrix. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the operation to be performed as +*> follows: +*> +*> TRANS = 'N' or 'n' x := A*x. +*> +*> TRANS = 'T' or 't' x := A**T*x. +*> +*> TRANS = 'C' or 'c' x := A**T*x. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> On entry, DIAG specifies whether or not A is unit +*> triangular as follows: +*> +*> DIAG = 'U' or 'u' A is assumed to be unit triangular. +*> +*> DIAG = 'N' or 'n' A is not assumed to be unit +*> triangular. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry with UPLO = 'U' or 'u', K specifies the number of +*> super-diagonals of the matrix A. +*> On entry with UPLO = 'L' or 'l', K specifies the number of +*> sub-diagonals of the matrix A. +*> K must satisfy 0 .le. K. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension ( LDA, N ) +*> Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) +*> by n part of the array A must contain the upper triangular +*> band part of the matrix of coefficients, supplied column by +*> column, with the leading diagonal of the matrix in row +*> ( k + 1 ) of the array, the first super-diagonal starting at +*> position 2 in row k, and so on. The top left k by k triangle +*> of the array A is not referenced. +*> The following program segment will transfer an upper +*> triangular band matrix from conventional full matrix storage +*> to band storage: +*> +*> DO 20, J = 1, N +*> M = K + 1 - J +*> DO 10, I = MAX( 1, J - K ), J +*> A( M + I, J ) = matrix( I, J ) +*> 10 CONTINUE +*> 20 CONTINUE +*> +*> Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) +*> by n part of the array A must contain the lower triangular +*> band part of the matrix of coefficients, supplied column by +*> column, with the leading diagonal of the matrix in row 1 of +*> the array, the first sub-diagonal starting at position 1 in +*> row 2, and so on. The bottom right k by k triangle of the +*> array A is not referenced. +*> The following program segment will transfer a lower +*> triangular band matrix from conventional full matrix storage +*> to band storage: +*> +*> DO 20, J = 1, N +*> M = 1 - J +*> DO 10, I = J, MIN( N, J + K ) +*> A( M + I, J ) = matrix( I, J ) +*> 10 CONTINUE +*> 20 CONTINUE +*> +*> Note that when DIAG = 'U' or 'u' the elements of the array A +*> corresponding to the diagonal elements of the matrix are not +*> referenced, but are assumed to be unity. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> ( k + 1 ). +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element vector x. On exit, X is overwritten with the +*> transformed vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup tbmv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> The vector and matrix arguments are not referenced when N = 0, or M = 0 +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DTBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,K,LDA,N + CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER (ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,IX,J,JX,KPLUS1,KX,L + LOGICAL NOUNIT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX,MIN +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (.NOT.LSAME(TRANS,'N') .AND. + + .NOT.LSAME(TRANS,'T') .AND. + + .NOT.LSAME(TRANS,'C')) THEN + INFO = 2 + ELSE IF (.NOT.LSAME(DIAG,'U') .AND. + + .NOT.LSAME(DIAG,'N')) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (K.LT.0) THEN + INFO = 5 + ELSE IF (LDA.LT. (K+1)) THEN + INFO = 7 + ELSE IF (INCX.EQ.0) THEN + INFO = 9 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DTBMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (N.EQ.0) RETURN +* + NOUNIT = LSAME(DIAG,'N') +* +* Set up the start point in X if the increment is not unity. This +* will be ( N - 1 )*INCX too small for descending loops. +* + IF (INCX.LE.0) THEN + KX = 1 - (N-1)*INCX + ELSE IF (INCX.NE.1) THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* + IF (LSAME(TRANS,'N')) THEN +* +* Form x := A*x. +* + IF (LSAME(UPLO,'U')) THEN + KPLUS1 = K + 1 + IF (INCX.EQ.1) THEN + DO 20 J = 1,N + IF (X(J).NE.ZERO) THEN + TEMP = X(J) + L = KPLUS1 - J + DO 10 I = MAX(1,J-K),J - 1 + X(I) = X(I) + TEMP*A(L+I,J) + 10 CONTINUE + IF (NOUNIT) X(J) = X(J)*A(KPLUS1,J) + END IF + 20 CONTINUE + ELSE + JX = KX + DO 40 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = X(JX) + IX = KX + L = KPLUS1 - J + DO 30 I = MAX(1,J-K),J - 1 + X(IX) = X(IX) + TEMP*A(L+I,J) + IX = IX + INCX + 30 CONTINUE + IF (NOUNIT) X(JX) = X(JX)*A(KPLUS1,J) + END IF + JX = JX + INCX + IF (J.GT.K) KX = KX + INCX + 40 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 60 J = N,1,-1 + IF (X(J).NE.ZERO) THEN + TEMP = X(J) + L = 1 - J + DO 50 I = MIN(N,J+K),J + 1,-1 + X(I) = X(I) + TEMP*A(L+I,J) + 50 CONTINUE + IF (NOUNIT) X(J) = X(J)*A(1,J) + END IF + 60 CONTINUE + ELSE + KX = KX + (N-1)*INCX + JX = KX + DO 80 J = N,1,-1 + IF (X(JX).NE.ZERO) THEN + TEMP = X(JX) + IX = KX + L = 1 - J + DO 70 I = MIN(N,J+K),J + 1,-1 + X(IX) = X(IX) + TEMP*A(L+I,J) + IX = IX - INCX + 70 CONTINUE + IF (NOUNIT) X(JX) = X(JX)*A(1,J) + END IF + JX = JX - INCX + IF ((N-J).GE.K) KX = KX - INCX + 80 CONTINUE + END IF + END IF + ELSE +* +* Form x := A**T*x. +* + IF (LSAME(UPLO,'U')) THEN + KPLUS1 = K + 1 + IF (INCX.EQ.1) THEN + DO 100 J = N,1,-1 + TEMP = X(J) + L = KPLUS1 - J + IF (NOUNIT) TEMP = TEMP*A(KPLUS1,J) + DO 90 I = J - 1,MAX(1,J-K),-1 + TEMP = TEMP + A(L+I,J)*X(I) + 90 CONTINUE + X(J) = TEMP + 100 CONTINUE + ELSE + KX = KX + (N-1)*INCX + JX = KX + DO 120 J = N,1,-1 + TEMP = X(JX) + KX = KX - INCX + IX = KX + L = KPLUS1 - J + IF (NOUNIT) TEMP = TEMP*A(KPLUS1,J) + DO 110 I = J - 1,MAX(1,J-K),-1 + TEMP = TEMP + A(L+I,J)*X(IX) + IX = IX - INCX + 110 CONTINUE + X(JX) = TEMP + JX = JX - INCX + 120 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 140 J = 1,N + TEMP = X(J) + L = 1 - J + IF (NOUNIT) TEMP = TEMP*A(1,J) + DO 130 I = J + 1,MIN(N,J+K) + TEMP = TEMP + A(L+I,J)*X(I) + 130 CONTINUE + X(J) = TEMP + 140 CONTINUE + ELSE + JX = KX + DO 160 J = 1,N + TEMP = X(JX) + KX = KX + INCX + IX = KX + L = 1 - J + IF (NOUNIT) TEMP = TEMP*A(1,J) + DO 150 I = J + 1,MIN(N,J+K) + TEMP = TEMP + A(L+I,J)*X(IX) + IX = IX + INCX + 150 CONTINUE + X(JX) = TEMP + JX = JX + INCX + 160 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of DTBMV +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/dtbsv.f b/fortran_implementation/external_libraries/BLAS/SRC/dtbsv.f new file mode 100644 index 0000000..683a5eb --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/dtbsv.f @@ -0,0 +1,400 @@ +*> \brief \b DTBSV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DTBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,K,LDA,N +* CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A(LDA,*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTBSV solves one of the systems of equations +*> +*> A*x = b, or A**T*x = b, +*> +*> where b and x are n element vectors and A is an n by n unit, or +*> non-unit, upper or lower triangular band matrix, with ( k + 1 ) +*> diagonals. +*> +*> No test for singularity or near-singularity is included in this +*> routine. Such tests must be performed before calling this routine. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the matrix is an upper or +*> lower triangular matrix as follows: +*> +*> UPLO = 'U' or 'u' A is an upper triangular matrix. +*> +*> UPLO = 'L' or 'l' A is a lower triangular matrix. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the equations to be solved as +*> follows: +*> +*> TRANS = 'N' or 'n' A*x = b. +*> +*> TRANS = 'T' or 't' A**T*x = b. +*> +*> TRANS = 'C' or 'c' A**T*x = b. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> On entry, DIAG specifies whether or not A is unit +*> triangular as follows: +*> +*> DIAG = 'U' or 'u' A is assumed to be unit triangular. +*> +*> DIAG = 'N' or 'n' A is not assumed to be unit +*> triangular. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry with UPLO = 'U' or 'u', K specifies the number of +*> super-diagonals of the matrix A. +*> On entry with UPLO = 'L' or 'l', K specifies the number of +*> sub-diagonals of the matrix A. +*> K must satisfy 0 .le. K. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension ( LDA, N ) +*> Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) +*> by n part of the array A must contain the upper triangular +*> band part of the matrix of coefficients, supplied column by +*> column, with the leading diagonal of the matrix in row +*> ( k + 1 ) of the array, the first super-diagonal starting at +*> position 2 in row k, and so on. The top left k by k triangle +*> of the array A is not referenced. +*> The following program segment will transfer an upper +*> triangular band matrix from conventional full matrix storage +*> to band storage: +*> +*> DO 20, J = 1, N +*> M = K + 1 - J +*> DO 10, I = MAX( 1, J - K ), J +*> A( M + I, J ) = matrix( I, J ) +*> 10 CONTINUE +*> 20 CONTINUE +*> +*> Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) +*> by n part of the array A must contain the lower triangular +*> band part of the matrix of coefficients, supplied column by +*> column, with the leading diagonal of the matrix in row 1 of +*> the array, the first sub-diagonal starting at position 1 in +*> row 2, and so on. The bottom right k by k triangle of the +*> array A is not referenced. +*> The following program segment will transfer a lower +*> triangular band matrix from conventional full matrix storage +*> to band storage: +*> +*> DO 20, J = 1, N +*> M = 1 - J +*> DO 10, I = J, MIN( N, J + K ) +*> A( M + I, J ) = matrix( I, J ) +*> 10 CONTINUE +*> 20 CONTINUE +*> +*> Note that when DIAG = 'U' or 'u' the elements of the array A +*> corresponding to the diagonal elements of the matrix are not +*> referenced, but are assumed to be unity. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> ( k + 1 ). +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element right-hand side vector b. On exit, X is overwritten +*> with the solution vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup tbsv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DTBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,K,LDA,N + CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER (ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,IX,J,JX,KPLUS1,KX,L + LOGICAL NOUNIT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX,MIN +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (.NOT.LSAME(TRANS,'N') .AND. + + .NOT.LSAME(TRANS,'T') .AND. + + .NOT.LSAME(TRANS,'C')) THEN + INFO = 2 + ELSE IF (.NOT.LSAME(DIAG,'U') .AND. + + .NOT.LSAME(DIAG,'N')) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (K.LT.0) THEN + INFO = 5 + ELSE IF (LDA.LT. (K+1)) THEN + INFO = 7 + ELSE IF (INCX.EQ.0) THEN + INFO = 9 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DTBSV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (N.EQ.0) RETURN +* + NOUNIT = LSAME(DIAG,'N') +* +* Set up the start point in X if the increment is not unity. This +* will be ( N - 1 )*INCX too small for descending loops. +* + IF (INCX.LE.0) THEN + KX = 1 - (N-1)*INCX + ELSE IF (INCX.NE.1) THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of A are +* accessed by sequentially with one pass through A. +* + IF (LSAME(TRANS,'N')) THEN +* +* Form x := inv( A )*x. +* + IF (LSAME(UPLO,'U')) THEN + KPLUS1 = K + 1 + IF (INCX.EQ.1) THEN + DO 20 J = N,1,-1 + IF (X(J).NE.ZERO) THEN + L = KPLUS1 - J + IF (NOUNIT) X(J) = X(J)/A(KPLUS1,J) + TEMP = X(J) + DO 10 I = J - 1,MAX(1,J-K),-1 + X(I) = X(I) - TEMP*A(L+I,J) + 10 CONTINUE + END IF + 20 CONTINUE + ELSE + KX = KX + (N-1)*INCX + JX = KX + DO 40 J = N,1,-1 + KX = KX - INCX + IF (X(JX).NE.ZERO) THEN + IX = KX + L = KPLUS1 - J + IF (NOUNIT) X(JX) = X(JX)/A(KPLUS1,J) + TEMP = X(JX) + DO 30 I = J - 1,MAX(1,J-K),-1 + X(IX) = X(IX) - TEMP*A(L+I,J) + IX = IX - INCX + 30 CONTINUE + END IF + JX = JX - INCX + 40 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 60 J = 1,N + IF (X(J).NE.ZERO) THEN + L = 1 - J + IF (NOUNIT) X(J) = X(J)/A(1,J) + TEMP = X(J) + DO 50 I = J + 1,MIN(N,J+K) + X(I) = X(I) - TEMP*A(L+I,J) + 50 CONTINUE + END IF + 60 CONTINUE + ELSE + JX = KX + DO 80 J = 1,N + KX = KX + INCX + IF (X(JX).NE.ZERO) THEN + IX = KX + L = 1 - J + IF (NOUNIT) X(JX) = X(JX)/A(1,J) + TEMP = X(JX) + DO 70 I = J + 1,MIN(N,J+K) + X(IX) = X(IX) - TEMP*A(L+I,J) + IX = IX + INCX + 70 CONTINUE + END IF + JX = JX + INCX + 80 CONTINUE + END IF + END IF + ELSE +* +* Form x := inv( A**T)*x. +* + IF (LSAME(UPLO,'U')) THEN + KPLUS1 = K + 1 + IF (INCX.EQ.1) THEN + DO 100 J = 1,N + TEMP = X(J) + L = KPLUS1 - J + DO 90 I = MAX(1,J-K),J - 1 + TEMP = TEMP - A(L+I,J)*X(I) + 90 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(KPLUS1,J) + X(J) = TEMP + 100 CONTINUE + ELSE + JX = KX + DO 120 J = 1,N + TEMP = X(JX) + IX = KX + L = KPLUS1 - J + DO 110 I = MAX(1,J-K),J - 1 + TEMP = TEMP - A(L+I,J)*X(IX) + IX = IX + INCX + 110 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(KPLUS1,J) + X(JX) = TEMP + JX = JX + INCX + IF (J.GT.K) KX = KX + INCX + 120 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 140 J = N,1,-1 + TEMP = X(J) + L = 1 - J + DO 130 I = MIN(N,J+K),J + 1,-1 + TEMP = TEMP - A(L+I,J)*X(I) + 130 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(1,J) + X(J) = TEMP + 140 CONTINUE + ELSE + KX = KX + (N-1)*INCX + JX = KX + DO 160 J = N,1,-1 + TEMP = X(JX) + IX = KX + L = 1 - J + DO 150 I = MIN(N,J+K),J + 1,-1 + TEMP = TEMP - A(L+I,J)*X(IX) + IX = IX - INCX + 150 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(1,J) + X(JX) = TEMP + JX = JX - INCX + IF ((N-J).GE.K) KX = KX - INCX + 160 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of DTBSV +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/dtpmv.f b/fortran_implementation/external_libraries/BLAS/SRC/dtpmv.f new file mode 100644 index 0000000..a45bf98 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/dtpmv.f @@ -0,0 +1,351 @@ +*> \brief \b DTPMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DTPMV(UPLO,TRANS,DIAG,N,AP,X,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,N +* CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AP(*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTPMV performs one of the matrix-vector operations +*> +*> x := A*x, or x := A**T*x, +*> +*> where x is an n element vector and A is an n by n unit, or non-unit, +*> upper or lower triangular matrix, supplied in packed form. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the matrix is an upper or +*> lower triangular matrix as follows: +*> +*> UPLO = 'U' or 'u' A is an upper triangular matrix. +*> +*> UPLO = 'L' or 'l' A is a lower triangular matrix. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the operation to be performed as +*> follows: +*> +*> TRANS = 'N' or 'n' x := A*x. +*> +*> TRANS = 'T' or 't' x := A**T*x. +*> +*> TRANS = 'C' or 'c' x := A**T*x. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> On entry, DIAG specifies whether or not A is unit +*> triangular as follows: +*> +*> DIAG = 'U' or 'u' A is assumed to be unit triangular. +*> +*> DIAG = 'N' or 'n' A is not assumed to be unit +*> triangular. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] AP +*> \verbatim +*> AP is DOUBLE PRECISION array, dimension at least +*> ( ( n*( n + 1 ) )/2 ). +*> Before entry with UPLO = 'U' or 'u', the array AP must +*> contain the upper triangular matrix packed sequentially, +*> column by column, so that AP( 1 ) contains a( 1, 1 ), +*> AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) +*> respectively, and so on. +*> Before entry with UPLO = 'L' or 'l', the array AP must +*> contain the lower triangular matrix packed sequentially, +*> column by column, so that AP( 1 ) contains a( 1, 1 ), +*> AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) +*> respectively, and so on. +*> Note that when DIAG = 'U' or 'u', the diagonal elements of +*> A are not referenced, but are assumed to be unity. +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element vector x. On exit, X is overwritten with the +*> transformed vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup tpmv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> The vector and matrix arguments are not referenced when N = 0, or M = 0 +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DTPMV(UPLO,TRANS,DIAG,N,AP,X,INCX) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,N + CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION AP(*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER (ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,IX,J,JX,K,KK,KX + LOGICAL NOUNIT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (.NOT.LSAME(TRANS,'N') .AND. + + .NOT.LSAME(TRANS,'T') .AND. + + .NOT.LSAME(TRANS,'C')) THEN + INFO = 2 + ELSE IF (.NOT.LSAME(DIAG,'U') .AND. + + .NOT.LSAME(DIAG,'N')) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (INCX.EQ.0) THEN + INFO = 7 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DTPMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (N.EQ.0) RETURN +* + NOUNIT = LSAME(DIAG,'N') +* +* Set up the start point in X if the increment is not unity. This +* will be ( N - 1 )*INCX too small for descending loops. +* + IF (INCX.LE.0) THEN + KX = 1 - (N-1)*INCX + ELSE IF (INCX.NE.1) THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of AP are +* accessed sequentially with one pass through AP. +* + IF (LSAME(TRANS,'N')) THEN +* +* Form x:= A*x. +* + IF (LSAME(UPLO,'U')) THEN + KK = 1 + IF (INCX.EQ.1) THEN + DO 20 J = 1,N + IF (X(J).NE.ZERO) THEN + TEMP = X(J) + K = KK + DO 10 I = 1,J - 1 + X(I) = X(I) + TEMP*AP(K) + K = K + 1 + 10 CONTINUE + IF (NOUNIT) X(J) = X(J)*AP(KK+J-1) + END IF + KK = KK + J + 20 CONTINUE + ELSE + JX = KX + DO 40 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = X(JX) + IX = KX + DO 30 K = KK,KK + J - 2 + X(IX) = X(IX) + TEMP*AP(K) + IX = IX + INCX + 30 CONTINUE + IF (NOUNIT) X(JX) = X(JX)*AP(KK+J-1) + END IF + JX = JX + INCX + KK = KK + J + 40 CONTINUE + END IF + ELSE + KK = (N* (N+1))/2 + IF (INCX.EQ.1) THEN + DO 60 J = N,1,-1 + IF (X(J).NE.ZERO) THEN + TEMP = X(J) + K = KK + DO 50 I = N,J + 1,-1 + X(I) = X(I) + TEMP*AP(K) + K = K - 1 + 50 CONTINUE + IF (NOUNIT) X(J) = X(J)*AP(KK-N+J) + END IF + KK = KK - (N-J+1) + 60 CONTINUE + ELSE + KX = KX + (N-1)*INCX + JX = KX + DO 80 J = N,1,-1 + IF (X(JX).NE.ZERO) THEN + TEMP = X(JX) + IX = KX + DO 70 K = KK,KK - (N- (J+1)),-1 + X(IX) = X(IX) + TEMP*AP(K) + IX = IX - INCX + 70 CONTINUE + IF (NOUNIT) X(JX) = X(JX)*AP(KK-N+J) + END IF + JX = JX - INCX + KK = KK - (N-J+1) + 80 CONTINUE + END IF + END IF + ELSE +* +* Form x := A**T*x. +* + IF (LSAME(UPLO,'U')) THEN + KK = (N* (N+1))/2 + IF (INCX.EQ.1) THEN + DO 100 J = N,1,-1 + TEMP = X(J) + IF (NOUNIT) TEMP = TEMP*AP(KK) + K = KK - 1 + DO 90 I = J - 1,1,-1 + TEMP = TEMP + AP(K)*X(I) + K = K - 1 + 90 CONTINUE + X(J) = TEMP + KK = KK - J + 100 CONTINUE + ELSE + JX = KX + (N-1)*INCX + DO 120 J = N,1,-1 + TEMP = X(JX) + IX = JX + IF (NOUNIT) TEMP = TEMP*AP(KK) + DO 110 K = KK - 1,KK - J + 1,-1 + IX = IX - INCX + TEMP = TEMP + AP(K)*X(IX) + 110 CONTINUE + X(JX) = TEMP + JX = JX - INCX + KK = KK - J + 120 CONTINUE + END IF + ELSE + KK = 1 + IF (INCX.EQ.1) THEN + DO 140 J = 1,N + TEMP = X(J) + IF (NOUNIT) TEMP = TEMP*AP(KK) + K = KK + 1 + DO 130 I = J + 1,N + TEMP = TEMP + AP(K)*X(I) + K = K + 1 + 130 CONTINUE + X(J) = TEMP + KK = KK + (N-J+1) + 140 CONTINUE + ELSE + JX = KX + DO 160 J = 1,N + TEMP = X(JX) + IX = JX + IF (NOUNIT) TEMP = TEMP*AP(KK) + DO 150 K = KK + 1,KK + N - J + IX = IX + INCX + TEMP = TEMP + AP(K)*X(IX) + 150 CONTINUE + X(JX) = TEMP + JX = JX + INCX + KK = KK + (N-J+1) + 160 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of DTPMV +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/dtpsv.f b/fortran_implementation/external_libraries/BLAS/SRC/dtpsv.f new file mode 100644 index 0000000..72bbb88 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/dtpsv.f @@ -0,0 +1,353 @@ +*> \brief \b DTPSV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DTPSV(UPLO,TRANS,DIAG,N,AP,X,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,N +* CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AP(*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTPSV solves one of the systems of equations +*> +*> A*x = b, or A**T*x = b, +*> +*> where b and x are n element vectors and A is an n by n unit, or +*> non-unit, upper or lower triangular matrix, supplied in packed form. +*> +*> No test for singularity or near-singularity is included in this +*> routine. Such tests must be performed before calling this routine. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the matrix is an upper or +*> lower triangular matrix as follows: +*> +*> UPLO = 'U' or 'u' A is an upper triangular matrix. +*> +*> UPLO = 'L' or 'l' A is a lower triangular matrix. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the equations to be solved as +*> follows: +*> +*> TRANS = 'N' or 'n' A*x = b. +*> +*> TRANS = 'T' or 't' A**T*x = b. +*> +*> TRANS = 'C' or 'c' A**T*x = b. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> On entry, DIAG specifies whether or not A is unit +*> triangular as follows: +*> +*> DIAG = 'U' or 'u' A is assumed to be unit triangular. +*> +*> DIAG = 'N' or 'n' A is not assumed to be unit +*> triangular. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] AP +*> \verbatim +*> AP is DOUBLE PRECISION array, dimension at least +*> ( ( n*( n + 1 ) )/2 ). +*> Before entry with UPLO = 'U' or 'u', the array AP must +*> contain the upper triangular matrix packed sequentially, +*> column by column, so that AP( 1 ) contains a( 1, 1 ), +*> AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) +*> respectively, and so on. +*> Before entry with UPLO = 'L' or 'l', the array AP must +*> contain the lower triangular matrix packed sequentially, +*> column by column, so that AP( 1 ) contains a( 1, 1 ), +*> AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) +*> respectively, and so on. +*> Note that when DIAG = 'U' or 'u', the diagonal elements of +*> A are not referenced, but are assumed to be unity. +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element right-hand side vector b. On exit, X is overwritten +*> with the solution vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup tpsv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DTPSV(UPLO,TRANS,DIAG,N,AP,X,INCX) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,N + CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION AP(*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER (ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,IX,J,JX,K,KK,KX + LOGICAL NOUNIT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (.NOT.LSAME(TRANS,'N') .AND. + + .NOT.LSAME(TRANS,'T') .AND. + + .NOT.LSAME(TRANS,'C')) THEN + INFO = 2 + ELSE IF (.NOT.LSAME(DIAG,'U') .AND. + + .NOT.LSAME(DIAG,'N')) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (INCX.EQ.0) THEN + INFO = 7 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DTPSV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (N.EQ.0) RETURN +* + NOUNIT = LSAME(DIAG,'N') +* +* Set up the start point in X if the increment is not unity. This +* will be ( N - 1 )*INCX too small for descending loops. +* + IF (INCX.LE.0) THEN + KX = 1 - (N-1)*INCX + ELSE IF (INCX.NE.1) THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of AP are +* accessed sequentially with one pass through AP. +* + IF (LSAME(TRANS,'N')) THEN +* +* Form x := inv( A )*x. +* + IF (LSAME(UPLO,'U')) THEN + KK = (N* (N+1))/2 + IF (INCX.EQ.1) THEN + DO 20 J = N,1,-1 + IF (X(J).NE.ZERO) THEN + IF (NOUNIT) X(J) = X(J)/AP(KK) + TEMP = X(J) + K = KK - 1 + DO 10 I = J - 1,1,-1 + X(I) = X(I) - TEMP*AP(K) + K = K - 1 + 10 CONTINUE + END IF + KK = KK - J + 20 CONTINUE + ELSE + JX = KX + (N-1)*INCX + DO 40 J = N,1,-1 + IF (X(JX).NE.ZERO) THEN + IF (NOUNIT) X(JX) = X(JX)/AP(KK) + TEMP = X(JX) + IX = JX + DO 30 K = KK - 1,KK - J + 1,-1 + IX = IX - INCX + X(IX) = X(IX) - TEMP*AP(K) + 30 CONTINUE + END IF + JX = JX - INCX + KK = KK - J + 40 CONTINUE + END IF + ELSE + KK = 1 + IF (INCX.EQ.1) THEN + DO 60 J = 1,N + IF (X(J).NE.ZERO) THEN + IF (NOUNIT) X(J) = X(J)/AP(KK) + TEMP = X(J) + K = KK + 1 + DO 50 I = J + 1,N + X(I) = X(I) - TEMP*AP(K) + K = K + 1 + 50 CONTINUE + END IF + KK = KK + (N-J+1) + 60 CONTINUE + ELSE + JX = KX + DO 80 J = 1,N + IF (X(JX).NE.ZERO) THEN + IF (NOUNIT) X(JX) = X(JX)/AP(KK) + TEMP = X(JX) + IX = JX + DO 70 K = KK + 1,KK + N - J + IX = IX + INCX + X(IX) = X(IX) - TEMP*AP(K) + 70 CONTINUE + END IF + JX = JX + INCX + KK = KK + (N-J+1) + 80 CONTINUE + END IF + END IF + ELSE +* +* Form x := inv( A**T )*x. +* + IF (LSAME(UPLO,'U')) THEN + KK = 1 + IF (INCX.EQ.1) THEN + DO 100 J = 1,N + TEMP = X(J) + K = KK + DO 90 I = 1,J - 1 + TEMP = TEMP - AP(K)*X(I) + K = K + 1 + 90 CONTINUE + IF (NOUNIT) TEMP = TEMP/AP(KK+J-1) + X(J) = TEMP + KK = KK + J + 100 CONTINUE + ELSE + JX = KX + DO 120 J = 1,N + TEMP = X(JX) + IX = KX + DO 110 K = KK,KK + J - 2 + TEMP = TEMP - AP(K)*X(IX) + IX = IX + INCX + 110 CONTINUE + IF (NOUNIT) TEMP = TEMP/AP(KK+J-1) + X(JX) = TEMP + JX = JX + INCX + KK = KK + J + 120 CONTINUE + END IF + ELSE + KK = (N* (N+1))/2 + IF (INCX.EQ.1) THEN + DO 140 J = N,1,-1 + TEMP = X(J) + K = KK + DO 130 I = N,J + 1,-1 + TEMP = TEMP - AP(K)*X(I) + K = K - 1 + 130 CONTINUE + IF (NOUNIT) TEMP = TEMP/AP(KK-N+J) + X(J) = TEMP + KK = KK - (N-J+1) + 140 CONTINUE + ELSE + KX = KX + (N-1)*INCX + JX = KX + DO 160 J = N,1,-1 + TEMP = X(JX) + IX = KX + DO 150 K = KK,KK - (N- (J+1)),-1 + TEMP = TEMP - AP(K)*X(IX) + IX = IX - INCX + 150 CONTINUE + IF (NOUNIT) TEMP = TEMP/AP(KK-N+J) + X(JX) = TEMP + JX = JX - INCX + KK = KK - (N-J+1) + 160 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of DTPSV +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/dtrmm.f b/fortran_implementation/external_libraries/BLAS/SRC/dtrmm.f new file mode 100644 index 0000000..2424ca8 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/dtrmm.f @@ -0,0 +1,413 @@ +*> \brief \b DTRMM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION ALPHA +* INTEGER LDA,LDB,M,N +* CHARACTER DIAG,SIDE,TRANSA,UPLO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A(LDA,*),B(LDB,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTRMM performs one of the matrix-matrix operations +*> +*> B := alpha*op( A )*B, or B := alpha*B*op( A ), +*> +*> where alpha is a scalar, B is an m by n matrix, A is a unit, or +*> non-unit, upper or lower triangular matrix and op( A ) is one of +*> +*> op( A ) = A or op( A ) = A**T. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> On entry, SIDE specifies whether op( A ) multiplies B from +*> the left or right as follows: +*> +*> SIDE = 'L' or 'l' B := alpha*op( A )*B. +*> +*> SIDE = 'R' or 'r' B := alpha*B*op( A ). +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the matrix A is an upper or +*> lower triangular matrix as follows: +*> +*> UPLO = 'U' or 'u' A is an upper triangular matrix. +*> +*> UPLO = 'L' or 'l' A is a lower triangular matrix. +*> \endverbatim +*> +*> \param[in] TRANSA +*> \verbatim +*> TRANSA is CHARACTER*1 +*> On entry, TRANSA specifies the form of op( A ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSA = 'N' or 'n' op( A ) = A. +*> +*> TRANSA = 'T' or 't' op( A ) = A**T. +*> +*> TRANSA = 'C' or 'c' op( A ) = A**T. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> On entry, DIAG specifies whether or not A is unit triangular +*> as follows: +*> +*> DIAG = 'U' or 'u' A is assumed to be unit triangular. +*> +*> DIAG = 'N' or 'n' A is not assumed to be unit +*> triangular. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of B. M must be at +*> least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of B. N must be +*> at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is DOUBLE PRECISION. +*> On entry, ALPHA specifies the scalar alpha. When alpha is +*> zero then A is not referenced and B need not be set before +*> entry. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension ( LDA, k ), where k is m +*> when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. +*> Before entry with UPLO = 'U' or 'u', the leading k by k +*> upper triangular part of the array A must contain the upper +*> triangular matrix and the strictly lower triangular part of +*> A is not referenced. +*> Before entry with UPLO = 'L' or 'l', the leading k by k +*> lower triangular part of the array A must contain the lower +*> triangular matrix and the strictly upper triangular part of +*> A is not referenced. +*> Note that when DIAG = 'U' or 'u', the diagonal elements of +*> A are not referenced either, but are assumed to be unity. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When SIDE = 'L' or 'l' then +*> LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' +*> then LDA must be at least max( 1, n ). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension ( LDB, N ) +*> Before entry, the leading m by n part of the array B must +*> contain the matrix B, and on exit is overwritten by the +*> transformed matrix. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. LDB must be at least +*> max( 1, m ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup trmm +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> -- Written on 8-February-1989. +*> Jack Dongarra, Argonne National Laboratory. +*> Iain Duff, AERE Harwell. +*> Jeremy Du Croz, Numerical Algorithms Group Ltd. +*> Sven Hammarling, Numerical Algorithms Group Ltd. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +* +* -- Reference BLAS level3 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA + INTEGER LDA,LDB,M,N + CHARACTER DIAG,SIDE,TRANSA,UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),B(LDB,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,J,K,NROWA + LOGICAL LSIDE,NOUNIT,UPPER +* .. +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) +* .. +* +* Test the input parameters. +* + LSIDE = LSAME(SIDE,'L') + IF (LSIDE) THEN + NROWA = M + ELSE + NROWA = N + END IF + NOUNIT = LSAME(DIAG,'N') + UPPER = LSAME(UPLO,'U') +* + INFO = 0 + IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN + INFO = 1 + ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN + INFO = 2 + ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND. + + (.NOT.LSAME(TRANSA,'T')) .AND. + + (.NOT.LSAME(TRANSA,'C'))) THEN + INFO = 3 + ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. + + (.NOT.LSAME(DIAG,'N'))) THEN + INFO = 4 + ELSE IF (M.LT.0) THEN + INFO = 5 + ELSE IF (N.LT.0) THEN + INFO = 6 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 9 + ELSE IF (LDB.LT.MAX(1,M)) THEN + INFO = 11 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DTRMM ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (M.EQ.0 .OR. N.EQ.0) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,M + B(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + RETURN + END IF +* +* Start the operations. +* + IF (LSIDE) THEN + IF (LSAME(TRANSA,'N')) THEN +* +* Form B := alpha*A*B. +* + IF (UPPER) THEN + DO 50 J = 1,N + DO 40 K = 1,M + IF (B(K,J).NE.ZERO) THEN + TEMP = ALPHA*B(K,J) + DO 30 I = 1,K - 1 + B(I,J) = B(I,J) + TEMP*A(I,K) + 30 CONTINUE + IF (NOUNIT) TEMP = TEMP*A(K,K) + B(K,J) = TEMP + END IF + 40 CONTINUE + 50 CONTINUE + ELSE + DO 80 J = 1,N + DO 70 K = M,1,-1 + IF (B(K,J).NE.ZERO) THEN + TEMP = ALPHA*B(K,J) + B(K,J) = TEMP + IF (NOUNIT) B(K,J) = B(K,J)*A(K,K) + DO 60 I = K + 1,M + B(I,J) = B(I,J) + TEMP*A(I,K) + 60 CONTINUE + END IF + 70 CONTINUE + 80 CONTINUE + END IF + ELSE +* +* Form B := alpha*A**T*B. +* + IF (UPPER) THEN + DO 110 J = 1,N + DO 100 I = M,1,-1 + TEMP = B(I,J) + IF (NOUNIT) TEMP = TEMP*A(I,I) + DO 90 K = 1,I - 1 + TEMP = TEMP + A(K,I)*B(K,J) + 90 CONTINUE + B(I,J) = ALPHA*TEMP + 100 CONTINUE + 110 CONTINUE + ELSE + DO 140 J = 1,N + DO 130 I = 1,M + TEMP = B(I,J) + IF (NOUNIT) TEMP = TEMP*A(I,I) + DO 120 K = I + 1,M + TEMP = TEMP + A(K,I)*B(K,J) + 120 CONTINUE + B(I,J) = ALPHA*TEMP + 130 CONTINUE + 140 CONTINUE + END IF + END IF + ELSE + IF (LSAME(TRANSA,'N')) THEN +* +* Form B := alpha*B*A. +* + IF (UPPER) THEN + DO 180 J = N,1,-1 + TEMP = ALPHA + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 150 I = 1,M + B(I,J) = TEMP*B(I,J) + 150 CONTINUE + DO 170 K = 1,J - 1 + IF (A(K,J).NE.ZERO) THEN + TEMP = ALPHA*A(K,J) + DO 160 I = 1,M + B(I,J) = B(I,J) + TEMP*B(I,K) + 160 CONTINUE + END IF + 170 CONTINUE + 180 CONTINUE + ELSE + DO 220 J = 1,N + TEMP = ALPHA + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 190 I = 1,M + B(I,J) = TEMP*B(I,J) + 190 CONTINUE + DO 210 K = J + 1,N + IF (A(K,J).NE.ZERO) THEN + TEMP = ALPHA*A(K,J) + DO 200 I = 1,M + B(I,J) = B(I,J) + TEMP*B(I,K) + 200 CONTINUE + END IF + 210 CONTINUE + 220 CONTINUE + END IF + ELSE +* +* Form B := alpha*B*A**T. +* + IF (UPPER) THEN + DO 260 K = 1,N + DO 240 J = 1,K - 1 + IF (A(J,K).NE.ZERO) THEN + TEMP = ALPHA*A(J,K) + DO 230 I = 1,M + B(I,J) = B(I,J) + TEMP*B(I,K) + 230 CONTINUE + END IF + 240 CONTINUE + TEMP = ALPHA + IF (NOUNIT) TEMP = TEMP*A(K,K) + IF (TEMP.NE.ONE) THEN + DO 250 I = 1,M + B(I,K) = TEMP*B(I,K) + 250 CONTINUE + END IF + 260 CONTINUE + ELSE + DO 300 K = N,1,-1 + DO 280 J = K + 1,N + IF (A(J,K).NE.ZERO) THEN + TEMP = ALPHA*A(J,K) + DO 270 I = 1,M + B(I,J) = B(I,J) + TEMP*B(I,K) + 270 CONTINUE + END IF + 280 CONTINUE + TEMP = ALPHA + IF (NOUNIT) TEMP = TEMP*A(K,K) + IF (TEMP.NE.ONE) THEN + DO 290 I = 1,M + B(I,K) = TEMP*B(I,K) + 290 CONTINUE + END IF + 300 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of DTRMM +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/dtrmv.f b/fortran_implementation/external_libraries/BLAS/SRC/dtrmv.f new file mode 100644 index 0000000..48f2b44 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/dtrmv.f @@ -0,0 +1,341 @@ +*> \brief \b DTRMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,LDA,N +* CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A(LDA,*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTRMV performs one of the matrix-vector operations +*> +*> x := A*x, or x := A**T*x, +*> +*> where x is an n element vector and A is an n by n unit, or non-unit, +*> upper or lower triangular matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the matrix is an upper or +*> lower triangular matrix as follows: +*> +*> UPLO = 'U' or 'u' A is an upper triangular matrix. +*> +*> UPLO = 'L' or 'l' A is a lower triangular matrix. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the operation to be performed as +*> follows: +*> +*> TRANS = 'N' or 'n' x := A*x. +*> +*> TRANS = 'T' or 't' x := A**T*x. +*> +*> TRANS = 'C' or 'c' x := A**T*x. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> On entry, DIAG specifies whether or not A is unit +*> triangular as follows: +*> +*> DIAG = 'U' or 'u' A is assumed to be unit triangular. +*> +*> DIAG = 'N' or 'n' A is not assumed to be unit +*> triangular. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension ( LDA, N ) +*> Before entry with UPLO = 'U' or 'u', the leading n by n +*> upper triangular part of the array A must contain the upper +*> triangular matrix and the strictly lower triangular part of +*> A is not referenced. +*> Before entry with UPLO = 'L' or 'l', the leading n by n +*> lower triangular part of the array A must contain the lower +*> triangular matrix and the strictly upper triangular part of +*> A is not referenced. +*> Note that when DIAG = 'U' or 'u', the diagonal elements of +*> A are not referenced either, but are assumed to be unity. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> max( 1, n ). +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element vector x. On exit, X is overwritten with the +*> transformed vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup trmv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> The vector and matrix arguments are not referenced when N = 0, or M = 0 +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,LDA,N + CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER (ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,IX,J,JX,KX + LOGICAL NOUNIT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (.NOT.LSAME(TRANS,'N') .AND. + + .NOT.LSAME(TRANS,'T') .AND. + + .NOT.LSAME(TRANS,'C')) THEN + INFO = 2 + ELSE IF (.NOT.LSAME(DIAG,'U') .AND. + + .NOT.LSAME(DIAG,'N')) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (LDA.LT.MAX(1,N)) THEN + INFO = 6 + ELSE IF (INCX.EQ.0) THEN + INFO = 8 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DTRMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (N.EQ.0) RETURN +* + NOUNIT = LSAME(DIAG,'N') +* +* Set up the start point in X if the increment is not unity. This +* will be ( N - 1 )*INCX too small for descending loops. +* + IF (INCX.LE.0) THEN + KX = 1 - (N-1)*INCX + ELSE IF (INCX.NE.1) THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* + IF (LSAME(TRANS,'N')) THEN +* +* Form x := A*x. +* + IF (LSAME(UPLO,'U')) THEN + IF (INCX.EQ.1) THEN + DO 20 J = 1,N + IF (X(J).NE.ZERO) THEN + TEMP = X(J) + DO 10 I = 1,J - 1 + X(I) = X(I) + TEMP*A(I,J) + 10 CONTINUE + IF (NOUNIT) X(J) = X(J)*A(J,J) + END IF + 20 CONTINUE + ELSE + JX = KX + DO 40 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = X(JX) + IX = KX + DO 30 I = 1,J - 1 + X(IX) = X(IX) + TEMP*A(I,J) + IX = IX + INCX + 30 CONTINUE + IF (NOUNIT) X(JX) = X(JX)*A(J,J) + END IF + JX = JX + INCX + 40 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 60 J = N,1,-1 + IF (X(J).NE.ZERO) THEN + TEMP = X(J) + DO 50 I = N,J + 1,-1 + X(I) = X(I) + TEMP*A(I,J) + 50 CONTINUE + IF (NOUNIT) X(J) = X(J)*A(J,J) + END IF + 60 CONTINUE + ELSE + KX = KX + (N-1)*INCX + JX = KX + DO 80 J = N,1,-1 + IF (X(JX).NE.ZERO) THEN + TEMP = X(JX) + IX = KX + DO 70 I = N,J + 1,-1 + X(IX) = X(IX) + TEMP*A(I,J) + IX = IX - INCX + 70 CONTINUE + IF (NOUNIT) X(JX) = X(JX)*A(J,J) + END IF + JX = JX - INCX + 80 CONTINUE + END IF + END IF + ELSE +* +* Form x := A**T*x. +* + IF (LSAME(UPLO,'U')) THEN + IF (INCX.EQ.1) THEN + DO 100 J = N,1,-1 + TEMP = X(J) + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 90 I = J - 1,1,-1 + TEMP = TEMP + A(I,J)*X(I) + 90 CONTINUE + X(J) = TEMP + 100 CONTINUE + ELSE + JX = KX + (N-1)*INCX + DO 120 J = N,1,-1 + TEMP = X(JX) + IX = JX + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 110 I = J - 1,1,-1 + IX = IX - INCX + TEMP = TEMP + A(I,J)*X(IX) + 110 CONTINUE + X(JX) = TEMP + JX = JX - INCX + 120 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 140 J = 1,N + TEMP = X(J) + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 130 I = J + 1,N + TEMP = TEMP + A(I,J)*X(I) + 130 CONTINUE + X(J) = TEMP + 140 CONTINUE + ELSE + JX = KX + DO 160 J = 1,N + TEMP = X(JX) + IX = JX + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 150 I = J + 1,N + IX = IX + INCX + TEMP = TEMP + A(I,J)*X(IX) + 150 CONTINUE + X(JX) = TEMP + JX = JX + INCX + 160 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of DTRMV +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/dtrsm.f b/fortran_implementation/external_libraries/BLAS/SRC/dtrsm.f new file mode 100644 index 0000000..44b91f4 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/dtrsm.f @@ -0,0 +1,441 @@ +*> \brief \b DTRSM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION ALPHA +* INTEGER LDA,LDB,M,N +* CHARACTER DIAG,SIDE,TRANSA,UPLO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A(LDA,*),B(LDB,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTRSM solves one of the matrix equations +*> +*> op( A )*X = alpha*B, or X*op( A ) = alpha*B, +*> +*> where alpha is a scalar, X and B are m by n matrices, A is a unit, or +*> non-unit, upper or lower triangular matrix and op( A ) is one of +*> +*> op( A ) = A or op( A ) = A**T. +*> +*> The matrix X is overwritten on B. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> On entry, SIDE specifies whether op( A ) appears on the left +*> or right of X as follows: +*> +*> SIDE = 'L' or 'l' op( A )*X = alpha*B. +*> +*> SIDE = 'R' or 'r' X*op( A ) = alpha*B. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the matrix A is an upper or +*> lower triangular matrix as follows: +*> +*> UPLO = 'U' or 'u' A is an upper triangular matrix. +*> +*> UPLO = 'L' or 'l' A is a lower triangular matrix. +*> \endverbatim +*> +*> \param[in] TRANSA +*> \verbatim +*> TRANSA is CHARACTER*1 +*> On entry, TRANSA specifies the form of op( A ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSA = 'N' or 'n' op( A ) = A. +*> +*> TRANSA = 'T' or 't' op( A ) = A**T. +*> +*> TRANSA = 'C' or 'c' op( A ) = A**T. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> On entry, DIAG specifies whether or not A is unit triangular +*> as follows: +*> +*> DIAG = 'U' or 'u' A is assumed to be unit triangular. +*> +*> DIAG = 'N' or 'n' A is not assumed to be unit +*> triangular. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of B. M must be at +*> least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of B. N must be +*> at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is DOUBLE PRECISION. +*> On entry, ALPHA specifies the scalar alpha. When alpha is +*> zero then A is not referenced and B need not be set before +*> entry. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension ( LDA, k ), +*> where k is m when SIDE = 'L' or 'l' +*> and k is n when SIDE = 'R' or 'r'. +*> Before entry with UPLO = 'U' or 'u', the leading k by k +*> upper triangular part of the array A must contain the upper +*> triangular matrix and the strictly lower triangular part of +*> A is not referenced. +*> Before entry with UPLO = 'L' or 'l', the leading k by k +*> lower triangular part of the array A must contain the lower +*> triangular matrix and the strictly upper triangular part of +*> A is not referenced. +*> Note that when DIAG = 'U' or 'u', the diagonal elements of +*> A are not referenced either, but are assumed to be unity. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When SIDE = 'L' or 'l' then +*> LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' +*> then LDA must be at least max( 1, n ). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension ( LDB, N ) +*> Before entry, the leading m by n part of the array B must +*> contain the right-hand side matrix B, and on exit is +*> overwritten by the solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. LDB must be at least +*> max( 1, m ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup trsm +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> +*> -- Written on 8-February-1989. +*> Jack Dongarra, Argonne National Laboratory. +*> Iain Duff, AERE Harwell. +*> Jeremy Du Croz, Numerical Algorithms Group Ltd. +*> Sven Hammarling, Numerical Algorithms Group Ltd. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +* +* -- Reference BLAS level3 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA + INTEGER LDA,LDB,M,N + CHARACTER DIAG,SIDE,TRANSA,UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),B(LDB,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,J,K,NROWA + LOGICAL LSIDE,NOUNIT,UPPER +* .. +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) +* .. +* +* Test the input parameters. +* + LSIDE = LSAME(SIDE,'L') + IF (LSIDE) THEN + NROWA = M + ELSE + NROWA = N + END IF + NOUNIT = LSAME(DIAG,'N') + UPPER = LSAME(UPLO,'U') +* + INFO = 0 + IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN + INFO = 1 + ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN + INFO = 2 + ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND. + + (.NOT.LSAME(TRANSA,'T')) .AND. + + (.NOT.LSAME(TRANSA,'C'))) THEN + INFO = 3 + ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. + + (.NOT.LSAME(DIAG,'N'))) THEN + INFO = 4 + ELSE IF (M.LT.0) THEN + INFO = 5 + ELSE IF (N.LT.0) THEN + INFO = 6 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 9 + ELSE IF (LDB.LT.MAX(1,M)) THEN + INFO = 11 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DTRSM ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (M.EQ.0 .OR. N.EQ.0) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,M + B(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + RETURN + END IF +* +* Start the operations. +* + IF (LSIDE) THEN + IF (LSAME(TRANSA,'N')) THEN +* +* Form B := alpha*inv( A )*B. +* + IF (UPPER) THEN + DO 60 J = 1,N + IF (ALPHA.NE.ONE) THEN + DO 30 I = 1,M + B(I,J) = ALPHA*B(I,J) + 30 CONTINUE + END IF + DO 50 K = M,1,-1 + IF (B(K,J).NE.ZERO) THEN + IF (NOUNIT) B(K,J) = B(K,J)/A(K,K) + DO 40 I = 1,K - 1 + B(I,J) = B(I,J) - B(K,J)*A(I,K) + 40 CONTINUE + END IF + 50 CONTINUE + 60 CONTINUE + ELSE + DO 100 J = 1,N + IF (ALPHA.NE.ONE) THEN + DO 70 I = 1,M + B(I,J) = ALPHA*B(I,J) + 70 CONTINUE + END IF + DO 90 K = 1,M + IF (B(K,J).NE.ZERO) THEN + IF (NOUNIT) B(K,J) = B(K,J)/A(K,K) + DO 80 I = K + 1,M + B(I,J) = B(I,J) - B(K,J)*A(I,K) + 80 CONTINUE + END IF + 90 CONTINUE + 100 CONTINUE + END IF + ELSE +* +* Form B := alpha*inv( A**T )*B. +* + IF (UPPER) THEN + DO 130 J = 1,N + DO 120 I = 1,M + TEMP = ALPHA*B(I,J) + DO 110 K = 1,I - 1 + TEMP = TEMP - A(K,I)*B(K,J) + 110 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(I,I) + B(I,J) = TEMP + 120 CONTINUE + 130 CONTINUE + ELSE + DO 160 J = 1,N + DO 150 I = M,1,-1 + TEMP = ALPHA*B(I,J) + DO 140 K = I + 1,M + TEMP = TEMP - A(K,I)*B(K,J) + 140 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(I,I) + B(I,J) = TEMP + 150 CONTINUE + 160 CONTINUE + END IF + END IF + ELSE + IF (LSAME(TRANSA,'N')) THEN +* +* Form B := alpha*B*inv( A ). +* + IF (UPPER) THEN + DO 210 J = 1,N + IF (ALPHA.NE.ONE) THEN + DO 170 I = 1,M + B(I,J) = ALPHA*B(I,J) + 170 CONTINUE + END IF + DO 190 K = 1,J - 1 + IF (A(K,J).NE.ZERO) THEN + DO 180 I = 1,M + B(I,J) = B(I,J) - A(K,J)*B(I,K) + 180 CONTINUE + END IF + 190 CONTINUE + IF (NOUNIT) THEN + TEMP = ONE/A(J,J) + DO 200 I = 1,M + B(I,J) = TEMP*B(I,J) + 200 CONTINUE + END IF + 210 CONTINUE + ELSE + DO 260 J = N,1,-1 + IF (ALPHA.NE.ONE) THEN + DO 220 I = 1,M + B(I,J) = ALPHA*B(I,J) + 220 CONTINUE + END IF + DO 240 K = J + 1,N + IF (A(K,J).NE.ZERO) THEN + DO 230 I = 1,M + B(I,J) = B(I,J) - A(K,J)*B(I,K) + 230 CONTINUE + END IF + 240 CONTINUE + IF (NOUNIT) THEN + TEMP = ONE/A(J,J) + DO 250 I = 1,M + B(I,J) = TEMP*B(I,J) + 250 CONTINUE + END IF + 260 CONTINUE + END IF + ELSE +* +* Form B := alpha*B*inv( A**T ). +* + IF (UPPER) THEN + DO 310 K = N,1,-1 + IF (NOUNIT) THEN + TEMP = ONE/A(K,K) + DO 270 I = 1,M + B(I,K) = TEMP*B(I,K) + 270 CONTINUE + END IF + DO 290 J = 1,K - 1 + IF (A(J,K).NE.ZERO) THEN + TEMP = A(J,K) + DO 280 I = 1,M + B(I,J) = B(I,J) - TEMP*B(I,K) + 280 CONTINUE + END IF + 290 CONTINUE + IF (ALPHA.NE.ONE) THEN + DO 300 I = 1,M + B(I,K) = ALPHA*B(I,K) + 300 CONTINUE + END IF + 310 CONTINUE + ELSE + DO 360 K = 1,N + IF (NOUNIT) THEN + TEMP = ONE/A(K,K) + DO 320 I = 1,M + B(I,K) = TEMP*B(I,K) + 320 CONTINUE + END IF + DO 340 J = K + 1,N + IF (A(J,K).NE.ZERO) THEN + TEMP = A(J,K) + DO 330 I = 1,M + B(I,J) = B(I,J) - TEMP*B(I,K) + 330 CONTINUE + END IF + 340 CONTINUE + IF (ALPHA.NE.ONE) THEN + DO 350 I = 1,M + B(I,K) = ALPHA*B(I,K) + 350 CONTINUE + END IF + 360 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of DTRSM +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/dtrsv.f b/fortran_implementation/external_libraries/BLAS/SRC/dtrsv.f new file mode 100644 index 0000000..dadb4ef --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/dtrsv.f @@ -0,0 +1,337 @@ +*> \brief \b DTRSV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,LDA,N +* CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A(LDA,*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTRSV solves one of the systems of equations +*> +*> A*x = b, or A**T*x = b, +*> +*> where b and x are n element vectors and A is an n by n unit, or +*> non-unit, upper or lower triangular matrix. +*> +*> No test for singularity or near-singularity is included in this +*> routine. Such tests must be performed before calling this routine. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the matrix is an upper or +*> lower triangular matrix as follows: +*> +*> UPLO = 'U' or 'u' A is an upper triangular matrix. +*> +*> UPLO = 'L' or 'l' A is a lower triangular matrix. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the equations to be solved as +*> follows: +*> +*> TRANS = 'N' or 'n' A*x = b. +*> +*> TRANS = 'T' or 't' A**T*x = b. +*> +*> TRANS = 'C' or 'c' A**T*x = b. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> On entry, DIAG specifies whether or not A is unit +*> triangular as follows: +*> +*> DIAG = 'U' or 'u' A is assumed to be unit triangular. +*> +*> DIAG = 'N' or 'n' A is not assumed to be unit +*> triangular. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension ( LDA, N ) +*> Before entry with UPLO = 'U' or 'u', the leading n by n +*> upper triangular part of the array A must contain the upper +*> triangular matrix and the strictly lower triangular part of +*> A is not referenced. +*> Before entry with UPLO = 'L' or 'l', the leading n by n +*> lower triangular part of the array A must contain the lower +*> triangular matrix and the strictly upper triangular part of +*> A is not referenced. +*> Note that when DIAG = 'U' or 'u', the diagonal elements of +*> A are not referenced either, but are assumed to be unity. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> max( 1, n ). +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element right-hand side vector b. On exit, X is overwritten +*> with the solution vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> +*> Level 2 Blas routine. +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup trsv +* +* ===================================================================== + SUBROUTINE DTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,LDA,N + CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER (ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,IX,J,JX,KX + LOGICAL NOUNIT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (.NOT.LSAME(TRANS,'N') .AND. + + .NOT.LSAME(TRANS,'T') .AND. + + .NOT.LSAME(TRANS,'C')) THEN + INFO = 2 + ELSE IF (.NOT.LSAME(DIAG,'U') .AND. + + .NOT.LSAME(DIAG,'N')) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (LDA.LT.MAX(1,N)) THEN + INFO = 6 + ELSE IF (INCX.EQ.0) THEN + INFO = 8 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DTRSV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (N.EQ.0) RETURN +* + NOUNIT = LSAME(DIAG,'N') +* +* Set up the start point in X if the increment is not unity. This +* will be ( N - 1 )*INCX too small for descending loops. +* + IF (INCX.LE.0) THEN + KX = 1 - (N-1)*INCX + ELSE IF (INCX.NE.1) THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* + IF (LSAME(TRANS,'N')) THEN +* +* Form x := inv( A )*x. +* + IF (LSAME(UPLO,'U')) THEN + IF (INCX.EQ.1) THEN + DO 20 J = N,1,-1 + IF (X(J).NE.ZERO) THEN + IF (NOUNIT) X(J) = X(J)/A(J,J) + TEMP = X(J) + DO 10 I = J - 1,1,-1 + X(I) = X(I) - TEMP*A(I,J) + 10 CONTINUE + END IF + 20 CONTINUE + ELSE + JX = KX + (N-1)*INCX + DO 40 J = N,1,-1 + IF (X(JX).NE.ZERO) THEN + IF (NOUNIT) X(JX) = X(JX)/A(J,J) + TEMP = X(JX) + IX = JX + DO 30 I = J - 1,1,-1 + IX = IX - INCX + X(IX) = X(IX) - TEMP*A(I,J) + 30 CONTINUE + END IF + JX = JX - INCX + 40 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 60 J = 1,N + IF (X(J).NE.ZERO) THEN + IF (NOUNIT) X(J) = X(J)/A(J,J) + TEMP = X(J) + DO 50 I = J + 1,N + X(I) = X(I) - TEMP*A(I,J) + 50 CONTINUE + END IF + 60 CONTINUE + ELSE + JX = KX + DO 80 J = 1,N + IF (X(JX).NE.ZERO) THEN + IF (NOUNIT) X(JX) = X(JX)/A(J,J) + TEMP = X(JX) + IX = JX + DO 70 I = J + 1,N + IX = IX + INCX + X(IX) = X(IX) - TEMP*A(I,J) + 70 CONTINUE + END IF + JX = JX + INCX + 80 CONTINUE + END IF + END IF + ELSE +* +* Form x := inv( A**T )*x. +* + IF (LSAME(UPLO,'U')) THEN + IF (INCX.EQ.1) THEN + DO 100 J = 1,N + TEMP = X(J) + DO 90 I = 1,J - 1 + TEMP = TEMP - A(I,J)*X(I) + 90 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(J,J) + X(J) = TEMP + 100 CONTINUE + ELSE + JX = KX + DO 120 J = 1,N + TEMP = X(JX) + IX = KX + DO 110 I = 1,J - 1 + TEMP = TEMP - A(I,J)*X(IX) + IX = IX + INCX + 110 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(J,J) + X(JX) = TEMP + JX = JX + INCX + 120 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 140 J = N,1,-1 + TEMP = X(J) + DO 130 I = N,J + 1,-1 + TEMP = TEMP - A(I,J)*X(I) + 130 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(J,J) + X(J) = TEMP + 140 CONTINUE + ELSE + KX = KX + (N-1)*INCX + JX = KX + DO 160 J = N,1,-1 + TEMP = X(JX) + IX = KX + DO 150 I = N,J + 1,-1 + TEMP = TEMP - A(I,J)*X(IX) + IX = IX - INCX + 150 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(J,J) + X(JX) = TEMP + JX = JX - INCX + 160 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of DTRSV +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/dzasum.f b/fortran_implementation/external_libraries/BLAS/SRC/dzasum.f new file mode 100644 index 0000000..98f45b0 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/dzasum.f @@ -0,0 +1,118 @@ +*> \brief \b DZASUM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DZASUM(N,ZX,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,N +* .. +* .. Array Arguments .. +* COMPLEX*16 ZX(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DZASUM takes the sum of the (|Re(.)| + |Im(.)|)'s of a complex vector and +*> returns a double precision result. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in,out] ZX +*> \verbatim +*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of ZX +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup asum +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, 3/11/78. +*> modified 3/93 to return if incx .le. 0. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + DOUBLE PRECISION FUNCTION DZASUM(N,ZX,INCX) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,N +* .. +* .. Array Arguments .. + COMPLEX*16 ZX(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + DOUBLE PRECISION STEMP + INTEGER I,NINCX +* .. +* .. External Functions .. + DOUBLE PRECISION DCABS1 + EXTERNAL DCABS1 +* .. + DZASUM = 0.0d0 + STEMP = 0.0d0 + IF (N.LE.0 .OR. INCX.LE.0) RETURN + IF (INCX.EQ.1) THEN +* +* code for increment equal to 1 +* + DO I = 1,N + STEMP = STEMP + DCABS1(ZX(I)) + END DO + ELSE +* +* code for increment not equal to 1 +* + NINCX = N*INCX + DO I = 1,NINCX,INCX + STEMP = STEMP + DCABS1(ZX(I)) + END DO + END IF + DZASUM = STEMP + RETURN +* +* End of DZASUM +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/dznrm2.f90 b/fortran_implementation/external_libraries/BLAS/SRC/dznrm2.f90 new file mode 100644 index 0000000..f8e5ce0 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/dznrm2.f90 @@ -0,0 +1,209 @@ +!> \brief \b DZNRM2 +! +! =========== DOCUMENTATION =========== +! +! Online html documentation available at +! http://www.netlib.org/lapack/explore-html/ +! +! Definition: +! =========== +! +! DOUBLE PRECISION FUNCTION DZNRM2(N,X,INCX) +! +! .. Scalar Arguments .. +! INTEGER INCX,N +! .. +! .. Array Arguments .. +! DOUBLE COMPLEX X(*) +! .. +! +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> DZNRM2 returns the euclidean norm of a vector via the function +!> name, so that +!> +!> DZNRM2 := sqrt( x**H*x ) +!> \endverbatim +! +! Arguments: +! ========== +! +!> \param[in] N +!> \verbatim +!> N is INTEGER +!> number of elements in input vector(s) +!> \endverbatim +!> +!> \param[in] X +!> \verbatim +!> X is COMPLEX*16 array, dimension (N) +!> complex vector with N elements +!> \endverbatim +!> +!> \param[in] INCX +!> \verbatim +!> INCX is INTEGER, storage spacing between elements of X +!> If INCX > 0, X(1+(i-1)*INCX) = x(i) for 1 <= i <= n +!> If INCX < 0, X(1-(n-i)*INCX) = x(i) for 1 <= i <= n +!> If INCX = 0, x isn't a vector so there is no need to call +!> this subroutine. If you call it anyway, it will count x(1) +!> in the vector norm N times. +!> \endverbatim +! +! Authors: +! ======== +! +!> \author Edward Anderson, Lockheed Martin +! +!> \date August 2016 +! +!> \ingroup nrm2 +! +!> \par Contributors: +! ================== +!> +!> Weslley Pereira, University of Colorado Denver, USA +! +!> \par Further Details: +! ===================== +!> +!> \verbatim +!> +!> Anderson E. (2017) +!> Algorithm 978: Safe Scaling in the Level 1 BLAS +!> ACM Trans Math Softw 44:1--28 +!> https://doi.org/10.1145/3061665 +!> +!> Blue, James L. (1978) +!> A Portable Fortran Program to Find the Euclidean Norm of a Vector +!> ACM Trans Math Softw 4:15--23 +!> https://doi.org/10.1145/355769.355771 +!> +!> \endverbatim +!> +! ===================================================================== +function DZNRM2( n, x, incx ) + integer, parameter :: wp = kind(1.d0) + real(wp) :: DZNRM2 +! +! -- Reference BLAS level1 routine (version 3.9.1) -- +! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +! March 2021 +! +! .. Constants .. + real(wp), parameter :: zero = 0.0_wp + real(wp), parameter :: one = 1.0_wp + real(wp), parameter :: maxN = huge(0.0_wp) +! .. +! .. Blue's scaling constants .. + real(wp), parameter :: tsml = real(radix(0._wp), wp)**ceiling( & + (minexponent(0._wp) - 1) * 0.5_wp) + real(wp), parameter :: tbig = real(radix(0._wp), wp)**floor( & + (maxexponent(0._wp) - digits(0._wp) + 1) * 0.5_wp) + real(wp), parameter :: ssml = real(radix(0._wp), wp)**( - floor( & + (minexponent(0._wp) - digits(0._wp)) * 0.5_wp)) + real(wp), parameter :: sbig = real(radix(0._wp), wp)**( - ceiling( & + (maxexponent(0._wp) + digits(0._wp) - 1) * 0.5_wp)) +! .. +! .. Scalar Arguments .. + integer :: incx, n +! .. +! .. Array Arguments .. + complex(wp) :: x(*) +! .. +! .. Local Scalars .. + integer :: i, ix + logical :: notbig + real(wp) :: abig, amed, asml, ax, scl, sumsq, ymax, ymin +! +! Quick return if possible +! + DZNRM2 = zero + if( n <= 0 ) return +! + scl = one + sumsq = zero +! +! Compute the sum of squares in 3 accumulators: +! abig -- sums of squares scaled down to avoid overflow +! asml -- sums of squares scaled up to avoid underflow +! amed -- sums of squares that do not require scaling +! The thresholds and multipliers are +! tbig -- values bigger than this are scaled down by sbig +! tsml -- values smaller than this are scaled up by ssml +! + notbig = .true. + asml = zero + amed = zero + abig = zero + ix = 1 + if( incx < 0 ) ix = 1 - (n-1)*incx + do i = 1, n + ax = abs(real(x(ix))) + if (ax > tbig) then + abig = abig + (ax*sbig)**2 + notbig = .false. + else if (ax < tsml) then + if (notbig) asml = asml + (ax*ssml)**2 + else + amed = amed + ax**2 + end if + ax = abs(aimag(x(ix))) + if (ax > tbig) then + abig = abig + (ax*sbig)**2 + notbig = .false. + else if (ax < tsml) then + if (notbig) asml = asml + (ax*ssml)**2 + else + amed = amed + ax**2 + end if + ix = ix + incx + end do +! +! Combine abig and amed or amed and asml if more than one +! accumulator was used. +! + if (abig > zero) then +! +! Combine abig and amed if abig > 0. +! + if ( (amed > zero) .or. (amed > maxN) .or. (amed /= amed) ) then + abig = abig + (amed*sbig)*sbig + end if + scl = one / sbig + sumsq = abig + else if (asml > zero) then +! +! Combine amed and asml if asml > 0. +! + if ( (amed > zero) .or. (amed > maxN) .or. (amed /= amed) ) then + amed = sqrt(amed) + asml = sqrt(asml) / ssml + if (asml > amed) then + ymin = amed + ymax = asml + else + ymin = asml + ymax = amed + end if + scl = one + sumsq = ymax**2*( one + (ymin/ymax)**2 ) + else + scl = one / ssml + sumsq = asml + end if + else +! +! Otherwise all values are mid-range +! + scl = one + sumsq = amed + end if + DZNRM2 = scl*sqrt( sumsq ) + return +end function diff --git a/fortran_implementation/external_libraries/BLAS/SRC/icamax.f b/fortran_implementation/external_libraries/BLAS/SRC/icamax.f new file mode 100644 index 0000000..b65cbf8 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/icamax.f @@ -0,0 +1,127 @@ +*> \brief \b ICAMAX +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* INTEGER FUNCTION ICAMAX(N,CX,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,N +* .. +* .. Array Arguments .. +* COMPLEX CX(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ICAMAX finds the index of the first element having maximum |Re(.)| + |Im(.)| +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] CX +*> \verbatim +*> CX is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of CX +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup iamax +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, linpack, 3/11/78. +*> modified 3/93 to return if incx .le. 0. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + INTEGER FUNCTION ICAMAX(N,CX,INCX) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,N +* .. +* .. Array Arguments .. + COMPLEX CX(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + REAL SMAX + INTEGER I,IX +* .. +* .. External Functions .. + REAL SCABS1 + EXTERNAL SCABS1 +* .. + ICAMAX = 0 + IF (N.LT.1 .OR. INCX.LE.0) RETURN + ICAMAX = 1 + IF (N.EQ.1) RETURN + IF (INCX.EQ.1) THEN +* +* code for increment equal to 1 +* + SMAX = SCABS1(CX(1)) + DO I = 2,N + IF (SCABS1(CX(I)).GT.SMAX) THEN + ICAMAX = I + SMAX = SCABS1(CX(I)) + END IF + END DO + ELSE +* +* code for increment not equal to 1 +* + IX = 1 + SMAX = SCABS1(CX(1)) + IX = IX + INCX + DO I = 2,N + IF (SCABS1(CX(IX)).GT.SMAX) THEN + ICAMAX = I + SMAX = SCABS1(CX(IX)) + END IF + IX = IX + INCX + END DO + END IF + RETURN +* +* End of ICAMAX +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/idamax.f b/fortran_implementation/external_libraries/BLAS/SRC/idamax.f new file mode 100644 index 0000000..06d7d7e --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/idamax.f @@ -0,0 +1,126 @@ +*> \brief \b IDAMAX +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* INTEGER FUNCTION IDAMAX(N,DX,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION DX(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> IDAMAX finds the index of the first element having maximum absolute value. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] DX +*> \verbatim +*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of DX +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup iamax +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, linpack, 3/11/78. +*> modified 3/93 to return if incx .le. 0. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + INTEGER FUNCTION IDAMAX(N,DX,INCX) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DX(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + DOUBLE PRECISION DMAX + INTEGER I,IX +* .. +* .. Intrinsic Functions .. + INTRINSIC DABS +* .. + IDAMAX = 0 + IF (N.LT.1 .OR. INCX.LE.0) RETURN + IDAMAX = 1 + IF (N.EQ.1) RETURN + IF (INCX.EQ.1) THEN +* +* code for increment equal to 1 +* + DMAX = DABS(DX(1)) + DO I = 2,N + IF (DABS(DX(I)).GT.DMAX) THEN + IDAMAX = I + DMAX = DABS(DX(I)) + END IF + END DO + ELSE +* +* code for increment not equal to 1 +* + IX = 1 + DMAX = DABS(DX(1)) + IX = IX + INCX + DO I = 2,N + IF (DABS(DX(IX)).GT.DMAX) THEN + IDAMAX = I + DMAX = DABS(DX(IX)) + END IF + IX = IX + INCX + END DO + END IF + RETURN +* +* End of IDAMAX +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/isamax.f b/fortran_implementation/external_libraries/BLAS/SRC/isamax.f new file mode 100644 index 0000000..91e8f27 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/isamax.f @@ -0,0 +1,126 @@ +*> \brief \b ISAMAX +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* INTEGER FUNCTION ISAMAX(N,SX,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,N +* .. +* .. Array Arguments .. +* REAL SX(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ISAMAX finds the index of the first element having maximum absolute value. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] SX +*> \verbatim +*> SX is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of SX +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup iamax +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, linpack, 3/11/78. +*> modified 3/93 to return if incx .le. 0. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + INTEGER FUNCTION ISAMAX(N,SX,INCX) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,N +* .. +* .. Array Arguments .. + REAL SX(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + REAL SMAX + INTEGER I,IX +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS +* .. + ISAMAX = 0 + IF (N.LT.1 .OR. INCX.LE.0) RETURN + ISAMAX = 1 + IF (N.EQ.1) RETURN + IF (INCX.EQ.1) THEN +* +* code for increment equal to 1 +* + SMAX = ABS(SX(1)) + DO I = 2,N + IF (ABS(SX(I)).GT.SMAX) THEN + ISAMAX = I + SMAX = ABS(SX(I)) + END IF + END DO + ELSE +* +* code for increment not equal to 1 +* + IX = 1 + SMAX = ABS(SX(1)) + IX = IX + INCX + DO I = 2,N + IF (ABS(SX(IX)).GT.SMAX) THEN + ISAMAX = I + SMAX = ABS(SX(IX)) + END IF + IX = IX + INCX + END DO + END IF + RETURN +* +* End of ISAMAX +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/izamax.f b/fortran_implementation/external_libraries/BLAS/SRC/izamax.f new file mode 100644 index 0000000..0fe4125 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/izamax.f @@ -0,0 +1,127 @@ +*> \brief \b IZAMAX +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* INTEGER FUNCTION IZAMAX(N,ZX,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,N +* .. +* .. Array Arguments .. +* COMPLEX*16 ZX(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> IZAMAX finds the index of the first element having maximum |Re(.)| + |Im(.)| +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] ZX +*> \verbatim +*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of ZX +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup iamax +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, 1/15/85. +*> modified 3/93 to return if incx .le. 0. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + INTEGER FUNCTION IZAMAX(N,ZX,INCX) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,N +* .. +* .. Array Arguments .. + COMPLEX*16 ZX(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + DOUBLE PRECISION DMAX + INTEGER I,IX +* .. +* .. External Functions .. + DOUBLE PRECISION DCABS1 + EXTERNAL DCABS1 +* .. + IZAMAX = 0 + IF (N.LT.1 .OR. INCX.LE.0) RETURN + IZAMAX = 1 + IF (N.EQ.1) RETURN + IF (INCX.EQ.1) THEN +* +* code for increment equal to 1 +* + DMAX = DCABS1(ZX(1)) + DO I = 2,N + IF (DCABS1(ZX(I)).GT.DMAX) THEN + IZAMAX = I + DMAX = DCABS1(ZX(I)) + END IF + END DO + ELSE +* +* code for increment not equal to 1 +* + IX = 1 + DMAX = DCABS1(ZX(1)) + IX = IX + INCX + DO I = 2,N + IF (DCABS1(ZX(IX)).GT.DMAX) THEN + IZAMAX = I + DMAX = DCABS1(ZX(IX)) + END IF + IX = IX + INCX + END DO + END IF + RETURN +* +* End of IZAMAX +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/lsame.f b/fortran_implementation/external_libraries/BLAS/SRC/lsame.f new file mode 100644 index 0000000..eef9ee5 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/lsame.f @@ -0,0 +1,122 @@ +*> \brief \b LSAME +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* LOGICAL FUNCTION LSAME(CA,CB) +* +* .. Scalar Arguments .. +* CHARACTER CA,CB +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> LSAME returns .TRUE. if CA is the same letter as CB regardless of +*> case. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] CA +*> \verbatim +*> CA is CHARACTER*1 +*> \endverbatim +*> +*> \param[in] CB +*> \verbatim +*> CB is CHARACTER*1 +*> CA and CB specify the single characters to be compared. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup lsame +* +* ===================================================================== + LOGICAL FUNCTION LSAME(CA,CB) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER CA,CB +* .. +* +* ===================================================================== +* +* .. Intrinsic Functions .. + INTRINSIC ICHAR +* .. +* .. Local Scalars .. + INTEGER INTA,INTB,ZCODE +* .. +* +* Test if the characters are equal +* + LSAME = CA .EQ. CB + IF (LSAME) RETURN +* +* Now test for equivalence if both characters are alphabetic. +* + ZCODE = ICHAR('Z') +* +* Use 'Z' rather than 'A' so that ASCII can be detected on Prime +* machines, on which ICHAR returns a value with bit 8 set. +* ICHAR('A') on Prime machines returns 193 which is the same as +* ICHAR('A') on an EBCDIC machine. +* + INTA = ICHAR(CA) + INTB = ICHAR(CB) +* + IF (ZCODE.EQ.90 .OR. ZCODE.EQ.122) THEN +* +* ASCII is assumed - ZCODE is the ASCII code of either lower or +* upper case 'Z'. +* + IF (INTA.GE.97 .AND. INTA.LE.122) INTA = INTA - 32 + IF (INTB.GE.97 .AND. INTB.LE.122) INTB = INTB - 32 +* + ELSE IF (ZCODE.EQ.233 .OR. ZCODE.EQ.169) THEN +* +* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or +* upper case 'Z'. +* + IF (INTA.GE.129 .AND. INTA.LE.137 .OR. + + INTA.GE.145 .AND. INTA.LE.153 .OR. + + INTA.GE.162 .AND. INTA.LE.169) INTA = INTA + 64 + IF (INTB.GE.129 .AND. INTB.LE.137 .OR. + + INTB.GE.145 .AND. INTB.LE.153 .OR. + + INTB.GE.162 .AND. INTB.LE.169) INTB = INTB + 64 +* + ELSE IF (ZCODE.EQ.218 .OR. ZCODE.EQ.250) THEN +* +* ASCII is assumed, on Prime machines - ZCODE is the ASCII code +* plus 128 of either lower or upper case 'Z'. +* + IF (INTA.GE.225 .AND. INTA.LE.250) INTA = INTA - 32 + IF (INTB.GE.225 .AND. INTB.LE.250) INTB = INTB - 32 + END IF + LSAME = INTA .EQ. INTB +* +* RETURN +* +* End of LSAME +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/sasum.f b/fortran_implementation/external_libraries/BLAS/SRC/sasum.f new file mode 100644 index 0000000..95e99b3 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/sasum.f @@ -0,0 +1,132 @@ +*> \brief \b SASUM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* REAL FUNCTION SASUM(N,SX,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,N +* .. +* .. Array Arguments .. +* REAL SX(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SASUM takes the sum of the absolute values. +*> uses unrolled loops for increment equal to one. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] SX +*> \verbatim +*> SX is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of SX +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup asum +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, linpack, 3/11/78. +*> modified 3/93 to return if incx .le. 0. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + REAL FUNCTION SASUM(N,SX,INCX) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,N +* .. +* .. Array Arguments .. + REAL SX(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + REAL STEMP + INTEGER I,M,MP1,NINCX +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS,MOD +* .. + SASUM = 0.0e0 + STEMP = 0.0e0 + IF (N.LE.0 .OR. INCX.LE.0) RETURN + IF (INCX.EQ.1) THEN +* code for increment equal to 1 +* +* +* clean-up loop +* + M = MOD(N,6) + IF (M.NE.0) THEN + DO I = 1,M + STEMP = STEMP + ABS(SX(I)) + END DO + IF (N.LT.6) THEN + SASUM = STEMP + RETURN + END IF + END IF + MP1 = M + 1 + DO I = MP1,N,6 + STEMP = STEMP + ABS(SX(I)) + ABS(SX(I+1)) + + $ ABS(SX(I+2)) + ABS(SX(I+3)) + + $ ABS(SX(I+4)) + ABS(SX(I+5)) + END DO + ELSE +* +* code for increment not equal to 1 +* + NINCX = N*INCX + DO I = 1,NINCX,INCX + STEMP = STEMP + ABS(SX(I)) + END DO + END IF + SASUM = STEMP + RETURN +* +* End of SASUM +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/saxpy.f b/fortran_implementation/external_libraries/BLAS/SRC/saxpy.f new file mode 100644 index 0000000..f33a358 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/saxpy.f @@ -0,0 +1,152 @@ +*> \brief \b SAXPY +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SAXPY(N,SA,SX,INCX,SY,INCY) +* +* .. Scalar Arguments .. +* REAL SA +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* REAL SX(*),SY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SAXPY constant times a vector plus a vector. +*> uses unrolled loops for increments equal to one. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] SA +*> \verbatim +*> SA is REAL +*> On entry, SA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] SX +*> \verbatim +*> SX is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of SX +*> \endverbatim +*> +*> \param[in,out] SY +*> \verbatim +*> SY is REAL array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of SY +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup axpy +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, linpack, 3/11/78. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE SAXPY(N,SA,SX,INCX,SY,INCY) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + REAL SA + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + REAL SX(*),SY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,IX,IY,M,MP1 +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. + IF (N.LE.0) RETURN + IF (SA.EQ.0.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* +* +* clean-up loop +* + M = MOD(N,4) + IF (M.NE.0) THEN + DO I = 1,M + SY(I) = SY(I) + SA*SX(I) + END DO + END IF + IF (N.LT.4) RETURN + MP1 = M + 1 + DO I = MP1,N,4 + SY(I) = SY(I) + SA*SX(I) + SY(I+1) = SY(I+1) + SA*SX(I+1) + SY(I+2) = SY(I+2) + SA*SX(I+2) + SY(I+3) = SY(I+3) + SA*SX(I+3) + END DO + ELSE +* +* code for unequal increments or equal increments +* not equal to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + SY(IY) = SY(IY) + SA*SX(IX) + IX = IX + INCX + IY = IY + INCY + END DO + END IF + RETURN +* +* End of SAXPY +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/scabs1.f b/fortran_implementation/external_libraries/BLAS/SRC/scabs1.f new file mode 100644 index 0000000..6fed426 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/scabs1.f @@ -0,0 +1,65 @@ +*> \brief \b SCABS1 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* REAL FUNCTION SCABS1(Z) +* +* .. Scalar Arguments .. +* COMPLEX Z +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SCABS1 computes |Re(.)| + |Im(.)| of a complex number +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] Z +*> \verbatim +*> Z is COMPLEX +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup abs1 +* +* ===================================================================== + REAL FUNCTION SCABS1(Z) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX Z +* .. +* +* ===================================================================== +* +* .. Intrinsic Functions .. + INTRINSIC ABS,AIMAG,REAL +* .. + SCABS1 = ABS(REAL(Z)) + ABS(AIMAG(Z)) + RETURN +* +* End of SCABS1 +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/scasum.f b/fortran_implementation/external_libraries/BLAS/SRC/scasum.f new file mode 100644 index 0000000..a562746 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/scasum.f @@ -0,0 +1,117 @@ +*> \brief \b SCASUM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* REAL FUNCTION SCASUM(N,CX,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,N +* .. +* .. Array Arguments .. +* COMPLEX CX(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SCASUM takes the sum of the (|Re(.)| + |Im(.)|)'s of a complex vector and +*> returns a single precision result. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in,out] CX +*> \verbatim +*> CX is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of SX +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup asum +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, linpack, 3/11/78. +*> modified 3/93 to return if incx .le. 0. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + REAL FUNCTION SCASUM(N,CX,INCX) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,N +* .. +* .. Array Arguments .. + COMPLEX CX(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + REAL STEMP + INTEGER I,NINCX +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS,AIMAG,REAL +* .. + SCASUM = 0.0e0 + STEMP = 0.0e0 + IF (N.LE.0 .OR. INCX.LE.0) RETURN + IF (INCX.EQ.1) THEN +* +* code for increment equal to 1 +* + DO I = 1,N + STEMP = STEMP + ABS(REAL(CX(I))) + ABS(AIMAG(CX(I))) + END DO + ELSE +* +* code for increment not equal to 1 +* + NINCX = N*INCX + DO I = 1,NINCX,INCX + STEMP = STEMP + ABS(REAL(CX(I))) + ABS(AIMAG(CX(I))) + END DO + END IF + SCASUM = STEMP + RETURN +* +* End of SCASUM +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/scnrm2.f90 b/fortran_implementation/external_libraries/BLAS/SRC/scnrm2.f90 new file mode 100644 index 0000000..6eb2c9d --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/scnrm2.f90 @@ -0,0 +1,209 @@ +!> \brief \b SCNRM2 +! +! =========== DOCUMENTATION =========== +! +! Online html documentation available at +! http://www.netlib.org/lapack/explore-html/ +! +! Definition: +! =========== +! +! REAL FUNCTION SCNRM2(N,X,INCX) +! +! .. Scalar Arguments .. +! INTEGER INCX,N +! .. +! .. Array Arguments .. +! COMPLEX X(*) +! .. +! +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> SCNRM2 returns the euclidean norm of a vector via the function +!> name, so that +!> +!> SCNRM2 := sqrt( x**H*x ) +!> \endverbatim +! +! Arguments: +! ========== +! +!> \param[in] N +!> \verbatim +!> N is INTEGER +!> number of elements in input vector(s) +!> \endverbatim +!> +!> \param[in] X +!> \verbatim +!> X is COMPLEX array, dimension (N) +!> complex vector with N elements +!> \endverbatim +!> +!> \param[in] INCX +!> \verbatim +!> INCX is INTEGER, storage spacing between elements of X +!> If INCX > 0, X(1+(i-1)*INCX) = x(i) for 1 <= i <= n +!> If INCX < 0, X(1-(n-i)*INCX) = x(i) for 1 <= i <= n +!> If INCX = 0, x isn't a vector so there is no need to call +!> this subroutine. If you call it anyway, it will count x(1) +!> in the vector norm N times. +!> \endverbatim +! +! Authors: +! ======== +! +!> \author Edward Anderson, Lockheed Martin +! +!> \date August 2016 +! +!> \ingroup nrm2 +! +!> \par Contributors: +! ================== +!> +!> Weslley Pereira, University of Colorado Denver, USA +! +!> \par Further Details: +! ===================== +!> +!> \verbatim +!> +!> Anderson E. (2017) +!> Algorithm 978: Safe Scaling in the Level 1 BLAS +!> ACM Trans Math Softw 44:1--28 +!> https://doi.org/10.1145/3061665 +!> +!> Blue, James L. (1978) +!> A Portable Fortran Program to Find the Euclidean Norm of a Vector +!> ACM Trans Math Softw 4:15--23 +!> https://doi.org/10.1145/355769.355771 +!> +!> \endverbatim +!> +! ===================================================================== +function SCNRM2( n, x, incx ) + integer, parameter :: wp = kind(1.e0) + real(wp) :: SCNRM2 +! +! -- Reference BLAS level1 routine (version 3.9.1) -- +! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +! March 2021 +! +! .. Constants .. + real(wp), parameter :: zero = 0.0_wp + real(wp), parameter :: one = 1.0_wp + real(wp), parameter :: maxN = huge(0.0_wp) +! .. +! .. Blue's scaling constants .. + real(wp), parameter :: tsml = real(radix(0._wp), wp)**ceiling( & + (minexponent(0._wp) - 1) * 0.5_wp) + real(wp), parameter :: tbig = real(radix(0._wp), wp)**floor( & + (maxexponent(0._wp) - digits(0._wp) + 1) * 0.5_wp) + real(wp), parameter :: ssml = real(radix(0._wp), wp)**( - floor( & + (minexponent(0._wp) - digits(0._wp)) * 0.5_wp)) + real(wp), parameter :: sbig = real(radix(0._wp), wp)**( - ceiling( & + (maxexponent(0._wp) + digits(0._wp) - 1) * 0.5_wp)) +! .. +! .. Scalar Arguments .. + integer :: incx, n +! .. +! .. Array Arguments .. + complex(wp) :: x(*) +! .. +! .. Local Scalars .. + integer :: i, ix + logical :: notbig + real(wp) :: abig, amed, asml, ax, scl, sumsq, ymax, ymin +! +! Quick return if possible +! + SCNRM2 = zero + if( n <= 0 ) return +! + scl = one + sumsq = zero +! +! Compute the sum of squares in 3 accumulators: +! abig -- sums of squares scaled down to avoid overflow +! asml -- sums of squares scaled up to avoid underflow +! amed -- sums of squares that do not require scaling +! The thresholds and multipliers are +! tbig -- values bigger than this are scaled down by sbig +! tsml -- values smaller than this are scaled up by ssml +! + notbig = .true. + asml = zero + amed = zero + abig = zero + ix = 1 + if( incx < 0 ) ix = 1 - (n-1)*incx + do i = 1, n + ax = abs(real(x(ix))) + if (ax > tbig) then + abig = abig + (ax*sbig)**2 + notbig = .false. + else if (ax < tsml) then + if (notbig) asml = asml + (ax*ssml)**2 + else + amed = amed + ax**2 + end if + ax = abs(aimag(x(ix))) + if (ax > tbig) then + abig = abig + (ax*sbig)**2 + notbig = .false. + else if (ax < tsml) then + if (notbig) asml = asml + (ax*ssml)**2 + else + amed = amed + ax**2 + end if + ix = ix + incx + end do +! +! Combine abig and amed or amed and asml if more than one +! accumulator was used. +! + if (abig > zero) then +! +! Combine abig and amed if abig > 0. +! + if ( (amed > zero) .or. (amed > maxN) .or. (amed /= amed) ) then + abig = abig + (amed*sbig)*sbig + end if + scl = one / sbig + sumsq = abig + else if (asml > zero) then +! +! Combine amed and asml if asml > 0. +! + if ( (amed > zero) .or. (amed > maxN) .or. (amed /= amed) ) then + amed = sqrt(amed) + asml = sqrt(asml) / ssml + if (asml > amed) then + ymin = amed + ymax = asml + else + ymin = asml + ymax = amed + end if + scl = one + sumsq = ymax**2*( one + (ymin/ymax)**2 ) + else + scl = one / ssml + sumsq = asml + end if + else +! +! Otherwise all values are mid-range +! + scl = one + sumsq = amed + end if + SCNRM2 = scl*sqrt( sumsq ) + return +end function diff --git a/fortran_implementation/external_libraries/BLAS/SRC/scopy.f b/fortran_implementation/external_libraries/BLAS/SRC/scopy.f new file mode 100644 index 0000000..29e0c74 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/scopy.f @@ -0,0 +1,146 @@ +*> \brief \b SCOPY +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SCOPY(N,SX,INCX,SY,INCY) +* +* .. Scalar Arguments .. +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* REAL SX(*),SY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SCOPY copies a vector, x, to a vector, y. +*> uses unrolled loops for increments equal to 1. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] SX +*> \verbatim +*> SX is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of SX +*> \endverbatim +*> +*> \param[out] SY +*> \verbatim +*> SY is REAL array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of SY +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup copy +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, linpack, 3/11/78. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE SCOPY(N,SX,INCX,SY,INCY) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + REAL SX(*),SY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,IX,IY,M,MP1 +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* +* +* clean-up loop +* + M = MOD(N,7) + IF (M.NE.0) THEN + DO I = 1,M + SY(I) = SX(I) + END DO + IF (N.LT.7) RETURN + END IF + MP1 = M + 1 + DO I = MP1,N,7 + SY(I) = SX(I) + SY(I+1) = SX(I+1) + SY(I+2) = SX(I+2) + SY(I+3) = SX(I+3) + SY(I+4) = SX(I+4) + SY(I+5) = SX(I+5) + SY(I+6) = SX(I+6) + END DO + ELSE +* +* code for unequal increments or equal increments +* not equal to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + SY(IY) = SX(IX) + IX = IX + INCX + IY = IY + INCY + END DO + END IF + RETURN +* +* End of SCOPY +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/sdot.f b/fortran_implementation/external_libraries/BLAS/SRC/sdot.f new file mode 100644 index 0000000..da8574c --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/sdot.f @@ -0,0 +1,148 @@ +*> \brief \b SDOT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* REAL FUNCTION SDOT(N,SX,INCX,SY,INCY) +* +* .. Scalar Arguments .. +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* REAL SX(*),SY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SDOT forms the dot product of two vectors. +*> uses unrolled loops for increments equal to one. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] SX +*> \verbatim +*> SX is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of SX +*> \endverbatim +*> +*> \param[in] SY +*> \verbatim +*> SY is REAL array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of SY +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup dot +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, linpack, 3/11/78. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + REAL FUNCTION SDOT(N,SX,INCX,SY,INCY) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + REAL SX(*),SY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + REAL STEMP + INTEGER I,IX,IY,M,MP1 +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. + STEMP = 0.0e0 + SDOT = 0.0e0 + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* +* +* clean-up loop +* + M = MOD(N,5) + IF (M.NE.0) THEN + DO I = 1,M + STEMP = STEMP + SX(I)*SY(I) + END DO + IF (N.LT.5) THEN + SDOT=STEMP + RETURN + END IF + END IF + MP1 = M + 1 + DO I = MP1,N,5 + STEMP = STEMP + SX(I)*SY(I) + SX(I+1)*SY(I+1) + + $ SX(I+2)*SY(I+2) + SX(I+3)*SY(I+3) + SX(I+4)*SY(I+4) + END DO + ELSE +* +* code for unequal increments or equal increments +* not equal to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + STEMP = STEMP + SX(IX)*SY(IY) + IX = IX + INCX + IY = IY + INCY + END DO + END IF + SDOT = STEMP + RETURN +* +* End of SDOT +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/sdsdot.f b/fortran_implementation/external_libraries/BLAS/SRC/sdsdot.f new file mode 100644 index 0000000..329a716 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/sdsdot.f @@ -0,0 +1,163 @@ +*> \brief \b SDSDOT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* REAL FUNCTION SDSDOT(N,SB,SX,INCX,SY,INCY) +* +* .. Scalar Arguments .. +* REAL SB +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* REAL SX(*),SY(*) +* .. +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> Compute the inner product of two vectors with extended +*> precision accumulation. +*> +*> Returns S.P. result with dot product accumulated in D.P. +*> SDSDOT = SB + sum for I = 0 to N-1 of SX(LX+I*INCX)*SY(LY+I*INCY), +*> where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is +*> defined in a similar way using INCY. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] SB +*> \verbatim +*> SB is REAL +*> single precision scalar to be added to inner product +*> \endverbatim +*> +*> \param[in] SX +*> \verbatim +*> SX is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> single precision vector with N elements +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of SX +*> \endverbatim +*> +*> \param[in] SY +*> \verbatim +*> SY is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> single precision vector with N elements +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of SY +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Lawson, C. L., (JPL), Hanson, R. J., (SNLA), +*> \author Kincaid, D. R., (U. of Texas), Krogh, F. T., (JPL) +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup dot +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> REFERENCES +*> +*> C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. +*> Krogh, Basic linear algebra subprograms for Fortran +*> usage, Algorithm No. 539, Transactions on Mathematical +*> Software 5, 3 (September 1979), pp. 308-323. +*> +*> REVISION HISTORY (YYMMDD) +*> +*> 791001 DATE WRITTEN +*> 890531 Changed all specific intrinsics to generic. (WRB) +*> 890831 Modified array declarations. (WRB) +*> 890831 REVISION DATE from Version 3.2 +*> 891214 Prologue converted to Version 4.0 format. (BAB) +*> 920310 Corrected definition of LX in DESCRIPTION. (WRB) +*> 920501 Reformatted the REFERENCES section. (WRB) +*> 070118 Reformat to LAPACK coding style +*> \endverbatim +*> +* ===================================================================== + REAL FUNCTION SDSDOT(N,SB,SX,INCX,SY,INCY) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + REAL SB + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + REAL SX(*),SY(*) +* .. Local Scalars .. + DOUBLE PRECISION DSDOT + INTEGER I,KX,KY,NS +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE +* .. + DSDOT = SB + IF (N.LE.0) THEN + SDSDOT = REAL(DSDOT) + RETURN + END IF + IF (INCX.EQ.INCY .AND. INCX.GT.0) THEN +* +* Code for equal and positive increments. +* + NS = N*INCX + DO I = 1,NS,INCX + DSDOT = DSDOT + DBLE(SX(I))*DBLE(SY(I)) + END DO + ELSE +* +* Code for unequal or nonpositive increments. +* + KX = 1 + KY = 1 + IF (INCX.LT.0) KX = 1 + (1-N)*INCX + IF (INCY.LT.0) KY = 1 + (1-N)*INCY + DO I = 1,N + DSDOT = DSDOT + DBLE(SX(KX))*DBLE(SY(KY)) + KX = KX + INCX + KY = KY + INCY + END DO + END IF + SDSDOT = REAL(DSDOT) + RETURN +* +* End of SDSDOT +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/sgbmv.f b/fortran_implementation/external_libraries/BLAS/SRC/sgbmv.f new file mode 100644 index 0000000..4888fdd --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/sgbmv.f @@ -0,0 +1,370 @@ +*> \brief \b SGBMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* .. Scalar Arguments .. +* REAL ALPHA,BETA +* INTEGER INCX,INCY,KL,KU,LDA,M,N +* CHARACTER TRANS +* .. +* .. Array Arguments .. +* REAL A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SGBMV performs one of the matrix-vector operations +*> +*> y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, +*> +*> where alpha and beta are scalars, x and y are vectors and A is an +*> m by n band matrix, with kl sub-diagonals and ku super-diagonals. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the operation to be performed as +*> follows: +*> +*> TRANS = 'N' or 'n' y := alpha*A*x + beta*y. +*> +*> TRANS = 'T' or 't' y := alpha*A**T*x + beta*y. +*> +*> TRANS = 'C' or 'c' y := alpha*A**T*x + beta*y. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix A. +*> M must be at least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] KL +*> \verbatim +*> KL is INTEGER +*> On entry, KL specifies the number of sub-diagonals of the +*> matrix A. KL must satisfy 0 .le. KL. +*> \endverbatim +*> +*> \param[in] KU +*> \verbatim +*> KU is INTEGER +*> On entry, KU specifies the number of super-diagonals of the +*> matrix A. KU must satisfy 0 .le. KU. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is REAL +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is REAL array, dimension ( LDA, N ) +*> Before entry, the leading ( kl + ku + 1 ) by n part of the +*> array A must contain the matrix of coefficients, supplied +*> column by column, with the leading diagonal of the matrix in +*> row ( ku + 1 ) of the array, the first super-diagonal +*> starting at position 2 in row ku, the first sub-diagonal +*> starting at position 1 in row ( ku + 2 ), and so on. +*> Elements in the array A that do not correspond to elements +*> in the band matrix (such as the top left ku by ku triangle) +*> are not referenced. +*> The following program segment will transfer a band matrix +*> from conventional full matrix storage to band storage: +*> +*> DO 20, J = 1, N +*> K = KU + 1 - J +*> DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL ) +*> A( K + I, J ) = matrix( I, J ) +*> 10 CONTINUE +*> 20 CONTINUE +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> ( kl + ku + 1 ). +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is REAL array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' +*> and at least +*> ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. +*> Before entry, the incremented array X must contain the +*> vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is REAL +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then Y need not be set on input. +*> \endverbatim +*> +*> \param[in,out] Y +*> \verbatim +*> Y is REAL array, dimension at least +*> ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' +*> and at least +*> ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. +*> Before entry, the incremented array Y must contain the +*> vector y. On exit, Y is overwritten by the updated vector y. +*> If either m or n is zero, then Y not referenced and the function +*> performs a quick return. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> Y. INCY must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup gbmv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> The vector and matrix arguments are not referenced when N = 0, or M = 0 +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE SGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX, + + BETA,Y,INCY) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + REAL ALPHA,BETA + INTEGER INCX,INCY,KL,KU,LDA,M,N + CHARACTER TRANS +* .. +* .. Array Arguments .. + REAL A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE,ZERO + PARAMETER (ONE=1.0E+0,ZERO=0.0E+0) +* .. +* .. Local Scalars .. + REAL TEMP + INTEGER I,INFO,IX,IY,J,JX,JY,K,KUP1,KX,KY,LENX,LENY +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX,MIN +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. + + .NOT.LSAME(TRANS,'C')) THEN + INFO = 1 + ELSE IF (M.LT.0) THEN + INFO = 2 + ELSE IF (N.LT.0) THEN + INFO = 3 + ELSE IF (KL.LT.0) THEN + INFO = 4 + ELSE IF (KU.LT.0) THEN + INFO = 5 + ELSE IF (LDA.LT. (KL+KU+1)) THEN + INFO = 8 + ELSE IF (INCX.EQ.0) THEN + INFO = 10 + ELSE IF (INCY.EQ.0) THEN + INFO = 13 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('SGBMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. + + ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN +* +* Set LENX and LENY, the lengths of the vectors x and y, and set +* up the start points in X and Y. +* + IF (LSAME(TRANS,'N')) THEN + LENX = N + LENY = M + ELSE + LENX = M + LENY = N + END IF + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (LENX-1)*INCX + END IF + IF (INCY.GT.0) THEN + KY = 1 + ELSE + KY = 1 - (LENY-1)*INCY + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through the band part of A. +* +* First form y := beta*y. +* + IF (BETA.NE.ONE) THEN + IF (INCY.EQ.1) THEN + IF (BETA.EQ.ZERO) THEN + DO 10 I = 1,LENY + Y(I) = ZERO + 10 CONTINUE + ELSE + DO 20 I = 1,LENY + Y(I) = BETA*Y(I) + 20 CONTINUE + END IF + ELSE + IY = KY + IF (BETA.EQ.ZERO) THEN + DO 30 I = 1,LENY + Y(IY) = ZERO + IY = IY + INCY + 30 CONTINUE + ELSE + DO 40 I = 1,LENY + Y(IY) = BETA*Y(IY) + IY = IY + INCY + 40 CONTINUE + END IF + END IF + END IF + IF (ALPHA.EQ.ZERO) RETURN + KUP1 = KU + 1 + IF (LSAME(TRANS,'N')) THEN +* +* Form y := alpha*A*x + y. +* + JX = KX + IF (INCY.EQ.1) THEN + DO 60 J = 1,N + TEMP = ALPHA*X(JX) + K = KUP1 - J + DO 50 I = MAX(1,J-KU),MIN(M,J+KL) + Y(I) = Y(I) + TEMP*A(K+I,J) + 50 CONTINUE + JX = JX + INCX + 60 CONTINUE + ELSE + DO 80 J = 1,N + TEMP = ALPHA*X(JX) + IY = KY + K = KUP1 - J + DO 70 I = MAX(1,J-KU),MIN(M,J+KL) + Y(IY) = Y(IY) + TEMP*A(K+I,J) + IY = IY + INCY + 70 CONTINUE + JX = JX + INCX + IF (J.GT.KU) KY = KY + INCY + 80 CONTINUE + END IF + ELSE +* +* Form y := alpha*A**T*x + y. +* + JY = KY + IF (INCX.EQ.1) THEN + DO 100 J = 1,N + TEMP = ZERO + K = KUP1 - J + DO 90 I = MAX(1,J-KU),MIN(M,J+KL) + TEMP = TEMP + A(K+I,J)*X(I) + 90 CONTINUE + Y(JY) = Y(JY) + ALPHA*TEMP + JY = JY + INCY + 100 CONTINUE + ELSE + DO 120 J = 1,N + TEMP = ZERO + IX = KX + K = KUP1 - J + DO 110 I = MAX(1,J-KU),MIN(M,J+KL) + TEMP = TEMP + A(K+I,J)*X(IX) + IX = IX + INCX + 110 CONTINUE + Y(JY) = Y(JY) + ALPHA*TEMP + JY = JY + INCY + IF (J.GT.KU) KX = KX + INCX + 120 CONTINUE + END IF + END IF +* + RETURN +* +* End of SGBMV +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/sgemm.f b/fortran_implementation/external_libraries/BLAS/SRC/sgemm.f new file mode 100644 index 0000000..3e31add --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/sgemm.f @@ -0,0 +1,380 @@ +*> \brief \b SGEMM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* .. Scalar Arguments .. +* REAL ALPHA,BETA +* INTEGER K,LDA,LDB,LDC,M,N +* CHARACTER TRANSA,TRANSB +* .. +* .. Array Arguments .. +* REAL A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SGEMM performs one of the matrix-matrix operations +*> +*> C := alpha*op( A )*op( B ) + beta*C, +*> +*> where op( X ) is one of +*> +*> op( X ) = X or op( X ) = X**T, +*> +*> alpha and beta are scalars, and A, B and C are matrices, with op( A ) +*> an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANSA +*> \verbatim +*> TRANSA is CHARACTER*1 +*> On entry, TRANSA specifies the form of op( A ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSA = 'N' or 'n', op( A ) = A. +*> +*> TRANSA = 'T' or 't', op( A ) = A**T. +*> +*> TRANSA = 'C' or 'c', op( A ) = A**T. +*> \endverbatim +*> +*> \param[in] TRANSB +*> \verbatim +*> TRANSB is CHARACTER*1 +*> On entry, TRANSB specifies the form of op( B ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSB = 'N' or 'n', op( B ) = B. +*> +*> TRANSB = 'T' or 't', op( B ) = B**T. +*> +*> TRANSB = 'C' or 'c', op( B ) = B**T. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix +*> op( A ) and of the matrix C. M must be at least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of the matrix +*> op( B ) and the number of columns of the matrix C. N must be +*> at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry, K specifies the number of columns of the matrix +*> op( A ) and the number of rows of the matrix op( B ). K must +*> be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is REAL +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is REAL array, dimension ( LDA, ka ), where ka is +*> k when TRANSA = 'N' or 'n', and is m otherwise. +*> Before entry with TRANSA = 'N' or 'n', the leading m by k +*> part of the array A must contain the matrix A, otherwise +*> the leading k by m part of the array A must contain the +*> matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When TRANSA = 'N' or 'n' then +*> LDA must be at least max( 1, m ), otherwise LDA must be at +*> least max( 1, k ). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is REAL array, dimension ( LDB, kb ), where kb is +*> n when TRANSB = 'N' or 'n', and is k otherwise. +*> Before entry with TRANSB = 'N' or 'n', the leading k by n +*> part of the array B must contain the matrix B, otherwise +*> the leading n by k part of the array B must contain the +*> matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. When TRANSB = 'N' or 'n' then +*> LDB must be at least max( 1, k ), otherwise LDB must be at +*> least max( 1, n ). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is REAL +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then C need not be set on input. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is REAL array, dimension ( LDC, N ) +*> Before entry, the leading m by n part of the array C must +*> contain the matrix C, except when beta is zero, in which +*> case C need not be set on entry. +*> On exit, the array C is overwritten by the m by n matrix +*> ( alpha*op( A )*op( B ) + beta*C ). +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> On entry, LDC specifies the first dimension of C as declared +*> in the calling (sub) program. LDC must be at least +*> max( 1, m ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup gemm +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> -- Written on 8-February-1989. +*> Jack Dongarra, Argonne National Laboratory. +*> Iain Duff, AERE Harwell. +*> Jeremy Du Croz, Numerical Algorithms Group Ltd. +*> Sven Hammarling, Numerical Algorithms Group Ltd. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE SGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB, + + BETA,C,LDC) +* +* -- Reference BLAS level3 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + REAL ALPHA,BETA + INTEGER K,LDA,LDB,LDC,M,N + CHARACTER TRANSA,TRANSB +* .. +* .. Array Arguments .. + REAL A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + REAL TEMP + INTEGER I,INFO,J,L,NROWA,NROWB + LOGICAL NOTA,NOTB +* .. +* .. Parameters .. + REAL ONE,ZERO + PARAMETER (ONE=1.0E+0,ZERO=0.0E+0) +* .. +* +* Set NOTA and NOTB as true if A and B respectively are not +* transposed and set NROWA and NROWB as the number of rows of A +* and B respectively. +* + NOTA = LSAME(TRANSA,'N') + NOTB = LSAME(TRANSB,'N') + IF (NOTA) THEN + NROWA = M + ELSE + NROWA = K + END IF + IF (NOTB) THEN + NROWB = K + ELSE + NROWB = N + END IF +* +* Test the input parameters. +* + INFO = 0 + IF ((.NOT.NOTA) .AND. (.NOT.LSAME(TRANSA,'C')) .AND. + + (.NOT.LSAME(TRANSA,'T'))) THEN + INFO = 1 + ELSE IF ((.NOT.NOTB) .AND. (.NOT.LSAME(TRANSB,'C')) .AND. + + (.NOT.LSAME(TRANSB,'T'))) THEN + INFO = 2 + ELSE IF (M.LT.0) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (K.LT.0) THEN + INFO = 5 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 8 + ELSE IF (LDB.LT.MAX(1,NROWB)) THEN + INFO = 10 + ELSE IF (LDC.LT.MAX(1,M)) THEN + INFO = 13 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('SGEMM ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. + + (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN +* +* And if alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + IF (BETA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,M + C(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1,N + DO 30 I = 1,M + C(I,J) = BETA*C(I,J) + 30 CONTINUE + 40 CONTINUE + END IF + RETURN + END IF +* +* Start the operations. +* + IF (NOTB) THEN + IF (NOTA) THEN +* +* Form C := alpha*A*B + beta*C. +* + DO 90 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 50 I = 1,M + C(I,J) = ZERO + 50 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 60 I = 1,M + C(I,J) = BETA*C(I,J) + 60 CONTINUE + END IF + DO 80 L = 1,K + TEMP = ALPHA*B(L,J) + DO 70 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + ELSE +* +* Form C := alpha*A**T*B + beta*C +* + DO 120 J = 1,N + DO 110 I = 1,M + TEMP = ZERO + DO 100 L = 1,K + TEMP = TEMP + A(L,I)*B(L,J) + 100 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 110 CONTINUE + 120 CONTINUE + END IF + ELSE + IF (NOTA) THEN +* +* Form C := alpha*A*B**T + beta*C +* + DO 170 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 130 I = 1,M + C(I,J) = ZERO + 130 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 140 I = 1,M + C(I,J) = BETA*C(I,J) + 140 CONTINUE + END IF + DO 160 L = 1,K + TEMP = ALPHA*B(J,L) + DO 150 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE + ELSE +* +* Form C := alpha*A**T*B**T + beta*C +* + DO 200 J = 1,N + DO 190 I = 1,M + TEMP = ZERO + DO 180 L = 1,K + TEMP = TEMP + A(L,I)*B(J,L) + 180 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 190 CONTINUE + 200 CONTINUE + END IF + END IF +* + RETURN +* +* End of SGEMM +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/sgemmtr.f b/fortran_implementation/external_libraries/BLAS/SRC/sgemmtr.f new file mode 100644 index 0000000..257ff8b --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/sgemmtr.f @@ -0,0 +1,431 @@ +*> \brief \b SGEMMTR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SGEMMTR(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB,BETA, +* C,LDC) +* +* .. Scalar Arguments .. +* REAL ALPHA,BETA +* INTEGER K,LDA,LDB,LDC,N +* CHARACTER TRANSA,TRANSB, UPLO +* .. +* .. Array Arguments .. +* REAL A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SGEMMTR performs one of the matrix-matrix operations +*> +*> C := alpha*op( A )*op( B ) + beta*C, +*> +*> where op( X ) is one of +*> +*> op( X ) = X or op( X ) = X**T, +*> +*> alpha and beta are scalars, and A, B and C are matrices, with op( A ) +*> an n by k matrix, op( B ) a k by n matrix and C an n by n matrix. +*> Thereby, the routine only accesses and updates the upper or lower +*> triangular part of the result matrix C. This behaviour can be used if +*> the resulting matrix C is known to be symmetric. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the lower or the upper +*> triangular part of C is access and updated. +*> +*> UPLO = 'L' or 'l', the lower triangular part of C is used. +*> +*> UPLO = 'U' or 'u', the upper triangular part of C is used. +*> \endverbatim +* +*> \param[in] TRANSA +*> \verbatim +*> TRANSA is CHARACTER*1 +*> On entry, TRANSA specifies the form of op( A ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSA = 'N' or 'n', op( A ) = A. +*> +*> TRANSA = 'T' or 't', op( A ) = A**T. +*> +*> TRANSA = 'C' or 'c', op( A ) = A**T. +*> \endverbatim +*> +*> \param[in] TRANSB +*> \verbatim +*> TRANSB is CHARACTER*1 +*> On entry, TRANSB specifies the form of op( B ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSB = 'N' or 'n', op( B ) = B. +*> +*> TRANSB = 'T' or 't', op( B ) = B**T. +*> +*> TRANSB = 'C' or 'c', op( B ) = B**T. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of rows and columns of +*> the matrix C, the number of columns of op(B) and the number +*> of rows of op(A). N must be at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry, K specifies the number of columns of the matrix +*> op( A ) and the number of rows of the matrix op( B ). K must +*> be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is REAL. +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is REAL array, dimension ( LDA, ka ), where ka is +*> k when TRANSA = 'N' or 'n', and is n otherwise. +*> Before entry with TRANSA = 'N' or 'n', the leading n by k +*> part of the array A must contain the matrix A, otherwise +*> the leading k by m part of the array A must contain the +*> matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When TRANSA = 'N' or 'n' then +*> LDA must be at least max( 1, n ), otherwise LDA must be at +*> least max( 1, k ). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is REAL array, dimension ( LDB, kb ), where kb is +*> n when TRANSB = 'N' or 'n', and is k otherwise. +*> Before entry with TRANSB = 'N' or 'n', the leading k by n +*> part of the array B must contain the matrix B, otherwise +*> the leading n by k part of the array B must contain the +*> matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. When TRANSB = 'N' or 'n' then +*> LDB must be at least max( 1, k ), otherwise LDB must be at +*> least max( 1, n ). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is REAL. +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then C need not be set on input. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is REAL array, dimension ( LDC, N ) +*> Before entry, the leading n by n part of the array C must +*> contain the matrix C, except when beta is zero, in which +*> case C need not be set on entry. +*> On exit, the upper or lower triangular part of the matrix +*> C is overwritten by the n by n matrix +*> ( alpha*op( A )*op( B ) + beta*C ). +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> On entry, LDC specifies the first dimension of C as declared +*> in the calling (sub) program. LDC must be at least +*> max( 1, n ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Martin Koehler +* +*> \ingroup gemmtr +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> -- Written on 19-July-2023. +*> Martin Koehler, MPI Magdeburg +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE SGEMMTR(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB, + + BETA,C,LDC) + IMPLICIT NONE +* +* -- Reference BLAS level3 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + REAL ALPHA,BETA + INTEGER K,LDA,LDB,LDC,N + CHARACTER TRANSA,TRANSB,UPLO +* .. +* .. Array Arguments .. + REAL A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + REAL TEMP + INTEGER I,INFO,J,L,NROWA,NROWB, ISTART, ISTOP + LOGICAL NOTA,NOTB, UPPER +* .. +* .. Parameters .. + REAL ONE,ZERO + PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) +* .. +* +* Set NOTA and NOTB as true if A and B respectively are not +* transposed and set NROWA and NROWB as the number of rows of A +* and B respectively. +* + NOTA = LSAME(TRANSA,'N') + NOTB = LSAME(TRANSB,'N') + IF (NOTA) THEN + NROWA = N + ELSE + NROWA = K + END IF + IF (NOTB) THEN + NROWB = K + ELSE + NROWB = N + END IF + UPPER = LSAME(UPLO, 'U') +* +* Test the input parameters. +* + INFO = 0 + IF ((.NOT. UPPER) .AND. (.NOT. LSAME(UPLO, 'L'))) THEN + INFO = 1 + ELSE IF ((.NOT.NOTA) .AND. (.NOT.LSAME(TRANSA,'C')) .AND. + + (.NOT.LSAME(TRANSA,'T'))) THEN + INFO = 2 + ELSE IF ((.NOT.NOTB) .AND. (.NOT.LSAME(TRANSB,'C')) .AND. + + (.NOT.LSAME(TRANSB,'T'))) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (K.LT.0) THEN + INFO = 5 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 8 + ELSE IF (LDB.LT.MAX(1,NROWB)) THEN + INFO = 10 + ELSE IF (LDC.LT.MAX(1,N)) THEN + INFO = 13 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('SGEMMTR',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (N.EQ.0) RETURN +* +* And if alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + IF (BETA.EQ.ZERO) THEN + DO 20 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + DO 10 I = ISTART, ISTOP + C(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + DO 30 I = ISTART, ISTOP + C(I,J) = BETA*C(I,J) + 30 CONTINUE + 40 CONTINUE + END IF + RETURN + END IF +* +* Start the operations. +* + IF (NOTB) THEN + IF (NOTA) THEN +* +* Form C := alpha*A*B + beta*C. +* + DO 90 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + IF (BETA.EQ.ZERO) THEN + DO 50 I = ISTART, ISTOP + C(I,J) = ZERO + 50 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 60 I = ISTART, ISTOP + C(I,J) = BETA*C(I,J) + 60 CONTINUE + END IF + DO 80 L = 1,K + TEMP = ALPHA*B(L,J) + DO 70 I = ISTART, ISTOP + C(I,J) = C(I,J) + TEMP*A(I,L) + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + ELSE +* +* Form C := alpha*A**T*B + beta*C +* + DO 120 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + DO 110 I = ISTART, ISTOP + TEMP = ZERO + DO 100 L = 1,K + TEMP = TEMP + A(L,I)*B(L,J) + 100 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 110 CONTINUE + 120 CONTINUE + END IF + ELSE + IF (NOTA) THEN +* +* Form C := alpha*A*B**T + beta*C +* + DO 170 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + IF (BETA.EQ.ZERO) THEN + DO 130 I = ISTART,ISTOP + C(I,J) = ZERO + 130 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 140 I = ISTART,ISTOP + C(I,J) = BETA*C(I,J) + 140 CONTINUE + END IF + DO 160 L = 1,K + TEMP = ALPHA*B(J,L) + DO 150 I = ISTART,ISTOP + C(I,J) = C(I,J) + TEMP*A(I,L) + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE + ELSE +* +* Form C := alpha*A**T*B**T + beta*C +* + DO 200 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + DO 190 I = ISTART, ISTOP + TEMP = ZERO + DO 180 L = 1,K + TEMP = TEMP + A(L,I)*B(J,L) + 180 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 190 CONTINUE + 200 CONTINUE + END IF + END IF +* + RETURN +* +* End of SGEMMTR +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/sgemv.f b/fortran_implementation/external_libraries/BLAS/SRC/sgemv.f new file mode 100644 index 0000000..b988208 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/sgemv.f @@ -0,0 +1,329 @@ +*> \brief \b SGEMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* .. Scalar Arguments .. +* REAL ALPHA,BETA +* INTEGER INCX,INCY,LDA,M,N +* CHARACTER TRANS +* .. +* .. Array Arguments .. +* REAL A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SGEMV performs one of the matrix-vector operations +*> +*> y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, +*> +*> where alpha and beta are scalars, x and y are vectors and A is an +*> m by n matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the operation to be performed as +*> follows: +*> +*> TRANS = 'N' or 'n' y := alpha*A*x + beta*y. +*> +*> TRANS = 'T' or 't' y := alpha*A**T*x + beta*y. +*> +*> TRANS = 'C' or 'c' y := alpha*A**T*x + beta*y. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix A. +*> M must be at least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is REAL +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is REAL array, dimension ( LDA, N ) +*> Before entry, the leading m by n part of the array A must +*> contain the matrix of coefficients. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> max( 1, m ). +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is REAL array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' +*> and at least +*> ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. +*> Before entry, the incremented array X must contain the +*> vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is REAL +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then Y need not be set on input. +*> \endverbatim +*> +*> \param[in,out] Y +*> \verbatim +*> Y is REAL array, dimension at least +*> ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' +*> and at least +*> ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. +*> Before entry with BETA non-zero, the incremented array Y +*> must contain the vector y. On exit, Y is overwritten by the +*> updated vector y. +*> If either m or n is zero, then Y not referenced and the function +*> performs a quick return. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> Y. INCY must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup gemv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> The vector and matrix arguments are not referenced when N = 0, or M = 0 +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE SGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + REAL ALPHA,BETA + INTEGER INCX,INCY,LDA,M,N + CHARACTER TRANS +* .. +* .. Array Arguments .. + REAL A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE,ZERO + PARAMETER (ONE=1.0E+0,ZERO=0.0E+0) +* .. +* .. Local Scalars .. + REAL TEMP + INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY,LENX,LENY +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. + + .NOT.LSAME(TRANS,'C')) THEN + INFO = 1 + ELSE IF (M.LT.0) THEN + INFO = 2 + ELSE IF (N.LT.0) THEN + INFO = 3 + ELSE IF (LDA.LT.MAX(1,M)) THEN + INFO = 6 + ELSE IF (INCX.EQ.0) THEN + INFO = 8 + ELSE IF (INCY.EQ.0) THEN + INFO = 11 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('SGEMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. + + ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN +* +* Set LENX and LENY, the lengths of the vectors x and y, and set +* up the start points in X and Y. +* + IF (LSAME(TRANS,'N')) THEN + LENX = N + LENY = M + ELSE + LENX = M + LENY = N + END IF + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (LENX-1)*INCX + END IF + IF (INCY.GT.0) THEN + KY = 1 + ELSE + KY = 1 - (LENY-1)*INCY + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* +* First form y := beta*y. +* + IF (BETA.NE.ONE) THEN + IF (INCY.EQ.1) THEN + IF (BETA.EQ.ZERO) THEN + DO 10 I = 1,LENY + Y(I) = ZERO + 10 CONTINUE + ELSE + DO 20 I = 1,LENY + Y(I) = BETA*Y(I) + 20 CONTINUE + END IF + ELSE + IY = KY + IF (BETA.EQ.ZERO) THEN + DO 30 I = 1,LENY + Y(IY) = ZERO + IY = IY + INCY + 30 CONTINUE + ELSE + DO 40 I = 1,LENY + Y(IY) = BETA*Y(IY) + IY = IY + INCY + 40 CONTINUE + END IF + END IF + END IF + IF (ALPHA.EQ.ZERO) RETURN + IF (LSAME(TRANS,'N')) THEN +* +* Form y := alpha*A*x + y. +* + JX = KX + IF (INCY.EQ.1) THEN + DO 60 J = 1,N + TEMP = ALPHA*X(JX) + DO 50 I = 1,M + Y(I) = Y(I) + TEMP*A(I,J) + 50 CONTINUE + JX = JX + INCX + 60 CONTINUE + ELSE + DO 80 J = 1,N + TEMP = ALPHA*X(JX) + IY = KY + DO 70 I = 1,M + Y(IY) = Y(IY) + TEMP*A(I,J) + IY = IY + INCY + 70 CONTINUE + JX = JX + INCX + 80 CONTINUE + END IF + ELSE +* +* Form y := alpha*A**T*x + y. +* + JY = KY + IF (INCX.EQ.1) THEN + DO 100 J = 1,N + TEMP = ZERO + DO 90 I = 1,M + TEMP = TEMP + A(I,J)*X(I) + 90 CONTINUE + Y(JY) = Y(JY) + ALPHA*TEMP + JY = JY + INCY + 100 CONTINUE + ELSE + DO 120 J = 1,N + TEMP = ZERO + IX = KX + DO 110 I = 1,M + TEMP = TEMP + A(I,J)*X(IX) + IX = IX + INCX + 110 CONTINUE + Y(JY) = Y(JY) + ALPHA*TEMP + JY = JY + INCY + 120 CONTINUE + END IF + END IF +* + RETURN +* +* End of SGEMV +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/sger.f b/fortran_implementation/external_libraries/BLAS/SRC/sger.f new file mode 100644 index 0000000..1b8acea --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/sger.f @@ -0,0 +1,224 @@ +*> \brief \b SGER +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) +* +* .. Scalar Arguments .. +* REAL ALPHA +* INTEGER INCX,INCY,LDA,M,N +* .. +* .. Array Arguments .. +* REAL A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SGER performs the rank 1 operation +*> +*> A := alpha*x*y**T + A, +*> +*> where alpha is a scalar, x is an m element vector, y is an n element +*> vector and A is an m by n matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix A. +*> M must be at least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is REAL +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is REAL array, dimension at least +*> ( 1 + ( m - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the m +*> element vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in] Y +*> \verbatim +*> Y is REAL array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCY ) ). +*> Before entry, the incremented array Y must contain the n +*> element vector y. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> Y. INCY must not be zero. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension ( LDA, N ) +*> Before entry, the leading m by n part of the array A must +*> contain the matrix of coefficients. On exit, A is +*> overwritten by the updated matrix. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> max( 1, m ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup ger +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE SGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + REAL ALPHA + INTEGER INCX,INCY,LDA,M,N +* .. +* .. Array Arguments .. + REAL A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO + PARAMETER (ZERO=0.0E+0) +* .. +* .. Local Scalars .. + REAL TEMP + INTEGER I,INFO,IX,J,JY,KX +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (M.LT.0) THEN + INFO = 1 + ELSE IF (N.LT.0) THEN + INFO = 2 + ELSE IF (INCX.EQ.0) THEN + INFO = 5 + ELSE IF (INCY.EQ.0) THEN + INFO = 7 + ELSE IF (LDA.LT.MAX(1,M)) THEN + INFO = 9 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('SGER ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* + IF (INCY.GT.0) THEN + JY = 1 + ELSE + JY = 1 - (N-1)*INCY + END IF + IF (INCX.EQ.1) THEN + DO 20 J = 1,N + IF (Y(JY).NE.ZERO) THEN + TEMP = ALPHA*Y(JY) + DO 10 I = 1,M + A(I,J) = A(I,J) + X(I)*TEMP + 10 CONTINUE + END IF + JY = JY + INCY + 20 CONTINUE + ELSE + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (M-1)*INCX + END IF + DO 40 J = 1,N + IF (Y(JY).NE.ZERO) THEN + TEMP = ALPHA*Y(JY) + IX = KX + DO 30 I = 1,M + A(I,J) = A(I,J) + X(IX)*TEMP + IX = IX + INCX + 30 CONTINUE + END IF + JY = JY + INCY + 40 CONTINUE + END IF +* + RETURN +* +* End of SGER +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/snrm2.f90 b/fortran_implementation/external_libraries/BLAS/SRC/snrm2.f90 new file mode 100644 index 0000000..565587b --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/snrm2.f90 @@ -0,0 +1,199 @@ +!> \brief \b SNRM2 +! +! =========== DOCUMENTATION =========== +! +! Online html documentation available at +! http://www.netlib.org/lapack/explore-html/ +! +! Definition: +! =========== +! +! REAL FUNCTION SNRM2(N,X,INCX) +! +! .. Scalar Arguments .. +! INTEGER INCX,N +! .. +! .. Array Arguments .. +! REAL X(*) +! .. +! +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> SNRM2 returns the euclidean norm of a vector via the function +!> name, so that +!> +!> SNRM2 := sqrt( x'*x ). +!> \endverbatim +! +! Arguments: +! ========== +! +!> \param[in] N +!> \verbatim +!> N is INTEGER +!> number of elements in input vector(s) +!> \endverbatim +!> +!> \param[in] X +!> \verbatim +!> X is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +!> \endverbatim +!> +!> \param[in] INCX +!> \verbatim +!> INCX is INTEGER, storage spacing between elements of X +!> If INCX > 0, X(1+(i-1)*INCX) = x(i) for 1 <= i <= n +!> If INCX < 0, X(1-(n-i)*INCX) = x(i) for 1 <= i <= n +!> If INCX = 0, x isn't a vector so there is no need to call +!> this subroutine. If you call it anyway, it will count x(1) +!> in the vector norm N times. +!> \endverbatim +! +! Authors: +! ======== +! +!> \author Edward Anderson, Lockheed Martin +! +!> \date August 2016 +! +!> \ingroup nrm2 +! +!> \par Contributors: +! ================== +!> +!> Weslley Pereira, University of Colorado Denver, USA +! +!> \par Further Details: +! ===================== +!> +!> \verbatim +!> +!> Anderson E. (2017) +!> Algorithm 978: Safe Scaling in the Level 1 BLAS +!> ACM Trans Math Softw 44:1--28 +!> https://doi.org/10.1145/3061665 +!> +!> Blue, James L. (1978) +!> A Portable Fortran Program to Find the Euclidean Norm of a Vector +!> ACM Trans Math Softw 4:15--23 +!> https://doi.org/10.1145/355769.355771 +!> +!> \endverbatim +!> +! ===================================================================== +function SNRM2( n, x, incx ) + integer, parameter :: wp = kind(1.e0) + real(wp) :: SNRM2 +! +! -- Reference BLAS level1 routine (version 3.9.1) -- +! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +! March 2021 +! +! .. Constants .. + real(wp), parameter :: zero = 0.0_wp + real(wp), parameter :: one = 1.0_wp + real(wp), parameter :: maxN = huge(0.0_wp) +! .. +! .. Blue's scaling constants .. + real(wp), parameter :: tsml = real(radix(0._wp), wp)**ceiling( & + (minexponent(0._wp) - 1) * 0.5_wp) + real(wp), parameter :: tbig = real(radix(0._wp), wp)**floor( & + (maxexponent(0._wp) - digits(0._wp) + 1) * 0.5_wp) + real(wp), parameter :: ssml = real(radix(0._wp), wp)**( - floor( & + (minexponent(0._wp) - digits(0._wp)) * 0.5_wp)) + real(wp), parameter :: sbig = real(radix(0._wp), wp)**( - ceiling( & + (maxexponent(0._wp) + digits(0._wp) - 1) * 0.5_wp)) +! .. +! .. Scalar Arguments .. + integer :: incx, n +! .. +! .. Array Arguments .. + real(wp) :: x(*) +! .. +! .. Local Scalars .. + integer :: i, ix + logical :: notbig + real(wp) :: abig, amed, asml, ax, scl, sumsq, ymax, ymin +! +! Quick return if possible +! + SNRM2 = zero + if( n <= 0 ) return +! + scl = one + sumsq = zero +! +! Compute the sum of squares in 3 accumulators: +! abig -- sums of squares scaled down to avoid overflow +! asml -- sums of squares scaled up to avoid underflow +! amed -- sums of squares that do not require scaling +! The thresholds and multipliers are +! tbig -- values bigger than this are scaled down by sbig +! tsml -- values smaller than this are scaled up by ssml +! + notbig = .true. + asml = zero + amed = zero + abig = zero + ix = 1 + if( incx < 0 ) ix = 1 - (n-1)*incx + do i = 1, n + ax = abs(x(ix)) + if (ax > tbig) then + abig = abig + (ax*sbig)**2 + notbig = .false. + else if (ax < tsml) then + if (notbig) asml = asml + (ax*ssml)**2 + else + amed = amed + ax**2 + end if + ix = ix + incx + end do +! +! Combine abig and amed or amed and asml if more than one +! accumulator was used. +! + if (abig > zero) then +! +! Combine abig and amed if abig > 0. +! + if ( (amed > zero) .or. (amed > maxN) .or. (amed /= amed) ) then + abig = abig + (amed*sbig)*sbig + end if + scl = one / sbig + sumsq = abig + else if (asml > zero) then +! +! Combine amed and asml if asml > 0. +! + if ( (amed > zero) .or. (amed > maxN) .or. (amed /= amed) ) then + amed = sqrt(amed) + asml = sqrt(asml) / ssml + if (asml > amed) then + ymin = amed + ymax = asml + else + ymin = asml + ymax = amed + end if + scl = one + sumsq = ymax**2*( one + (ymin/ymax)**2 ) + else + scl = one / ssml + sumsq = asml + end if + else +! +! Otherwise all values are mid-range +! + scl = one + sumsq = amed + end if + SNRM2 = scl*sqrt( sumsq ) + return +end function diff --git a/fortran_implementation/external_libraries/BLAS/SRC/srot.f b/fortran_implementation/external_libraries/BLAS/SRC/srot.f new file mode 100644 index 0000000..ab7bc1e --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/srot.f @@ -0,0 +1,142 @@ +*> \brief \b SROT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SROT(N,SX,INCX,SY,INCY,C,S) +* +* .. Scalar Arguments .. +* REAL C,S +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* REAL SX(*),SY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> applies a plane rotation. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in,out] SX +*> \verbatim +*> SX is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of SX +*> \endverbatim +*> +*> \param[in,out] SY +*> \verbatim +*> SY is REAL array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of SY +*> \endverbatim +*> +*> \param[in] C +*> \verbatim +*> C is REAL +*> \endverbatim +*> +*> \param[in] S +*> \verbatim +*> S is REAL +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup rot +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, linpack, 3/11/78. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE SROT(N,SX,INCX,SY,INCY,C,S) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + REAL C,S + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + REAL SX(*),SY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + REAL STEMP + INTEGER I,IX,IY +* .. + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* + DO I = 1,N + STEMP = C*SX(I) + S*SY(I) + SY(I) = C*SY(I) - S*SX(I) + SX(I) = STEMP + END DO + ELSE +* +* code for unequal increments or equal increments not equal +* to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + STEMP = C*SX(IX) + S*SY(IY) + SY(IY) = C*SY(IY) - S*SX(IX) + SX(IX) = STEMP + IX = IX + INCX + IY = IY + INCY + END DO + END IF + RETURN +* +* End of SROT +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/srotg.f90 b/fortran_implementation/external_libraries/BLAS/SRC/srotg.f90 new file mode 100644 index 0000000..ce536a5 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/srotg.f90 @@ -0,0 +1,150 @@ +!> \brief \b SROTG +! +! =========== DOCUMENTATION =========== +! +! Online html documentation available at +! http://www.netlib.org/lapack/explore-html/ +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> SROTG constructs a plane rotation +!> [ c s ] [ a ] = [ r ] +!> [ -s c ] [ b ] [ 0 ] +!> satisfying c**2 + s**2 = 1. +!> +!> The computation uses the formulas +!> sigma = sgn(a) if |a| > |b| +!> = sgn(b) if |b| >= |a| +!> r = sigma*sqrt( a**2 + b**2 ) +!> c = 1; s = 0 if r = 0 +!> c = a/r; s = b/r if r != 0 +!> The subroutine also computes +!> z = s if |a| > |b|, +!> = 1/c if |b| >= |a| and c != 0 +!> = 1 if c = 0 +!> This allows c and s to be reconstructed from z as follows: +!> If z = 1, set c = 0, s = 1. +!> If |z| < 1, set c = sqrt(1 - z**2) and s = z. +!> If |z| > 1, set c = 1/z and s = sqrt( 1 - c**2). +!> +!> \endverbatim +!> +!> @see lartg, @see lartgp +! +! Arguments: +! ========== +! +!> \param[in,out] A +!> \verbatim +!> A is REAL +!> On entry, the scalar a. +!> On exit, the scalar r. +!> \endverbatim +!> +!> \param[in,out] B +!> \verbatim +!> B is REAL +!> On entry, the scalar b. +!> On exit, the scalar z. +!> \endverbatim +!> +!> \param[out] C +!> \verbatim +!> C is REAL +!> The scalar c. +!> \endverbatim +!> +!> \param[out] S +!> \verbatim +!> S is REAL +!> The scalar s. +!> \endverbatim +! +! Authors: +! ======== +! +!> \author Edward Anderson, Lockheed Martin +! +!> \par Contributors: +! ================== +!> +!> Weslley Pereira, University of Colorado Denver, USA +! +!> \ingroup rotg +! +!> \par Further Details: +! ===================== +!> +!> \verbatim +!> +!> Anderson E. (2017) +!> Algorithm 978: Safe Scaling in the Level 1 BLAS +!> ACM Trans Math Softw 44:1--28 +!> https://doi.org/10.1145/3061665 +!> +!> \endverbatim +! +! ===================================================================== +subroutine SROTG( a, b, c, s ) + integer, parameter :: wp = kind(1.e0) +! +! -- Reference BLAS level1 routine -- +! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +! +! .. Constants .. + real(wp), parameter :: zero = 0.0_wp + real(wp), parameter :: one = 1.0_wp +! .. +! .. Scaling constants .. + real(wp), parameter :: safmin = real(radix(0._wp),wp)**max( & + minexponent(0._wp)-1, & + 1-maxexponent(0._wp) & + ) + real(wp), parameter :: safmax = real(radix(0._wp),wp)**max( & + 1-minexponent(0._wp), & + maxexponent(0._wp)-1 & + ) +! .. +! .. Scalar Arguments .. + real(wp) :: a, b, c, s +! .. +! .. Local Scalars .. + real(wp) :: anorm, bnorm, scl, sigma, r, z +! .. + anorm = abs(a) + bnorm = abs(b) + if( bnorm == zero ) then + c = one + s = zero + b = zero + else if( anorm == zero ) then + c = zero + s = one + a = b + b = one + else + scl = min( safmax, max( safmin, anorm, bnorm ) ) + if( anorm > bnorm ) then + sigma = sign(one,a) + else + sigma = sign(one,b) + end if + r = sigma*( scl*sqrt((a/scl)**2 + (b/scl)**2) ) + c = a/r + s = b/r + if( anorm > bnorm ) then + z = s + else if( c /= zero ) then + z = one/c + else + z = one + end if + a = r + b = z + end if + return +end subroutine diff --git a/fortran_implementation/external_libraries/BLAS/SRC/srotm.f b/fortran_implementation/external_libraries/BLAS/SRC/srotm.f new file mode 100644 index 0000000..a25519b --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/srotm.f @@ -0,0 +1,201 @@ +*> \brief \b SROTM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SROTM(N,SX,INCX,SY,INCY,SPARAM) +* +* .. Scalar Arguments .. +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* REAL SPARAM(5),SX(*),SY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX +*> +*> (SX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF SX ARE IN +*> (SX**T) +*> +*> SX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE +*> LX = (-INCX)*N, AND SIMILARLY FOR SY USING USING LY AND INCY. +*> WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS.. +*> +*> SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0 +*> +*> (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0) +*> H=( ) ( ) ( ) ( ) +*> (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0). +*> SEE SROTMG FOR A DESCRIPTION OF DATA STORAGE IN SPARAM. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in,out] SX +*> \verbatim +*> SX is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of SX +*> \endverbatim +*> +*> \param[in,out] SY +*> \verbatim +*> SY is REAL array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of SY +*> \endverbatim +*> +*> \param[in] SPARAM +*> \verbatim +*> SPARAM is REAL array, dimension (5) +*> SPARAM(1)=SFLAG +*> SPARAM(2)=SH11 +*> SPARAM(3)=SH21 +*> SPARAM(4)=SH12 +*> SPARAM(5)=SH22 +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup rotm +* +* ===================================================================== + SUBROUTINE SROTM(N,SX,INCX,SY,INCY,SPARAM) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + REAL SPARAM(5),SX(*),SY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + REAL SFLAG,SH11,SH12,SH21,SH22,TWO,W,Z,ZERO + INTEGER I,KX,KY,NSTEPS +* .. +* .. Data statements .. + DATA ZERO,TWO/0.E0,2.E0/ +* .. +* + SFLAG = SPARAM(1) + IF (N.LE.0 .OR. (SFLAG+TWO.EQ.ZERO)) RETURN + IF (INCX.EQ.INCY.AND.INCX.GT.0) THEN +* + NSTEPS = N*INCX + IF (SFLAG.LT.ZERO) THEN + SH11 = SPARAM(2) + SH12 = SPARAM(4) + SH21 = SPARAM(3) + SH22 = SPARAM(5) + DO I = 1,NSTEPS,INCX + W = SX(I) + Z = SY(I) + SX(I) = W*SH11 + Z*SH12 + SY(I) = W*SH21 + Z*SH22 + END DO + ELSE IF (SFLAG.EQ.ZERO) THEN + SH12 = SPARAM(4) + SH21 = SPARAM(3) + DO I = 1,NSTEPS,INCX + W = SX(I) + Z = SY(I) + SX(I) = W + Z*SH12 + SY(I) = W*SH21 + Z + END DO + ELSE + SH11 = SPARAM(2) + SH22 = SPARAM(5) + DO I = 1,NSTEPS,INCX + W = SX(I) + Z = SY(I) + SX(I) = W*SH11 + Z + SY(I) = -W + SH22*Z + END DO + END IF + ELSE + KX = 1 + KY = 1 + IF (INCX.LT.0) KX = 1 + (1-N)*INCX + IF (INCY.LT.0) KY = 1 + (1-N)*INCY +* + IF (SFLAG.LT.ZERO) THEN + SH11 = SPARAM(2) + SH12 = SPARAM(4) + SH21 = SPARAM(3) + SH22 = SPARAM(5) + DO I = 1,N + W = SX(KX) + Z = SY(KY) + SX(KX) = W*SH11 + Z*SH12 + SY(KY) = W*SH21 + Z*SH22 + KX = KX + INCX + KY = KY + INCY + END DO + ELSE IF (SFLAG.EQ.ZERO) THEN + SH12 = SPARAM(4) + SH21 = SPARAM(3) + DO I = 1,N + W = SX(KX) + Z = SY(KY) + SX(KX) = W + Z*SH12 + SY(KY) = W*SH21 + Z + KX = KX + INCX + KY = KY + INCY + END DO + ELSE + SH11 = SPARAM(2) + SH22 = SPARAM(5) + DO I = 1,N + W = SX(KX) + Z = SY(KY) + SX(KX) = W*SH11 + Z + SY(KY) = -W + SH22*Z + KX = KX + INCX + KY = KY + INCY + END DO + END IF + END IF + RETURN +* +* End of SROTM +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/srotmg.f b/fortran_implementation/external_libraries/BLAS/SRC/srotmg.f new file mode 100644 index 0000000..9273927 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/srotmg.f @@ -0,0 +1,260 @@ +*> \brief \b SROTMG +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SROTMG(SD1,SD2,SX1,SY1,SPARAM) +* +* .. Scalar Arguments .. +* REAL SD1,SD2,SX1,SY1 +* .. +* .. Array Arguments .. +* REAL SPARAM(5) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS +*> THE SECOND COMPONENT OF THE 2-VECTOR (SQRT(SD1)*SX1,SQRT(SD2)*> SY2)**T. +*> WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS.. +*> +*> SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0 +*> +*> (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0) +*> H=( ) ( ) ( ) ( ) +*> (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0). +*> LOCATIONS 2-4 OF SPARAM CONTAIN SH11,SH21,SH12, AND SH22 +*> RESPECTIVELY. (VALUES OF 1.E0, -1.E0, OR 0.E0 IMPLIED BY THE +*> VALUE OF SPARAM(1) ARE NOT STORED IN SPARAM.) +*> +*> THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE +*> INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE +*> OF SD1 AND SD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in,out] SD1 +*> \verbatim +*> SD1 is REAL +*> \endverbatim +*> +*> \param[in,out] SD2 +*> \verbatim +*> SD2 is REAL +*> \endverbatim +*> +*> \param[in,out] SX1 +*> \verbatim +*> SX1 is REAL +*> \endverbatim +*> +*> \param[in] SY1 +*> \verbatim +*> SY1 is REAL +*> \endverbatim +*> +*> \param[out] SPARAM +*> \verbatim +*> SPARAM is REAL array, dimension (5) +*> SPARAM(1)=SFLAG +*> SPARAM(2)=SH11 +*> SPARAM(3)=SH21 +*> SPARAM(4)=SH12 +*> SPARAM(5)=SH22 +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup rotmg +* +* ===================================================================== + SUBROUTINE SROTMG(SD1,SD2,SX1,SY1,SPARAM) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + REAL SD1,SD2,SX1,SY1 +* .. +* .. Array Arguments .. + REAL SPARAM(5) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + REAL GAM,GAMSQ,ONE,RGAMSQ,SFLAG,SH11,SH12,SH21,SH22,SP1,SP2,SQ1, + $ SQ2,STEMP,SU,TWO,ZERO +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS +* .. +* .. Data statements .. +* + DATA ZERO,ONE,TWO/0.E0,1.E0,2.E0/ + DATA GAM,GAMSQ,RGAMSQ/4096.E0,1.67772E7,5.96046E-8/ +* .. + + IF (SD1.LT.ZERO) THEN +* GO ZERO-H-D-AND-SX1.. + SFLAG = -ONE + SH11 = ZERO + SH12 = ZERO + SH21 = ZERO + SH22 = ZERO +* + SD1 = ZERO + SD2 = ZERO + SX1 = ZERO + ELSE +* CASE-SD1-NONNEGATIVE + SP2 = SD2*SY1 + IF (SP2.EQ.ZERO) THEN + SFLAG = -TWO + SPARAM(1) = SFLAG + RETURN + END IF +* REGULAR-CASE.. + SP1 = SD1*SX1 + SQ2 = SP2*SY1 + SQ1 = SP1*SX1 +* + IF (ABS(SQ1).GT.ABS(SQ2)) THEN + SH21 = -SY1/SX1 + SH12 = SP2/SP1 +* + SU = ONE - SH12*SH21 +* + IF (SU.GT.ZERO) THEN + SFLAG = ZERO + SD1 = SD1/SU + SD2 = SD2/SU + SX1 = SX1*SU + ELSE +* This code path if here for safety. We do not expect this +* condition to ever hold except in edge cases with rounding +* errors. See DOI: 10.1145/355841.355847 + SFLAG = -ONE + SH11 = ZERO + SH12 = ZERO + SH21 = ZERO + SH22 = ZERO +* + SD1 = ZERO + SD2 = ZERO + SX1 = ZERO + END IF + ELSE + + IF (SQ2.LT.ZERO) THEN +* GO ZERO-H-D-AND-SX1.. + SFLAG = -ONE + SH11 = ZERO + SH12 = ZERO + SH21 = ZERO + SH22 = ZERO +* + SD1 = ZERO + SD2 = ZERO + SX1 = ZERO + ELSE + SFLAG = ONE + SH11 = SP1/SP2 + SH22 = SX1/SY1 + SU = ONE + SH11*SH22 + STEMP = SD2/SU + SD2 = SD1/SU + SD1 = STEMP + SX1 = SY1*SU + END IF + END IF + +* PROCEDURE..SCALE-CHECK + IF (SD1.NE.ZERO) THEN + DO WHILE ((SD1.LE.RGAMSQ) .OR. (SD1.GE.GAMSQ)) + IF (SFLAG.EQ.ZERO) THEN + SH11 = ONE + SH22 = ONE + SFLAG = -ONE + ELSE + SH21 = -ONE + SH12 = ONE + SFLAG = -ONE + END IF + IF (SD1.LE.RGAMSQ) THEN + SD1 = SD1*GAM**2 + SX1 = SX1/GAM + SH11 = SH11/GAM + SH12 = SH12/GAM + ELSE + SD1 = SD1/GAM**2 + SX1 = SX1*GAM + SH11 = SH11*GAM + SH12 = SH12*GAM + END IF + ENDDO + END IF + + IF (SD2.NE.ZERO) THEN + DO WHILE ( (ABS(SD2).LE.RGAMSQ) .OR. (ABS(SD2).GE.GAMSQ) ) + IF (SFLAG.EQ.ZERO) THEN + SH11 = ONE + SH22 = ONE + SFLAG = -ONE + ELSE + SH21 = -ONE + SH12 = ONE + SFLAG = -ONE + END IF + IF (ABS(SD2).LE.RGAMSQ) THEN + SD2 = SD2*GAM**2 + SH21 = SH21/GAM + SH22 = SH22/GAM + ELSE + SD2 = SD2/GAM**2 + SH21 = SH21*GAM + SH22 = SH22*GAM + END IF + END DO + END IF + + END IF + + IF (SFLAG.LT.ZERO) THEN + SPARAM(2) = SH11 + SPARAM(3) = SH21 + SPARAM(4) = SH12 + SPARAM(5) = SH22 + ELSE IF (SFLAG.EQ.ZERO) THEN + SPARAM(3) = SH21 + SPARAM(4) = SH12 + ELSE + SPARAM(2) = SH11 + SPARAM(5) = SH22 + END IF + + SPARAM(1) = SFLAG + RETURN +* +* End of SROTMG +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/ssbmv.f b/fortran_implementation/external_libraries/BLAS/SRC/ssbmv.f new file mode 100644 index 0000000..c2a0b3e --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/ssbmv.f @@ -0,0 +1,372 @@ +*> \brief \b SSBMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SSBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* .. Scalar Arguments .. +* REAL ALPHA,BETA +* INTEGER INCX,INCY,K,LDA,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* REAL A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSBMV performs the matrix-vector operation +*> +*> y := alpha*A*x + beta*y, +*> +*> where alpha and beta are scalars, x and y are n element vectors and +*> A is an n by n symmetric band matrix, with k super-diagonals. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the band matrix A is being supplied as +*> follows: +*> +*> UPLO = 'U' or 'u' The upper triangular part of A is +*> being supplied. +*> +*> UPLO = 'L' or 'l' The lower triangular part of A is +*> being supplied. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry, K specifies the number of super-diagonals of the +*> matrix A. K must satisfy 0 .le. K. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is REAL +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is REAL array, dimension ( LDA, N ) +*> Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) +*> by n part of the array A must contain the upper triangular +*> band part of the symmetric matrix, supplied column by +*> column, with the leading diagonal of the matrix in row +*> ( k + 1 ) of the array, the first super-diagonal starting at +*> position 2 in row k, and so on. The top left k by k triangle +*> of the array A is not referenced. +*> The following program segment will transfer the upper +*> triangular part of a symmetric band matrix from conventional +*> full matrix storage to band storage: +*> +*> DO 20, J = 1, N +*> M = K + 1 - J +*> DO 10, I = MAX( 1, J - K ), J +*> A( M + I, J ) = matrix( I, J ) +*> 10 CONTINUE +*> 20 CONTINUE +*> +*> Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) +*> by n part of the array A must contain the lower triangular +*> band part of the symmetric matrix, supplied column by +*> column, with the leading diagonal of the matrix in row 1 of +*> the array, the first sub-diagonal starting at position 1 in +*> row 2, and so on. The bottom right k by k triangle of the +*> array A is not referenced. +*> The following program segment will transfer the lower +*> triangular part of a symmetric band matrix from conventional +*> full matrix storage to band storage: +*> +*> DO 20, J = 1, N +*> M = 1 - J +*> DO 10, I = J, MIN( N, J + K ) +*> A( M + I, J ) = matrix( I, J ) +*> 10 CONTINUE +*> 20 CONTINUE +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> ( k + 1 ). +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is REAL array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the +*> vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is REAL +*> On entry, BETA specifies the scalar beta. +*> \endverbatim +*> +*> \param[in,out] Y +*> \verbatim +*> Y is REAL array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCY ) ). +*> Before entry, the incremented array Y must contain the +*> vector y. On exit, Y is overwritten by the updated vector y. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> Y. INCY must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup hbmv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> The vector and matrix arguments are not referenced when N = 0, or M = 0 +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE SSBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + REAL ALPHA,BETA + INTEGER INCX,INCY,K,LDA,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + REAL A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE,ZERO + PARAMETER (ONE=1.0E+0,ZERO=0.0E+0) +* .. +* .. Local Scalars .. + REAL TEMP1,TEMP2 + INTEGER I,INFO,IX,IY,J,JX,JY,KPLUS1,KX,KY,L +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX,MIN +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (N.LT.0) THEN + INFO = 2 + ELSE IF (K.LT.0) THEN + INFO = 3 + ELSE IF (LDA.LT. (K+1)) THEN + INFO = 6 + ELSE IF (INCX.EQ.0) THEN + INFO = 8 + ELSE IF (INCY.EQ.0) THEN + INFO = 11 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('SSBMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN +* +* Set up the start points in X and Y. +* + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (N-1)*INCX + END IF + IF (INCY.GT.0) THEN + KY = 1 + ELSE + KY = 1 - (N-1)*INCY + END IF +* +* Start the operations. In this version the elements of the array A +* are accessed sequentially with one pass through A. +* +* First form y := beta*y. +* + IF (BETA.NE.ONE) THEN + IF (INCY.EQ.1) THEN + IF (BETA.EQ.ZERO) THEN + DO 10 I = 1,N + Y(I) = ZERO + 10 CONTINUE + ELSE + DO 20 I = 1,N + Y(I) = BETA*Y(I) + 20 CONTINUE + END IF + ELSE + IY = KY + IF (BETA.EQ.ZERO) THEN + DO 30 I = 1,N + Y(IY) = ZERO + IY = IY + INCY + 30 CONTINUE + ELSE + DO 40 I = 1,N + Y(IY) = BETA*Y(IY) + IY = IY + INCY + 40 CONTINUE + END IF + END IF + END IF + IF (ALPHA.EQ.ZERO) RETURN + IF (LSAME(UPLO,'U')) THEN +* +* Form y when upper triangle of A is stored. +* + KPLUS1 = K + 1 + IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN + DO 60 J = 1,N + TEMP1 = ALPHA*X(J) + TEMP2 = ZERO + L = KPLUS1 - J + DO 50 I = MAX(1,J-K),J - 1 + Y(I) = Y(I) + TEMP1*A(L+I,J) + TEMP2 = TEMP2 + A(L+I,J)*X(I) + 50 CONTINUE + Y(J) = Y(J) + TEMP1*A(KPLUS1,J) + ALPHA*TEMP2 + 60 CONTINUE + ELSE + JX = KX + JY = KY + DO 80 J = 1,N + TEMP1 = ALPHA*X(JX) + TEMP2 = ZERO + IX = KX + IY = KY + L = KPLUS1 - J + DO 70 I = MAX(1,J-K),J - 1 + Y(IY) = Y(IY) + TEMP1*A(L+I,J) + TEMP2 = TEMP2 + A(L+I,J)*X(IX) + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + Y(JY) = Y(JY) + TEMP1*A(KPLUS1,J) + ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + IF (J.GT.K) THEN + KX = KX + INCX + KY = KY + INCY + END IF + 80 CONTINUE + END IF + ELSE +* +* Form y when lower triangle of A is stored. +* + IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN + DO 100 J = 1,N + TEMP1 = ALPHA*X(J) + TEMP2 = ZERO + Y(J) = Y(J) + TEMP1*A(1,J) + L = 1 - J + DO 90 I = J + 1,MIN(N,J+K) + Y(I) = Y(I) + TEMP1*A(L+I,J) + TEMP2 = TEMP2 + A(L+I,J)*X(I) + 90 CONTINUE + Y(J) = Y(J) + ALPHA*TEMP2 + 100 CONTINUE + ELSE + JX = KX + JY = KY + DO 120 J = 1,N + TEMP1 = ALPHA*X(JX) + TEMP2 = ZERO + Y(JY) = Y(JY) + TEMP1*A(1,J) + L = 1 - J + IX = JX + IY = JY + DO 110 I = J + 1,MIN(N,J+K) + IX = IX + INCX + IY = IY + INCY + Y(IY) = Y(IY) + TEMP1*A(L+I,J) + TEMP2 = TEMP2 + A(L+I,J)*X(IX) + 110 CONTINUE + Y(JY) = Y(JY) + ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + 120 CONTINUE + END IF + END IF +* + RETURN +* +* End of SSBMV +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/sscal.f b/fortran_implementation/external_libraries/BLAS/SRC/sscal.f new file mode 100644 index 0000000..b535f22 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/sscal.f @@ -0,0 +1,140 @@ +*> \brief \b SSCAL +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SSCAL(N,SA,SX,INCX) +* +* .. Scalar Arguments .. +* REAL SA +* INTEGER INCX,N +* .. +* .. Array Arguments .. +* REAL SX(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSCAL scales a vector by a constant. +*> uses unrolled loops for increment equal to 1. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] SA +*> \verbatim +*> SA is REAL +*> On entry, SA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in,out] SX +*> \verbatim +*> SX is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of SX +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup scal +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, linpack, 3/11/78. +*> modified 3/93 to return if incx .le. 0. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE SSCAL(N,SA,SX,INCX) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + REAL SA + INTEGER INCX,N +* .. +* .. Array Arguments .. + REAL SX(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,M,MP1,NINCX +* .. +* .. Parameters .. + REAL ONE + PARAMETER (ONE=1.0E+0) +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. + IF (N.LE.0 .OR. INCX.LE.0 .OR. SA.EQ.ONE) RETURN + IF (INCX.EQ.1) THEN +* +* code for increment equal to 1 +* +* +* clean-up loop +* + M = MOD(N,5) + IF (M.NE.0) THEN + DO I = 1,M + SX(I) = SA*SX(I) + END DO + IF (N.LT.5) RETURN + END IF + MP1 = M + 1 + DO I = MP1,N,5 + SX(I) = SA*SX(I) + SX(I+1) = SA*SX(I+1) + SX(I+2) = SA*SX(I+2) + SX(I+3) = SA*SX(I+3) + SX(I+4) = SA*SX(I+4) + END DO + ELSE +* +* code for increment not equal to 1 +* + NINCX = N*INCX + DO I = 1,NINCX,INCX + SX(I) = SA*SX(I) + END DO + END IF + RETURN +* +* End of SSCAL +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/sspmv.f b/fortran_implementation/external_libraries/BLAS/SRC/sspmv.f new file mode 100644 index 0000000..4ca5e3e --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/sspmv.f @@ -0,0 +1,328 @@ +*> \brief \b SSPMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SSPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY) +* +* .. Scalar Arguments .. +* REAL ALPHA,BETA +* INTEGER INCX,INCY,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* REAL AP(*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSPMV performs the matrix-vector operation +*> +*> y := alpha*A*x + beta*y, +*> +*> where alpha and beta are scalars, x and y are n element vectors and +*> A is an n by n symmetric matrix, supplied in packed form. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the matrix A is supplied in the packed +*> array AP as follows: +*> +*> UPLO = 'U' or 'u' The upper triangular part of A is +*> supplied in AP. +*> +*> UPLO = 'L' or 'l' The lower triangular part of A is +*> supplied in AP. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is REAL +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] AP +*> \verbatim +*> AP is REAL array, dimension at least +*> ( ( n*( n + 1 ) )/2 ). +*> Before entry with UPLO = 'U' or 'u', the array AP must +*> contain the upper triangular part of the symmetric matrix +*> packed sequentially, column by column, so that AP( 1 ) +*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) +*> and a( 2, 2 ) respectively, and so on. +*> Before entry with UPLO = 'L' or 'l', the array AP must +*> contain the lower triangular part of the symmetric matrix +*> packed sequentially, column by column, so that AP( 1 ) +*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) +*> and a( 3, 1 ) respectively, and so on. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is REAL array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is REAL +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then Y need not be set on input. +*> \endverbatim +*> +*> \param[in,out] Y +*> \verbatim +*> Y is REAL array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCY ) ). +*> Before entry, the incremented array Y must contain the n +*> element vector y. On exit, Y is overwritten by the updated +*> vector y. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> Y. INCY must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup hpmv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> The vector and matrix arguments are not referenced when N = 0, or M = 0 +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE SSPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + REAL ALPHA,BETA + INTEGER INCX,INCY,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + REAL AP(*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE,ZERO + PARAMETER (ONE=1.0E+0,ZERO=0.0E+0) +* .. +* .. Local Scalars .. + REAL TEMP1,TEMP2 + INTEGER I,INFO,IX,IY,J,JX,JY,K,KK,KX,KY +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (N.LT.0) THEN + INFO = 2 + ELSE IF (INCX.EQ.0) THEN + INFO = 6 + ELSE IF (INCY.EQ.0) THEN + INFO = 9 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('SSPMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN +* +* Set up the start points in X and Y. +* + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (N-1)*INCX + END IF + IF (INCY.GT.0) THEN + KY = 1 + ELSE + KY = 1 - (N-1)*INCY + END IF +* +* Start the operations. In this version the elements of the array AP +* are accessed sequentially with one pass through AP. +* +* First form y := beta*y. +* + IF (BETA.NE.ONE) THEN + IF (INCY.EQ.1) THEN + IF (BETA.EQ.ZERO) THEN + DO 10 I = 1,N + Y(I) = ZERO + 10 CONTINUE + ELSE + DO 20 I = 1,N + Y(I) = BETA*Y(I) + 20 CONTINUE + END IF + ELSE + IY = KY + IF (BETA.EQ.ZERO) THEN + DO 30 I = 1,N + Y(IY) = ZERO + IY = IY + INCY + 30 CONTINUE + ELSE + DO 40 I = 1,N + Y(IY) = BETA*Y(IY) + IY = IY + INCY + 40 CONTINUE + END IF + END IF + END IF + IF (ALPHA.EQ.ZERO) RETURN + KK = 1 + IF (LSAME(UPLO,'U')) THEN +* +* Form y when AP contains the upper triangle. +* + IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN + DO 60 J = 1,N + TEMP1 = ALPHA*X(J) + TEMP2 = ZERO + K = KK + DO 50 I = 1,J - 1 + Y(I) = Y(I) + TEMP1*AP(K) + TEMP2 = TEMP2 + AP(K)*X(I) + K = K + 1 + 50 CONTINUE + Y(J) = Y(J) + TEMP1*AP(KK+J-1) + ALPHA*TEMP2 + KK = KK + J + 60 CONTINUE + ELSE + JX = KX + JY = KY + DO 80 J = 1,N + TEMP1 = ALPHA*X(JX) + TEMP2 = ZERO + IX = KX + IY = KY + DO 70 K = KK,KK + J - 2 + Y(IY) = Y(IY) + TEMP1*AP(K) + TEMP2 = TEMP2 + AP(K)*X(IX) + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + Y(JY) = Y(JY) + TEMP1*AP(KK+J-1) + ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + KK = KK + J + 80 CONTINUE + END IF + ELSE +* +* Form y when AP contains the lower triangle. +* + IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN + DO 100 J = 1,N + TEMP1 = ALPHA*X(J) + TEMP2 = ZERO + Y(J) = Y(J) + TEMP1*AP(KK) + K = KK + 1 + DO 90 I = J + 1,N + Y(I) = Y(I) + TEMP1*AP(K) + TEMP2 = TEMP2 + AP(K)*X(I) + K = K + 1 + 90 CONTINUE + Y(J) = Y(J) + ALPHA*TEMP2 + KK = KK + (N-J+1) + 100 CONTINUE + ELSE + JX = KX + JY = KY + DO 120 J = 1,N + TEMP1 = ALPHA*X(JX) + TEMP2 = ZERO + Y(JY) = Y(JY) + TEMP1*AP(KK) + IX = JX + IY = JY + DO 110 K = KK + 1,KK + N - J + IX = IX + INCX + IY = IY + INCY + Y(IY) = Y(IY) + TEMP1*AP(K) + TEMP2 = TEMP2 + AP(K)*X(IX) + 110 CONTINUE + Y(JY) = Y(JY) + ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + KK = KK + (N-J+1) + 120 CONTINUE + END IF + END IF +* + RETURN +* +* End of SSPMV +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/sspr.f b/fortran_implementation/external_libraries/BLAS/SRC/sspr.f new file mode 100644 index 0000000..f573649 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/sspr.f @@ -0,0 +1,258 @@ +*> \brief \b SSPR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SSPR(UPLO,N,ALPHA,X,INCX,AP) +* +* .. Scalar Arguments .. +* REAL ALPHA +* INTEGER INCX,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* REAL AP(*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSPR performs the symmetric rank 1 operation +*> +*> A := alpha*x*x**T + A, +*> +*> where alpha is a real scalar, x is an n element vector and A is an +*> n by n symmetric matrix, supplied in packed form. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the matrix A is supplied in the packed +*> array AP as follows: +*> +*> UPLO = 'U' or 'u' The upper triangular part of A is +*> supplied in AP. +*> +*> UPLO = 'L' or 'l' The lower triangular part of A is +*> supplied in AP. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is REAL +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is REAL array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in,out] AP +*> \verbatim +*> AP is REAL array, dimension at least +*> ( ( n*( n + 1 ) )/2 ). +*> Before entry with UPLO = 'U' or 'u', the array AP must +*> contain the upper triangular part of the symmetric matrix +*> packed sequentially, column by column, so that AP( 1 ) +*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) +*> and a( 2, 2 ) respectively, and so on. On exit, the array +*> AP is overwritten by the upper triangular part of the +*> updated matrix. +*> Before entry with UPLO = 'L' or 'l', the array AP must +*> contain the lower triangular part of the symmetric matrix +*> packed sequentially, column by column, so that AP( 1 ) +*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) +*> and a( 3, 1 ) respectively, and so on. On exit, the array +*> AP is overwritten by the lower triangular part of the +*> updated matrix. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup hpr +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE SSPR(UPLO,N,ALPHA,X,INCX,AP) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + REAL ALPHA + INTEGER INCX,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + REAL AP(*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO + PARAMETER (ZERO=0.0E+0) +* .. +* .. Local Scalars .. + REAL TEMP + INTEGER I,INFO,IX,J,JX,K,KK,KX +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (N.LT.0) THEN + INFO = 2 + ELSE IF (INCX.EQ.0) THEN + INFO = 5 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('SSPR ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN +* +* Set the start point in X if the increment is not unity. +* + IF (INCX.LE.0) THEN + KX = 1 - (N-1)*INCX + ELSE IF (INCX.NE.1) THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of the array AP +* are accessed sequentially with one pass through AP. +* + KK = 1 + IF (LSAME(UPLO,'U')) THEN +* +* Form A when upper triangle is stored in AP. +* + IF (INCX.EQ.1) THEN + DO 20 J = 1,N + IF (X(J).NE.ZERO) THEN + TEMP = ALPHA*X(J) + K = KK + DO 10 I = 1,J + AP(K) = AP(K) + X(I)*TEMP + K = K + 1 + 10 CONTINUE + END IF + KK = KK + J + 20 CONTINUE + ELSE + JX = KX + DO 40 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = ALPHA*X(JX) + IX = KX + DO 30 K = KK,KK + J - 1 + AP(K) = AP(K) + X(IX)*TEMP + IX = IX + INCX + 30 CONTINUE + END IF + JX = JX + INCX + KK = KK + J + 40 CONTINUE + END IF + ELSE +* +* Form A when lower triangle is stored in AP. +* + IF (INCX.EQ.1) THEN + DO 60 J = 1,N + IF (X(J).NE.ZERO) THEN + TEMP = ALPHA*X(J) + K = KK + DO 50 I = J,N + AP(K) = AP(K) + X(I)*TEMP + K = K + 1 + 50 CONTINUE + END IF + KK = KK + N - J + 1 + 60 CONTINUE + ELSE + JX = KX + DO 80 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = ALPHA*X(JX) + IX = JX + DO 70 K = KK,KK + N - J + AP(K) = AP(K) + X(IX)*TEMP + IX = IX + INCX + 70 CONTINUE + END IF + JX = JX + INCX + KK = KK + N - J + 1 + 80 CONTINUE + END IF + END IF +* + RETURN +* +* End of SSPR +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/sspr2.f b/fortran_implementation/external_libraries/BLAS/SRC/sspr2.f new file mode 100644 index 0000000..a51ed32 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/sspr2.f @@ -0,0 +1,293 @@ +*> \brief \b SSPR2 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SSPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP) +* +* .. Scalar Arguments .. +* REAL ALPHA +* INTEGER INCX,INCY,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* REAL AP(*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSPR2 performs the symmetric rank 2 operation +*> +*> A := alpha*x*y**T + alpha*y*x**T + A, +*> +*> where alpha is a scalar, x and y are n element vectors and A is an +*> n by n symmetric matrix, supplied in packed form. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the matrix A is supplied in the packed +*> array AP as follows: +*> +*> UPLO = 'U' or 'u' The upper triangular part of A is +*> supplied in AP. +*> +*> UPLO = 'L' or 'l' The lower triangular part of A is +*> supplied in AP. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is REAL +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is REAL array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in] Y +*> \verbatim +*> Y is REAL array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCY ) ). +*> Before entry, the incremented array Y must contain the n +*> element vector y. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> Y. INCY must not be zero. +*> \endverbatim +*> +*> \param[in,out] AP +*> \verbatim +*> AP is REAL array, dimension at least +*> ( ( n*( n + 1 ) )/2 ). +*> Before entry with UPLO = 'U' or 'u', the array AP must +*> contain the upper triangular part of the symmetric matrix +*> packed sequentially, column by column, so that AP( 1 ) +*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) +*> and a( 2, 2 ) respectively, and so on. On exit, the array +*> AP is overwritten by the upper triangular part of the +*> updated matrix. +*> Before entry with UPLO = 'L' or 'l', the array AP must +*> contain the lower triangular part of the symmetric matrix +*> packed sequentially, column by column, so that AP( 1 ) +*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) +*> and a( 3, 1 ) respectively, and so on. On exit, the array +*> AP is overwritten by the lower triangular part of the +*> updated matrix. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup hpr2 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE SSPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + REAL ALPHA + INTEGER INCX,INCY,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + REAL AP(*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO + PARAMETER (ZERO=0.0E+0) +* .. +* .. Local Scalars .. + REAL TEMP1,TEMP2 + INTEGER I,INFO,IX,IY,J,JX,JY,K,KK,KX,KY +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (N.LT.0) THEN + INFO = 2 + ELSE IF (INCX.EQ.0) THEN + INFO = 5 + ELSE IF (INCY.EQ.0) THEN + INFO = 7 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('SSPR2 ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN +* +* Set up the start points in X and Y if the increments are not both +* unity. +* + IF ((INCX.NE.1) .OR. (INCY.NE.1)) THEN + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (N-1)*INCX + END IF + IF (INCY.GT.0) THEN + KY = 1 + ELSE + KY = 1 - (N-1)*INCY + END IF + JX = KX + JY = KY + END IF +* +* Start the operations. In this version the elements of the array AP +* are accessed sequentially with one pass through AP. +* + KK = 1 + IF (LSAME(UPLO,'U')) THEN +* +* Form A when upper triangle is stored in AP. +* + IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN + DO 20 J = 1,N + IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN + TEMP1 = ALPHA*Y(J) + TEMP2 = ALPHA*X(J) + K = KK + DO 10 I = 1,J + AP(K) = AP(K) + X(I)*TEMP1 + Y(I)*TEMP2 + K = K + 1 + 10 CONTINUE + END IF + KK = KK + J + 20 CONTINUE + ELSE + DO 40 J = 1,N + IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN + TEMP1 = ALPHA*Y(JY) + TEMP2 = ALPHA*X(JX) + IX = KX + IY = KY + DO 30 K = KK,KK + J - 1 + AP(K) = AP(K) + X(IX)*TEMP1 + Y(IY)*TEMP2 + IX = IX + INCX + IY = IY + INCY + 30 CONTINUE + END IF + JX = JX + INCX + JY = JY + INCY + KK = KK + J + 40 CONTINUE + END IF + ELSE +* +* Form A when lower triangle is stored in AP. +* + IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN + DO 60 J = 1,N + IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN + TEMP1 = ALPHA*Y(J) + TEMP2 = ALPHA*X(J) + K = KK + DO 50 I = J,N + AP(K) = AP(K) + X(I)*TEMP1 + Y(I)*TEMP2 + K = K + 1 + 50 CONTINUE + END IF + KK = KK + N - J + 1 + 60 CONTINUE + ELSE + DO 80 J = 1,N + IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN + TEMP1 = ALPHA*Y(JY) + TEMP2 = ALPHA*X(JX) + IX = JX + IY = JY + DO 70 K = KK,KK + N - J + AP(K) = AP(K) + X(IX)*TEMP1 + Y(IY)*TEMP2 + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + END IF + JX = JX + INCX + JY = JY + INCY + KK = KK + N - J + 1 + 80 CONTINUE + END IF + END IF +* + RETURN +* +* End of SSPR2 +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/sswap.f b/fortran_implementation/external_libraries/BLAS/SRC/sswap.f new file mode 100644 index 0000000..57af902 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/sswap.f @@ -0,0 +1,153 @@ +*> \brief \b SSWAP +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SSWAP(N,SX,INCX,SY,INCY) +* +* .. Scalar Arguments .. +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* REAL SX(*),SY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSWAP interchanges two vectors. +*> uses unrolled loops for increments equal to 1. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in,out] SX +*> \verbatim +*> SX is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of SX +*> \endverbatim +*> +*> \param[in,out] SY +*> \verbatim +*> SY is REAL array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of SY +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup swap +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, linpack, 3/11/78. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE SSWAP(N,SX,INCX,SY,INCY) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + REAL SX(*),SY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + REAL STEMP + INTEGER I,IX,IY,M,MP1 +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* +* +* clean-up loop +* + M = MOD(N,3) + IF (M.NE.0) THEN + DO I = 1,M + STEMP = SX(I) + SX(I) = SY(I) + SY(I) = STEMP + END DO + IF (N.LT.3) RETURN + END IF + MP1 = M + 1 + DO I = MP1,N,3 + STEMP = SX(I) + SX(I) = SY(I) + SY(I) = STEMP + STEMP = SX(I+1) + SX(I+1) = SY(I+1) + SY(I+1) = STEMP + STEMP = SX(I+2) + SX(I+2) = SY(I+2) + SY(I+2) = STEMP + END DO + ELSE +* +* code for unequal increments or equal increments not equal +* to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + STEMP = SX(IX) + SX(IX) = SY(IY) + SY(IY) = STEMP + IX = IX + INCX + IY = IY + INCY + END DO + END IF + RETURN +* +* End of SSWAP +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/ssymm.f b/fortran_implementation/external_libraries/BLAS/SRC/ssymm.f new file mode 100644 index 0000000..4174fa6 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/ssymm.f @@ -0,0 +1,366 @@ +*> \brief \b SSYMM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* .. Scalar Arguments .. +* REAL ALPHA,BETA +* INTEGER LDA,LDB,LDC,M,N +* CHARACTER SIDE,UPLO +* .. +* .. Array Arguments .. +* REAL A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSYMM performs one of the matrix-matrix operations +*> +*> C := alpha*A*B + beta*C, +*> +*> or +*> +*> C := alpha*B*A + beta*C, +*> +*> where alpha and beta are scalars, A is a symmetric matrix and B and +*> C are m by n matrices. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> On entry, SIDE specifies whether the symmetric matrix A +*> appears on the left or right in the operation as follows: +*> +*> SIDE = 'L' or 'l' C := alpha*A*B + beta*C, +*> +*> SIDE = 'R' or 'r' C := alpha*B*A + beta*C, +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the symmetric matrix A is to be +*> referenced as follows: +*> +*> UPLO = 'U' or 'u' Only the upper triangular part of the +*> symmetric matrix is to be referenced. +*> +*> UPLO = 'L' or 'l' Only the lower triangular part of the +*> symmetric matrix is to be referenced. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix C. +*> M must be at least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of the matrix C. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is REAL +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is REAL array, dimension ( LDA, ka ), where ka is +*> m when SIDE = 'L' or 'l' and is n otherwise. +*> Before entry with SIDE = 'L' or 'l', the m by m part of +*> the array A must contain the symmetric matrix, such that +*> when UPLO = 'U' or 'u', the leading m by m upper triangular +*> part of the array A must contain the upper triangular part +*> of the symmetric matrix and the strictly lower triangular +*> part of A is not referenced, and when UPLO = 'L' or 'l', +*> the leading m by m lower triangular part of the array A +*> must contain the lower triangular part of the symmetric +*> matrix and the strictly upper triangular part of A is not +*> referenced. +*> Before entry with SIDE = 'R' or 'r', the n by n part of +*> the array A must contain the symmetric matrix, such that +*> when UPLO = 'U' or 'u', the leading n by n upper triangular +*> part of the array A must contain the upper triangular part +*> of the symmetric matrix and the strictly lower triangular +*> part of A is not referenced, and when UPLO = 'L' or 'l', +*> the leading n by n lower triangular part of the array A +*> must contain the lower triangular part of the symmetric +*> matrix and the strictly upper triangular part of A is not +*> referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When SIDE = 'L' or 'l' then +*> LDA must be at least max( 1, m ), otherwise LDA must be at +*> least max( 1, n ). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is REAL array, dimension ( LDB, N ) +*> Before entry, the leading m by n part of the array B must +*> contain the matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. LDB must be at least +*> max( 1, m ). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is REAL +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then C need not be set on input. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is REAL array, dimension ( LDC, N ) +*> Before entry, the leading m by n part of the array C must +*> contain the matrix C, except when beta is zero, in which +*> case C need not be set on entry. +*> On exit, the array C is overwritten by the m by n updated +*> matrix. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> On entry, LDC specifies the first dimension of C as declared +*> in the calling (sub) program. LDC must be at least +*> max( 1, m ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup hemm +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> -- Written on 8-February-1989. +*> Jack Dongarra, Argonne National Laboratory. +*> Iain Duff, AERE Harwell. +*> Jeremy Du Croz, Numerical Algorithms Group Ltd. +*> Sven Hammarling, Numerical Algorithms Group Ltd. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE SSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* -- Reference BLAS level3 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + REAL ALPHA,BETA + INTEGER LDA,LDB,LDC,M,N + CHARACTER SIDE,UPLO +* .. +* .. Array Arguments .. + REAL A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + REAL TEMP1,TEMP2 + INTEGER I,INFO,J,K,NROWA + LOGICAL UPPER +* .. +* .. Parameters .. + REAL ONE,ZERO + PARAMETER (ONE=1.0E+0,ZERO=0.0E+0) +* .. +* +* Set NROWA as the number of rows of A. +* + IF (LSAME(SIDE,'L')) THEN + NROWA = M + ELSE + NROWA = N + END IF + UPPER = LSAME(UPLO,'U') +* +* Test the input parameters. +* + INFO = 0 + IF ((.NOT.LSAME(SIDE,'L')) .AND. + + (.NOT.LSAME(SIDE,'R'))) THEN + INFO = 1 + ELSE IF ((.NOT.UPPER) .AND. + + (.NOT.LSAME(UPLO,'L'))) THEN + INFO = 2 + ELSE IF (M.LT.0) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 7 + ELSE IF (LDB.LT.MAX(1,M)) THEN + INFO = 9 + ELSE IF (LDC.LT.MAX(1,M)) THEN + INFO = 12 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('SSYMM ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. + + ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + IF (BETA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,M + C(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1,N + DO 30 I = 1,M + C(I,J) = BETA*C(I,J) + 30 CONTINUE + 40 CONTINUE + END IF + RETURN + END IF +* +* Start the operations. +* + IF (LSAME(SIDE,'L')) THEN +* +* Form C := alpha*A*B + beta*C. +* + IF (UPPER) THEN + DO 70 J = 1,N + DO 60 I = 1,M + TEMP1 = ALPHA*B(I,J) + TEMP2 = ZERO + DO 50 K = 1,I - 1 + C(K,J) = C(K,J) + TEMP1*A(K,I) + TEMP2 = TEMP2 + B(K,J)*A(K,I) + 50 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = TEMP1*A(I,I) + ALPHA*TEMP2 + ELSE + C(I,J) = BETA*C(I,J) + TEMP1*A(I,I) + + + ALPHA*TEMP2 + END IF + 60 CONTINUE + 70 CONTINUE + ELSE + DO 100 J = 1,N + DO 90 I = M,1,-1 + TEMP1 = ALPHA*B(I,J) + TEMP2 = ZERO + DO 80 K = I + 1,M + C(K,J) = C(K,J) + TEMP1*A(K,I) + TEMP2 = TEMP2 + B(K,J)*A(K,I) + 80 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = TEMP1*A(I,I) + ALPHA*TEMP2 + ELSE + C(I,J) = BETA*C(I,J) + TEMP1*A(I,I) + + + ALPHA*TEMP2 + END IF + 90 CONTINUE + 100 CONTINUE + END IF + ELSE +* +* Form C := alpha*B*A + beta*C. +* + DO 170 J = 1,N + TEMP1 = ALPHA*A(J,J) + IF (BETA.EQ.ZERO) THEN + DO 110 I = 1,M + C(I,J) = TEMP1*B(I,J) + 110 CONTINUE + ELSE + DO 120 I = 1,M + C(I,J) = BETA*C(I,J) + TEMP1*B(I,J) + 120 CONTINUE + END IF + DO 140 K = 1,J - 1 + IF (UPPER) THEN + TEMP1 = ALPHA*A(K,J) + ELSE + TEMP1 = ALPHA*A(J,K) + END IF + DO 130 I = 1,M + C(I,J) = C(I,J) + TEMP1*B(I,K) + 130 CONTINUE + 140 CONTINUE + DO 160 K = J + 1,N + IF (UPPER) THEN + TEMP1 = ALPHA*A(J,K) + ELSE + TEMP1 = ALPHA*A(K,J) + END IF + DO 150 I = 1,M + C(I,J) = C(I,J) + TEMP1*B(I,K) + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE + END IF +* + RETURN +* +* End of SSYMM +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/ssymv.f b/fortran_implementation/external_libraries/BLAS/SRC/ssymv.f new file mode 100644 index 0000000..4a15c24 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/ssymv.f @@ -0,0 +1,330 @@ +*> \brief \b SSYMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SSYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* .. Scalar Arguments .. +* REAL ALPHA,BETA +* INTEGER INCX,INCY,LDA,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* REAL A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSYMV performs the matrix-vector operation +*> +*> y := alpha*A*x + beta*y, +*> +*> where alpha and beta are scalars, x and y are n element vectors and +*> A is an n by n symmetric matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the array A is to be referenced as +*> follows: +*> +*> UPLO = 'U' or 'u' Only the upper triangular part of A +*> is to be referenced. +*> +*> UPLO = 'L' or 'l' Only the lower triangular part of A +*> is to be referenced. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is REAL +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is REAL array, dimension ( LDA, N ) +*> Before entry with UPLO = 'U' or 'u', the leading n by n +*> upper triangular part of the array A must contain the upper +*> triangular part of the symmetric matrix and the strictly +*> lower triangular part of A is not referenced. +*> Before entry with UPLO = 'L' or 'l', the leading n by n +*> lower triangular part of the array A must contain the lower +*> triangular part of the symmetric matrix and the strictly +*> upper triangular part of A is not referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> max( 1, n ). +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is REAL array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is REAL +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then Y need not be set on input. +*> \endverbatim +*> +*> \param[in,out] Y +*> \verbatim +*> Y is REAL array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCY ) ). +*> Before entry, the incremented array Y must contain the n +*> element vector y. On exit, Y is overwritten by the updated +*> vector y. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> Y. INCY must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup hemv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> The vector and matrix arguments are not referenced when N = 0, or M = 0 +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE SSYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + REAL ALPHA,BETA + INTEGER INCX,INCY,LDA,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + REAL A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE,ZERO + PARAMETER (ONE=1.0E+0,ZERO=0.0E+0) +* .. +* .. Local Scalars .. + REAL TEMP1,TEMP2 + INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (N.LT.0) THEN + INFO = 2 + ELSE IF (LDA.LT.MAX(1,N)) THEN + INFO = 5 + ELSE IF (INCX.EQ.0) THEN + INFO = 7 + ELSE IF (INCY.EQ.0) THEN + INFO = 10 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('SSYMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN +* +* Set up the start points in X and Y. +* + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (N-1)*INCX + END IF + IF (INCY.GT.0) THEN + KY = 1 + ELSE + KY = 1 - (N-1)*INCY + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through the triangular part +* of A. +* +* First form y := beta*y. +* + IF (BETA.NE.ONE) THEN + IF (INCY.EQ.1) THEN + IF (BETA.EQ.ZERO) THEN + DO 10 I = 1,N + Y(I) = ZERO + 10 CONTINUE + ELSE + DO 20 I = 1,N + Y(I) = BETA*Y(I) + 20 CONTINUE + END IF + ELSE + IY = KY + IF (BETA.EQ.ZERO) THEN + DO 30 I = 1,N + Y(IY) = ZERO + IY = IY + INCY + 30 CONTINUE + ELSE + DO 40 I = 1,N + Y(IY) = BETA*Y(IY) + IY = IY + INCY + 40 CONTINUE + END IF + END IF + END IF + IF (ALPHA.EQ.ZERO) RETURN + IF (LSAME(UPLO,'U')) THEN +* +* Form y when A is stored in upper triangle. +* + IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN + DO 60 J = 1,N + TEMP1 = ALPHA*X(J) + TEMP2 = ZERO + DO 50 I = 1,J - 1 + Y(I) = Y(I) + TEMP1*A(I,J) + TEMP2 = TEMP2 + A(I,J)*X(I) + 50 CONTINUE + Y(J) = Y(J) + TEMP1*A(J,J) + ALPHA*TEMP2 + 60 CONTINUE + ELSE + JX = KX + JY = KY + DO 80 J = 1,N + TEMP1 = ALPHA*X(JX) + TEMP2 = ZERO + IX = KX + IY = KY + DO 70 I = 1,J - 1 + Y(IY) = Y(IY) + TEMP1*A(I,J) + TEMP2 = TEMP2 + A(I,J)*X(IX) + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + Y(JY) = Y(JY) + TEMP1*A(J,J) + ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + 80 CONTINUE + END IF + ELSE +* +* Form y when A is stored in lower triangle. +* + IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN + DO 100 J = 1,N + TEMP1 = ALPHA*X(J) + TEMP2 = ZERO + Y(J) = Y(J) + TEMP1*A(J,J) + DO 90 I = J + 1,N + Y(I) = Y(I) + TEMP1*A(I,J) + TEMP2 = TEMP2 + A(I,J)*X(I) + 90 CONTINUE + Y(J) = Y(J) + ALPHA*TEMP2 + 100 CONTINUE + ELSE + JX = KX + JY = KY + DO 120 J = 1,N + TEMP1 = ALPHA*X(JX) + TEMP2 = ZERO + Y(JY) = Y(JY) + TEMP1*A(J,J) + IX = JX + IY = JY + DO 110 I = J + 1,N + IX = IX + INCX + IY = IY + INCY + Y(IY) = Y(IY) + TEMP1*A(I,J) + TEMP2 = TEMP2 + A(I,J)*X(IX) + 110 CONTINUE + Y(JY) = Y(JY) + ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + 120 CONTINUE + END IF + END IF +* + RETURN +* +* End of SSYMV +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/ssyr.f b/fortran_implementation/external_libraries/BLAS/SRC/ssyr.f new file mode 100644 index 0000000..0588966 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/ssyr.f @@ -0,0 +1,260 @@ +*> \brief \b SSYR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SSYR(UPLO,N,ALPHA,X,INCX,A,LDA) +* +* .. Scalar Arguments .. +* REAL ALPHA +* INTEGER INCX,LDA,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* REAL A(LDA,*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSYR performs the symmetric rank 1 operation +*> +*> A := alpha*x*x**T + A, +*> +*> where alpha is a real scalar, x is an n element vector and A is an +*> n by n symmetric matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the array A is to be referenced as +*> follows: +*> +*> UPLO = 'U' or 'u' Only the upper triangular part of A +*> is to be referenced. +*> +*> UPLO = 'L' or 'l' Only the lower triangular part of A +*> is to be referenced. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is REAL +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is REAL array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension ( LDA, N ) +*> Before entry with UPLO = 'U' or 'u', the leading n by n +*> upper triangular part of the array A must contain the upper +*> triangular part of the symmetric matrix and the strictly +*> lower triangular part of A is not referenced. On exit, the +*> upper triangular part of the array A is overwritten by the +*> upper triangular part of the updated matrix. +*> Before entry with UPLO = 'L' or 'l', the leading n by n +*> lower triangular part of the array A must contain the lower +*> triangular part of the symmetric matrix and the strictly +*> upper triangular part of A is not referenced. On exit, the +*> lower triangular part of the array A is overwritten by the +*> lower triangular part of the updated matrix. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> max( 1, n ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup her +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE SSYR(UPLO,N,ALPHA,X,INCX,A,LDA) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + REAL ALPHA + INTEGER INCX,LDA,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + REAL A(LDA,*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO + PARAMETER (ZERO=0.0E+0) +* .. +* .. Local Scalars .. + REAL TEMP + INTEGER I,INFO,IX,J,JX,KX +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (N.LT.0) THEN + INFO = 2 + ELSE IF (INCX.EQ.0) THEN + INFO = 5 + ELSE IF (LDA.LT.MAX(1,N)) THEN + INFO = 7 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('SSYR ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN +* +* Set the start point in X if the increment is not unity. +* + IF (INCX.LE.0) THEN + KX = 1 - (N-1)*INCX + ELSE IF (INCX.NE.1) THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through the triangular part +* of A. +* + IF (LSAME(UPLO,'U')) THEN +* +* Form A when A is stored in upper triangle. +* + IF (INCX.EQ.1) THEN + DO 20 J = 1,N + IF (X(J).NE.ZERO) THEN + TEMP = ALPHA*X(J) + DO 10 I = 1,J + A(I,J) = A(I,J) + X(I)*TEMP + 10 CONTINUE + END IF + 20 CONTINUE + ELSE + JX = KX + DO 40 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = ALPHA*X(JX) + IX = KX + DO 30 I = 1,J + A(I,J) = A(I,J) + X(IX)*TEMP + IX = IX + INCX + 30 CONTINUE + END IF + JX = JX + INCX + 40 CONTINUE + END IF + ELSE +* +* Form A when A is stored in lower triangle. +* + IF (INCX.EQ.1) THEN + DO 60 J = 1,N + IF (X(J).NE.ZERO) THEN + TEMP = ALPHA*X(J) + DO 50 I = J,N + A(I,J) = A(I,J) + X(I)*TEMP + 50 CONTINUE + END IF + 60 CONTINUE + ELSE + JX = KX + DO 80 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = ALPHA*X(JX) + IX = JX + DO 70 I = J,N + A(I,J) = A(I,J) + X(IX)*TEMP + IX = IX + INCX + 70 CONTINUE + END IF + JX = JX + INCX + 80 CONTINUE + END IF + END IF +* + RETURN +* +* End of SSYR +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/ssyr2.f b/fortran_implementation/external_libraries/BLAS/SRC/ssyr2.f new file mode 100644 index 0000000..2593986 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/ssyr2.f @@ -0,0 +1,295 @@ +*> \brief \b SSYR2 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SSYR2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) +* +* .. Scalar Arguments .. +* REAL ALPHA +* INTEGER INCX,INCY,LDA,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* REAL A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSYR2 performs the symmetric rank 2 operation +*> +*> A := alpha*x*y**T + alpha*y*x**T + A, +*> +*> where alpha is a scalar, x and y are n element vectors and A is an n +*> by n symmetric matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the array A is to be referenced as +*> follows: +*> +*> UPLO = 'U' or 'u' Only the upper triangular part of A +*> is to be referenced. +*> +*> UPLO = 'L' or 'l' Only the lower triangular part of A +*> is to be referenced. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is REAL +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is REAL array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in] Y +*> \verbatim +*> Y is REAL array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCY ) ). +*> Before entry, the incremented array Y must contain the n +*> element vector y. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> Y. INCY must not be zero. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension ( LDA, N ) +*> Before entry with UPLO = 'U' or 'u', the leading n by n +*> upper triangular part of the array A must contain the upper +*> triangular part of the symmetric matrix and the strictly +*> lower triangular part of A is not referenced. On exit, the +*> upper triangular part of the array A is overwritten by the +*> upper triangular part of the updated matrix. +*> Before entry with UPLO = 'L' or 'l', the leading n by n +*> lower triangular part of the array A must contain the lower +*> triangular part of the symmetric matrix and the strictly +*> upper triangular part of A is not referenced. On exit, the +*> lower triangular part of the array A is overwritten by the +*> lower triangular part of the updated matrix. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> max( 1, n ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup her2 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE SSYR2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + REAL ALPHA + INTEGER INCX,INCY,LDA,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + REAL A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO + PARAMETER (ZERO=0.0E+0) +* .. +* .. Local Scalars .. + REAL TEMP1,TEMP2 + INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (N.LT.0) THEN + INFO = 2 + ELSE IF (INCX.EQ.0) THEN + INFO = 5 + ELSE IF (INCY.EQ.0) THEN + INFO = 7 + ELSE IF (LDA.LT.MAX(1,N)) THEN + INFO = 9 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('SSYR2 ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN +* +* Set up the start points in X and Y if the increments are not both +* unity. +* + IF ((INCX.NE.1) .OR. (INCY.NE.1)) THEN + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (N-1)*INCX + END IF + IF (INCY.GT.0) THEN + KY = 1 + ELSE + KY = 1 - (N-1)*INCY + END IF + JX = KX + JY = KY + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through the triangular part +* of A. +* + IF (LSAME(UPLO,'U')) THEN +* +* Form A when A is stored in the upper triangle. +* + IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN + DO 20 J = 1,N + IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN + TEMP1 = ALPHA*Y(J) + TEMP2 = ALPHA*X(J) + DO 10 I = 1,J + A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2 + 10 CONTINUE + END IF + 20 CONTINUE + ELSE + DO 40 J = 1,N + IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN + TEMP1 = ALPHA*Y(JY) + TEMP2 = ALPHA*X(JX) + IX = KX + IY = KY + DO 30 I = 1,J + A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2 + IX = IX + INCX + IY = IY + INCY + 30 CONTINUE + END IF + JX = JX + INCX + JY = JY + INCY + 40 CONTINUE + END IF + ELSE +* +* Form A when A is stored in the lower triangle. +* + IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN + DO 60 J = 1,N + IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN + TEMP1 = ALPHA*Y(J) + TEMP2 = ALPHA*X(J) + DO 50 I = J,N + A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2 + 50 CONTINUE + END IF + 60 CONTINUE + ELSE + DO 80 J = 1,N + IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN + TEMP1 = ALPHA*Y(JY) + TEMP2 = ALPHA*X(JX) + IX = JX + IY = JY + DO 70 I = J,N + A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2 + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + END IF + JX = JX + INCX + JY = JY + INCY + 80 CONTINUE + END IF + END IF +* + RETURN +* +* End of SSYR2 +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/ssyr2k.f b/fortran_implementation/external_libraries/BLAS/SRC/ssyr2k.f new file mode 100644 index 0000000..027927a --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/ssyr2k.f @@ -0,0 +1,396 @@ +*> \brief \b SSYR2K +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* .. Scalar Arguments .. +* REAL ALPHA,BETA +* INTEGER K,LDA,LDB,LDC,N +* CHARACTER TRANS,UPLO +* .. +* .. Array Arguments .. +* REAL A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSYR2K performs one of the symmetric rank 2k operations +*> +*> C := alpha*A*B**T + alpha*B*A**T + beta*C, +*> +*> or +*> +*> C := alpha*A**T*B + alpha*B**T*A + beta*C, +*> +*> where alpha and beta are scalars, C is an n by n symmetric matrix +*> and A and B are n by k matrices in the first case and k by n +*> matrices in the second case. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the array C is to be referenced as +*> follows: +*> +*> UPLO = 'U' or 'u' Only the upper triangular part of C +*> is to be referenced. +*> +*> UPLO = 'L' or 'l' Only the lower triangular part of C +*> is to be referenced. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the operation to be performed as +*> follows: +*> +*> TRANS = 'N' or 'n' C := alpha*A*B**T + alpha*B*A**T + +*> beta*C. +*> +*> TRANS = 'T' or 't' C := alpha*A**T*B + alpha*B**T*A + +*> beta*C. +*> +*> TRANS = 'C' or 'c' C := alpha*A**T*B + alpha*B**T*A + +*> beta*C. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix C. N must be +*> at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry with TRANS = 'N' or 'n', K specifies the number +*> of columns of the matrices A and B, and on entry with +*> TRANS = 'T' or 't' or 'C' or 'c', K specifies the number +*> of rows of the matrices A and B. K must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is REAL +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is REAL array, dimension ( LDA, ka ), where ka is +*> k when TRANS = 'N' or 'n', and is n otherwise. +*> Before entry with TRANS = 'N' or 'n', the leading n by k +*> part of the array A must contain the matrix A, otherwise +*> the leading k by n part of the array A must contain the +*> matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When TRANS = 'N' or 'n' +*> then LDA must be at least max( 1, n ), otherwise LDA must +*> be at least max( 1, k ). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is REAL array, dimension ( LDB, kb ), where kb is +*> k when TRANS = 'N' or 'n', and is n otherwise. +*> Before entry with TRANS = 'N' or 'n', the leading n by k +*> part of the array B must contain the matrix B, otherwise +*> the leading k by n part of the array B must contain the +*> matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. When TRANS = 'N' or 'n' +*> then LDB must be at least max( 1, n ), otherwise LDB must +*> be at least max( 1, k ). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is REAL +*> On entry, BETA specifies the scalar beta. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is REAL array, dimension ( LDC, N ) +*> Before entry with UPLO = 'U' or 'u', the leading n by n +*> upper triangular part of the array C must contain the upper +*> triangular part of the symmetric matrix and the strictly +*> lower triangular part of C is not referenced. On exit, the +*> upper triangular part of the array C is overwritten by the +*> upper triangular part of the updated matrix. +*> Before entry with UPLO = 'L' or 'l', the leading n by n +*> lower triangular part of the array C must contain the lower +*> triangular part of the symmetric matrix and the strictly +*> upper triangular part of C is not referenced. On exit, the +*> lower triangular part of the array C is overwritten by the +*> lower triangular part of the updated matrix. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> On entry, LDC specifies the first dimension of C as declared +*> in the calling (sub) program. LDC must be at least +*> max( 1, n ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup her2k +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> +*> -- Written on 8-February-1989. +*> Jack Dongarra, Argonne National Laboratory. +*> Iain Duff, AERE Harwell. +*> Jeremy Du Croz, Numerical Algorithms Group Ltd. +*> Sven Hammarling, Numerical Algorithms Group Ltd. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE SSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* -- Reference BLAS level3 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + REAL ALPHA,BETA + INTEGER K,LDA,LDB,LDC,N + CHARACTER TRANS,UPLO +* .. +* .. Array Arguments .. + REAL A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + REAL TEMP1,TEMP2 + INTEGER I,INFO,J,L,NROWA + LOGICAL UPPER +* .. +* .. Parameters .. + REAL ONE,ZERO + PARAMETER (ONE=1.0E+0,ZERO=0.0E+0) +* .. +* +* Test the input parameters. +* + IF (LSAME(TRANS,'N')) THEN + NROWA = N + ELSE + NROWA = K + END IF + UPPER = LSAME(UPLO,'U') +* + INFO = 0 + IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN + INFO = 1 + ELSE IF ((.NOT.LSAME(TRANS,'N')) .AND. + + (.NOT.LSAME(TRANS,'T')) .AND. + + (.NOT.LSAME(TRANS,'C'))) THEN + INFO = 2 + ELSE IF (N.LT.0) THEN + INFO = 3 + ELSE IF (K.LT.0) THEN + INFO = 4 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 7 + ELSE IF (LDB.LT.MAX(1,NROWA)) THEN + INFO = 9 + ELSE IF (LDC.LT.MAX(1,N)) THEN + INFO = 12 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('SSYR2K',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR. + + (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + IF (UPPER) THEN + IF (BETA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,J + C(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1,N + DO 30 I = 1,J + C(I,J) = BETA*C(I,J) + 30 CONTINUE + 40 CONTINUE + END IF + ELSE + IF (BETA.EQ.ZERO) THEN + DO 60 J = 1,N + DO 50 I = J,N + C(I,J) = ZERO + 50 CONTINUE + 60 CONTINUE + ELSE + DO 80 J = 1,N + DO 70 I = J,N + C(I,J) = BETA*C(I,J) + 70 CONTINUE + 80 CONTINUE + END IF + END IF + RETURN + END IF +* +* Start the operations. +* + IF (LSAME(TRANS,'N')) THEN +* +* Form C := alpha*A*B**T + alpha*B*A**T + C. +* + IF (UPPER) THEN + DO 130 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 90 I = 1,J + C(I,J) = ZERO + 90 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 100 I = 1,J + C(I,J) = BETA*C(I,J) + 100 CONTINUE + END IF + DO 120 L = 1,K + IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN + TEMP1 = ALPHA*B(J,L) + TEMP2 = ALPHA*A(J,L) + DO 110 I = 1,J + C(I,J) = C(I,J) + A(I,L)*TEMP1 + + + B(I,L)*TEMP2 + 110 CONTINUE + END IF + 120 CONTINUE + 130 CONTINUE + ELSE + DO 180 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 140 I = J,N + C(I,J) = ZERO + 140 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 150 I = J,N + C(I,J) = BETA*C(I,J) + 150 CONTINUE + END IF + DO 170 L = 1,K + IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN + TEMP1 = ALPHA*B(J,L) + TEMP2 = ALPHA*A(J,L) + DO 160 I = J,N + C(I,J) = C(I,J) + A(I,L)*TEMP1 + + + B(I,L)*TEMP2 + 160 CONTINUE + END IF + 170 CONTINUE + 180 CONTINUE + END IF + ELSE +* +* Form C := alpha*A**T*B + alpha*B**T*A + C. +* + IF (UPPER) THEN + DO 210 J = 1,N + DO 200 I = 1,J + TEMP1 = ZERO + TEMP2 = ZERO + DO 190 L = 1,K + TEMP1 = TEMP1 + A(L,I)*B(L,J) + TEMP2 = TEMP2 + B(L,I)*A(L,J) + 190 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP1 + ALPHA*TEMP2 + ELSE + C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 + + + ALPHA*TEMP2 + END IF + 200 CONTINUE + 210 CONTINUE + ELSE + DO 240 J = 1,N + DO 230 I = J,N + TEMP1 = ZERO + TEMP2 = ZERO + DO 220 L = 1,K + TEMP1 = TEMP1 + A(L,I)*B(L,J) + TEMP2 = TEMP2 + B(L,I)*A(L,J) + 220 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP1 + ALPHA*TEMP2 + ELSE + C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 + + + ALPHA*TEMP2 + END IF + 230 CONTINUE + 240 CONTINUE + END IF + END IF +* + RETURN +* +* End of SSYR2K +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/ssyrk.f b/fortran_implementation/external_libraries/BLAS/SRC/ssyrk.f new file mode 100644 index 0000000..d1dcd12 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/ssyrk.f @@ -0,0 +1,361 @@ +*> \brief \b SSYRK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) +* +* .. Scalar Arguments .. +* REAL ALPHA,BETA +* INTEGER K,LDA,LDC,N +* CHARACTER TRANS,UPLO +* .. +* .. Array Arguments .. +* REAL A(LDA,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSYRK performs one of the symmetric rank k operations +*> +*> C := alpha*A*A**T + beta*C, +*> +*> or +*> +*> C := alpha*A**T*A + beta*C, +*> +*> where alpha and beta are scalars, C is an n by n symmetric matrix +*> and A is an n by k matrix in the first case and a k by n matrix +*> in the second case. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the array C is to be referenced as +*> follows: +*> +*> UPLO = 'U' or 'u' Only the upper triangular part of C +*> is to be referenced. +*> +*> UPLO = 'L' or 'l' Only the lower triangular part of C +*> is to be referenced. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the operation to be performed as +*> follows: +*> +*> TRANS = 'N' or 'n' C := alpha*A*A**T + beta*C. +*> +*> TRANS = 'T' or 't' C := alpha*A**T*A + beta*C. +*> +*> TRANS = 'C' or 'c' C := alpha*A**T*A + beta*C. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix C. N must be +*> at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry with TRANS = 'N' or 'n', K specifies the number +*> of columns of the matrix A, and on entry with +*> TRANS = 'T' or 't' or 'C' or 'c', K specifies the number +*> of rows of the matrix A. K must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is REAL +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is REAL array, dimension ( LDA, ka ), where ka is +*> k when TRANS = 'N' or 'n', and is n otherwise. +*> Before entry with TRANS = 'N' or 'n', the leading n by k +*> part of the array A must contain the matrix A, otherwise +*> the leading k by n part of the array A must contain the +*> matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When TRANS = 'N' or 'n' +*> then LDA must be at least max( 1, n ), otherwise LDA must +*> be at least max( 1, k ). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is REAL +*> On entry, BETA specifies the scalar beta. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is REAL array, dimension ( LDC, N ) +*> Before entry with UPLO = 'U' or 'u', the leading n by n +*> upper triangular part of the array C must contain the upper +*> triangular part of the symmetric matrix and the strictly +*> lower triangular part of C is not referenced. On exit, the +*> upper triangular part of the array C is overwritten by the +*> upper triangular part of the updated matrix. +*> Before entry with UPLO = 'L' or 'l', the leading n by n +*> lower triangular part of the array C must contain the lower +*> triangular part of the symmetric matrix and the strictly +*> upper triangular part of C is not referenced. On exit, the +*> lower triangular part of the array C is overwritten by the +*> lower triangular part of the updated matrix. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> On entry, LDC specifies the first dimension of C as declared +*> in the calling (sub) program. LDC must be at least +*> max( 1, n ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup herk +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> -- Written on 8-February-1989. +*> Jack Dongarra, Argonne National Laboratory. +*> Iain Duff, AERE Harwell. +*> Jeremy Du Croz, Numerical Algorithms Group Ltd. +*> Sven Hammarling, Numerical Algorithms Group Ltd. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE SSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) +* +* -- Reference BLAS level3 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + REAL ALPHA,BETA + INTEGER K,LDA,LDC,N + CHARACTER TRANS,UPLO +* .. +* .. Array Arguments .. + REAL A(LDA,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + REAL TEMP + INTEGER I,INFO,J,L,NROWA + LOGICAL UPPER +* .. +* .. Parameters .. + REAL ONE,ZERO + PARAMETER (ONE=1.0E+0,ZERO=0.0E+0) +* .. +* +* Test the input parameters. +* + IF (LSAME(TRANS,'N')) THEN + NROWA = N + ELSE + NROWA = K + END IF + UPPER = LSAME(UPLO,'U') +* + INFO = 0 + IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN + INFO = 1 + ELSE IF ((.NOT.LSAME(TRANS,'N')) .AND. + + (.NOT.LSAME(TRANS,'T')) .AND. + + (.NOT.LSAME(TRANS,'C'))) THEN + INFO = 2 + ELSE IF (N.LT.0) THEN + INFO = 3 + ELSE IF (K.LT.0) THEN + INFO = 4 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 7 + ELSE IF (LDC.LT.MAX(1,N)) THEN + INFO = 10 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('SSYRK ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR. + + (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + IF (UPPER) THEN + IF (BETA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,J + C(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1,N + DO 30 I = 1,J + C(I,J) = BETA*C(I,J) + 30 CONTINUE + 40 CONTINUE + END IF + ELSE + IF (BETA.EQ.ZERO) THEN + DO 60 J = 1,N + DO 50 I = J,N + C(I,J) = ZERO + 50 CONTINUE + 60 CONTINUE + ELSE + DO 80 J = 1,N + DO 70 I = J,N + C(I,J) = BETA*C(I,J) + 70 CONTINUE + 80 CONTINUE + END IF + END IF + RETURN + END IF +* +* Start the operations. +* + IF (LSAME(TRANS,'N')) THEN +* +* Form C := alpha*A*A**T + beta*C. +* + IF (UPPER) THEN + DO 130 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 90 I = 1,J + C(I,J) = ZERO + 90 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 100 I = 1,J + C(I,J) = BETA*C(I,J) + 100 CONTINUE + END IF + DO 120 L = 1,K + IF (A(J,L).NE.ZERO) THEN + TEMP = ALPHA*A(J,L) + DO 110 I = 1,J + C(I,J) = C(I,J) + TEMP*A(I,L) + 110 CONTINUE + END IF + 120 CONTINUE + 130 CONTINUE + ELSE + DO 180 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 140 I = J,N + C(I,J) = ZERO + 140 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 150 I = J,N + C(I,J) = BETA*C(I,J) + 150 CONTINUE + END IF + DO 170 L = 1,K + IF (A(J,L).NE.ZERO) THEN + TEMP = ALPHA*A(J,L) + DO 160 I = J,N + C(I,J) = C(I,J) + TEMP*A(I,L) + 160 CONTINUE + END IF + 170 CONTINUE + 180 CONTINUE + END IF + ELSE +* +* Form C := alpha*A**T*A + beta*C. +* + IF (UPPER) THEN + DO 210 J = 1,N + DO 200 I = 1,J + TEMP = ZERO + DO 190 L = 1,K + TEMP = TEMP + A(L,I)*A(L,J) + 190 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 200 CONTINUE + 210 CONTINUE + ELSE + DO 240 J = 1,N + DO 230 I = J,N + TEMP = ZERO + DO 220 L = 1,K + TEMP = TEMP + A(L,I)*A(L,J) + 220 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 230 CONTINUE + 240 CONTINUE + END IF + END IF +* + RETURN +* +* End of SSYRK +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/stbmv.f b/fortran_implementation/external_libraries/BLAS/SRC/stbmv.f new file mode 100644 index 0000000..1af11e4 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/stbmv.f @@ -0,0 +1,397 @@ +*> \brief \b STBMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE STBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,K,LDA,N +* CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. +* REAL A(LDA,*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> STBMV performs one of the matrix-vector operations +*> +*> x := A*x, or x := A**T*x, +*> +*> where x is an n element vector and A is an n by n unit, or non-unit, +*> upper or lower triangular band matrix, with ( k + 1 ) diagonals. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the matrix is an upper or +*> lower triangular matrix as follows: +*> +*> UPLO = 'U' or 'u' A is an upper triangular matrix. +*> +*> UPLO = 'L' or 'l' A is a lower triangular matrix. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the operation to be performed as +*> follows: +*> +*> TRANS = 'N' or 'n' x := A*x. +*> +*> TRANS = 'T' or 't' x := A**T*x. +*> +*> TRANS = 'C' or 'c' x := A**T*x. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> On entry, DIAG specifies whether or not A is unit +*> triangular as follows: +*> +*> DIAG = 'U' or 'u' A is assumed to be unit triangular. +*> +*> DIAG = 'N' or 'n' A is not assumed to be unit +*> triangular. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry with UPLO = 'U' or 'u', K specifies the number of +*> super-diagonals of the matrix A. +*> On entry with UPLO = 'L' or 'l', K specifies the number of +*> sub-diagonals of the matrix A. +*> K must satisfy 0 .le. K. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is REAL array, dimension ( LDA, N ) +*> Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) +*> by n part of the array A must contain the upper triangular +*> band part of the matrix of coefficients, supplied column by +*> column, with the leading diagonal of the matrix in row +*> ( k + 1 ) of the array, the first super-diagonal starting at +*> position 2 in row k, and so on. The top left k by k triangle +*> of the array A is not referenced. +*> The following program segment will transfer an upper +*> triangular band matrix from conventional full matrix storage +*> to band storage: +*> +*> DO 20, J = 1, N +*> M = K + 1 - J +*> DO 10, I = MAX( 1, J - K ), J +*> A( M + I, J ) = matrix( I, J ) +*> 10 CONTINUE +*> 20 CONTINUE +*> +*> Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) +*> by n part of the array A must contain the lower triangular +*> band part of the matrix of coefficients, supplied column by +*> column, with the leading diagonal of the matrix in row 1 of +*> the array, the first sub-diagonal starting at position 1 in +*> row 2, and so on. The bottom right k by k triangle of the +*> array A is not referenced. +*> The following program segment will transfer a lower +*> triangular band matrix from conventional full matrix storage +*> to band storage: +*> +*> DO 20, J = 1, N +*> M = 1 - J +*> DO 10, I = J, MIN( N, J + K ) +*> A( M + I, J ) = matrix( I, J ) +*> 10 CONTINUE +*> 20 CONTINUE +*> +*> Note that when DIAG = 'U' or 'u' the elements of the array A +*> corresponding to the diagonal elements of the matrix are not +*> referenced, but are assumed to be unity. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> ( k + 1 ). +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is REAL array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element vector x. On exit, X is overwritten with the +*> transformed vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup tbmv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> The vector and matrix arguments are not referenced when N = 0, or M = 0 +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE STBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,K,LDA,N + CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. + REAL A(LDA,*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO + PARAMETER (ZERO=0.0E+0) +* .. +* .. Local Scalars .. + REAL TEMP + INTEGER I,INFO,IX,J,JX,KPLUS1,KX,L + LOGICAL NOUNIT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX,MIN +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (.NOT.LSAME(TRANS,'N') .AND. + + .NOT.LSAME(TRANS,'T') .AND. + + .NOT.LSAME(TRANS,'C')) THEN + INFO = 2 + ELSE IF (.NOT.LSAME(DIAG,'U') .AND. + + .NOT.LSAME(DIAG,'N')) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (K.LT.0) THEN + INFO = 5 + ELSE IF (LDA.LT. (K+1)) THEN + INFO = 7 + ELSE IF (INCX.EQ.0) THEN + INFO = 9 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('STBMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (N.EQ.0) RETURN +* + NOUNIT = LSAME(DIAG,'N') +* +* Set up the start point in X if the increment is not unity. This +* will be ( N - 1 )*INCX too small for descending loops. +* + IF (INCX.LE.0) THEN + KX = 1 - (N-1)*INCX + ELSE IF (INCX.NE.1) THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* + IF (LSAME(TRANS,'N')) THEN +* +* Form x := A*x. +* + IF (LSAME(UPLO,'U')) THEN + KPLUS1 = K + 1 + IF (INCX.EQ.1) THEN + DO 20 J = 1,N + IF (X(J).NE.ZERO) THEN + TEMP = X(J) + L = KPLUS1 - J + DO 10 I = MAX(1,J-K),J - 1 + X(I) = X(I) + TEMP*A(L+I,J) + 10 CONTINUE + IF (NOUNIT) X(J) = X(J)*A(KPLUS1,J) + END IF + 20 CONTINUE + ELSE + JX = KX + DO 40 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = X(JX) + IX = KX + L = KPLUS1 - J + DO 30 I = MAX(1,J-K),J - 1 + X(IX) = X(IX) + TEMP*A(L+I,J) + IX = IX + INCX + 30 CONTINUE + IF (NOUNIT) X(JX) = X(JX)*A(KPLUS1,J) + END IF + JX = JX + INCX + IF (J.GT.K) KX = KX + INCX + 40 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 60 J = N,1,-1 + IF (X(J).NE.ZERO) THEN + TEMP = X(J) + L = 1 - J + DO 50 I = MIN(N,J+K),J + 1,-1 + X(I) = X(I) + TEMP*A(L+I,J) + 50 CONTINUE + IF (NOUNIT) X(J) = X(J)*A(1,J) + END IF + 60 CONTINUE + ELSE + KX = KX + (N-1)*INCX + JX = KX + DO 80 J = N,1,-1 + IF (X(JX).NE.ZERO) THEN + TEMP = X(JX) + IX = KX + L = 1 - J + DO 70 I = MIN(N,J+K),J + 1,-1 + X(IX) = X(IX) + TEMP*A(L+I,J) + IX = IX - INCX + 70 CONTINUE + IF (NOUNIT) X(JX) = X(JX)*A(1,J) + END IF + JX = JX - INCX + IF ((N-J).GE.K) KX = KX - INCX + 80 CONTINUE + END IF + END IF + ELSE +* +* Form x := A**T*x. +* + IF (LSAME(UPLO,'U')) THEN + KPLUS1 = K + 1 + IF (INCX.EQ.1) THEN + DO 100 J = N,1,-1 + TEMP = X(J) + L = KPLUS1 - J + IF (NOUNIT) TEMP = TEMP*A(KPLUS1,J) + DO 90 I = J - 1,MAX(1,J-K),-1 + TEMP = TEMP + A(L+I,J)*X(I) + 90 CONTINUE + X(J) = TEMP + 100 CONTINUE + ELSE + KX = KX + (N-1)*INCX + JX = KX + DO 120 J = N,1,-1 + TEMP = X(JX) + KX = KX - INCX + IX = KX + L = KPLUS1 - J + IF (NOUNIT) TEMP = TEMP*A(KPLUS1,J) + DO 110 I = J - 1,MAX(1,J-K),-1 + TEMP = TEMP + A(L+I,J)*X(IX) + IX = IX - INCX + 110 CONTINUE + X(JX) = TEMP + JX = JX - INCX + 120 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 140 J = 1,N + TEMP = X(J) + L = 1 - J + IF (NOUNIT) TEMP = TEMP*A(1,J) + DO 130 I = J + 1,MIN(N,J+K) + TEMP = TEMP + A(L+I,J)*X(I) + 130 CONTINUE + X(J) = TEMP + 140 CONTINUE + ELSE + JX = KX + DO 160 J = 1,N + TEMP = X(JX) + KX = KX + INCX + IX = KX + L = 1 - J + IF (NOUNIT) TEMP = TEMP*A(1,J) + DO 150 I = J + 1,MIN(N,J+K) + TEMP = TEMP + A(L+I,J)*X(IX) + IX = IX + INCX + 150 CONTINUE + X(JX) = TEMP + JX = JX + INCX + 160 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of STBMV +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/stbsv.f b/fortran_implementation/external_libraries/BLAS/SRC/stbsv.f new file mode 100644 index 0000000..24d1105 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/stbsv.f @@ -0,0 +1,400 @@ +*> \brief \b STBSV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE STBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,K,LDA,N +* CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. +* REAL A(LDA,*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> STBSV solves one of the systems of equations +*> +*> A*x = b, or A**T*x = b, +*> +*> where b and x are n element vectors and A is an n by n unit, or +*> non-unit, upper or lower triangular band matrix, with ( k + 1 ) +*> diagonals. +*> +*> No test for singularity or near-singularity is included in this +*> routine. Such tests must be performed before calling this routine. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the matrix is an upper or +*> lower triangular matrix as follows: +*> +*> UPLO = 'U' or 'u' A is an upper triangular matrix. +*> +*> UPLO = 'L' or 'l' A is a lower triangular matrix. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the equations to be solved as +*> follows: +*> +*> TRANS = 'N' or 'n' A*x = b. +*> +*> TRANS = 'T' or 't' A**T*x = b. +*> +*> TRANS = 'C' or 'c' A**T*x = b. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> On entry, DIAG specifies whether or not A is unit +*> triangular as follows: +*> +*> DIAG = 'U' or 'u' A is assumed to be unit triangular. +*> +*> DIAG = 'N' or 'n' A is not assumed to be unit +*> triangular. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry with UPLO = 'U' or 'u', K specifies the number of +*> super-diagonals of the matrix A. +*> On entry with UPLO = 'L' or 'l', K specifies the number of +*> sub-diagonals of the matrix A. +*> K must satisfy 0 .le. K. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is REAL array, dimension ( LDA, N ) +*> Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) +*> by n part of the array A must contain the upper triangular +*> band part of the matrix of coefficients, supplied column by +*> column, with the leading diagonal of the matrix in row +*> ( k + 1 ) of the array, the first super-diagonal starting at +*> position 2 in row k, and so on. The top left k by k triangle +*> of the array A is not referenced. +*> The following program segment will transfer an upper +*> triangular band matrix from conventional full matrix storage +*> to band storage: +*> +*> DO 20, J = 1, N +*> M = K + 1 - J +*> DO 10, I = MAX( 1, J - K ), J +*> A( M + I, J ) = matrix( I, J ) +*> 10 CONTINUE +*> 20 CONTINUE +*> +*> Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) +*> by n part of the array A must contain the lower triangular +*> band part of the matrix of coefficients, supplied column by +*> column, with the leading diagonal of the matrix in row 1 of +*> the array, the first sub-diagonal starting at position 1 in +*> row 2, and so on. The bottom right k by k triangle of the +*> array A is not referenced. +*> The following program segment will transfer a lower +*> triangular band matrix from conventional full matrix storage +*> to band storage: +*> +*> DO 20, J = 1, N +*> M = 1 - J +*> DO 10, I = J, MIN( N, J + K ) +*> A( M + I, J ) = matrix( I, J ) +*> 10 CONTINUE +*> 20 CONTINUE +*> +*> Note that when DIAG = 'U' or 'u' the elements of the array A +*> corresponding to the diagonal elements of the matrix are not +*> referenced, but are assumed to be unity. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> ( k + 1 ). +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is REAL array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element right-hand side vector b. On exit, X is overwritten +*> with the solution vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup tbsv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE STBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,K,LDA,N + CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. + REAL A(LDA,*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO + PARAMETER (ZERO=0.0E+0) +* .. +* .. Local Scalars .. + REAL TEMP + INTEGER I,INFO,IX,J,JX,KPLUS1,KX,L + LOGICAL NOUNIT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX,MIN +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (.NOT.LSAME(TRANS,'N') .AND. + + .NOT.LSAME(TRANS,'T') .AND. + + .NOT.LSAME(TRANS,'C')) THEN + INFO = 2 + ELSE IF (.NOT.LSAME(DIAG,'U') .AND. + + .NOT.LSAME(DIAG,'N')) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (K.LT.0) THEN + INFO = 5 + ELSE IF (LDA.LT. (K+1)) THEN + INFO = 7 + ELSE IF (INCX.EQ.0) THEN + INFO = 9 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('STBSV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (N.EQ.0) RETURN +* + NOUNIT = LSAME(DIAG,'N') +* +* Set up the start point in X if the increment is not unity. This +* will be ( N - 1 )*INCX too small for descending loops. +* + IF (INCX.LE.0) THEN + KX = 1 - (N-1)*INCX + ELSE IF (INCX.NE.1) THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of A are +* accessed by sequentially with one pass through A. +* + IF (LSAME(TRANS,'N')) THEN +* +* Form x := inv( A )*x. +* + IF (LSAME(UPLO,'U')) THEN + KPLUS1 = K + 1 + IF (INCX.EQ.1) THEN + DO 20 J = N,1,-1 + IF (X(J).NE.ZERO) THEN + L = KPLUS1 - J + IF (NOUNIT) X(J) = X(J)/A(KPLUS1,J) + TEMP = X(J) + DO 10 I = J - 1,MAX(1,J-K),-1 + X(I) = X(I) - TEMP*A(L+I,J) + 10 CONTINUE + END IF + 20 CONTINUE + ELSE + KX = KX + (N-1)*INCX + JX = KX + DO 40 J = N,1,-1 + KX = KX - INCX + IF (X(JX).NE.ZERO) THEN + IX = KX + L = KPLUS1 - J + IF (NOUNIT) X(JX) = X(JX)/A(KPLUS1,J) + TEMP = X(JX) + DO 30 I = J - 1,MAX(1,J-K),-1 + X(IX) = X(IX) - TEMP*A(L+I,J) + IX = IX - INCX + 30 CONTINUE + END IF + JX = JX - INCX + 40 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 60 J = 1,N + IF (X(J).NE.ZERO) THEN + L = 1 - J + IF (NOUNIT) X(J) = X(J)/A(1,J) + TEMP = X(J) + DO 50 I = J + 1,MIN(N,J+K) + X(I) = X(I) - TEMP*A(L+I,J) + 50 CONTINUE + END IF + 60 CONTINUE + ELSE + JX = KX + DO 80 J = 1,N + KX = KX + INCX + IF (X(JX).NE.ZERO) THEN + IX = KX + L = 1 - J + IF (NOUNIT) X(JX) = X(JX)/A(1,J) + TEMP = X(JX) + DO 70 I = J + 1,MIN(N,J+K) + X(IX) = X(IX) - TEMP*A(L+I,J) + IX = IX + INCX + 70 CONTINUE + END IF + JX = JX + INCX + 80 CONTINUE + END IF + END IF + ELSE +* +* Form x := inv( A**T)*x. +* + IF (LSAME(UPLO,'U')) THEN + KPLUS1 = K + 1 + IF (INCX.EQ.1) THEN + DO 100 J = 1,N + TEMP = X(J) + L = KPLUS1 - J + DO 90 I = MAX(1,J-K),J - 1 + TEMP = TEMP - A(L+I,J)*X(I) + 90 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(KPLUS1,J) + X(J) = TEMP + 100 CONTINUE + ELSE + JX = KX + DO 120 J = 1,N + TEMP = X(JX) + IX = KX + L = KPLUS1 - J + DO 110 I = MAX(1,J-K),J - 1 + TEMP = TEMP - A(L+I,J)*X(IX) + IX = IX + INCX + 110 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(KPLUS1,J) + X(JX) = TEMP + JX = JX + INCX + IF (J.GT.K) KX = KX + INCX + 120 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 140 J = N,1,-1 + TEMP = X(J) + L = 1 - J + DO 130 I = MIN(N,J+K),J + 1,-1 + TEMP = TEMP - A(L+I,J)*X(I) + 130 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(1,J) + X(J) = TEMP + 140 CONTINUE + ELSE + KX = KX + (N-1)*INCX + JX = KX + DO 160 J = N,1,-1 + TEMP = X(JX) + IX = KX + L = 1 - J + DO 150 I = MIN(N,J+K),J + 1,-1 + TEMP = TEMP - A(L+I,J)*X(IX) + IX = IX - INCX + 150 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(1,J) + X(JX) = TEMP + JX = JX - INCX + IF ((N-J).GE.K) KX = KX - INCX + 160 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of STBSV +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/stpmv.f b/fortran_implementation/external_libraries/BLAS/SRC/stpmv.f new file mode 100644 index 0000000..b36ecd3 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/stpmv.f @@ -0,0 +1,351 @@ +*> \brief \b STPMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE STPMV(UPLO,TRANS,DIAG,N,AP,X,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,N +* CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. +* REAL AP(*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> STPMV performs one of the matrix-vector operations +*> +*> x := A*x, or x := A**T*x, +*> +*> where x is an n element vector and A is an n by n unit, or non-unit, +*> upper or lower triangular matrix, supplied in packed form. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the matrix is an upper or +*> lower triangular matrix as follows: +*> +*> UPLO = 'U' or 'u' A is an upper triangular matrix. +*> +*> UPLO = 'L' or 'l' A is a lower triangular matrix. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the operation to be performed as +*> follows: +*> +*> TRANS = 'N' or 'n' x := A*x. +*> +*> TRANS = 'T' or 't' x := A**T*x. +*> +*> TRANS = 'C' or 'c' x := A**T*x. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> On entry, DIAG specifies whether or not A is unit +*> triangular as follows: +*> +*> DIAG = 'U' or 'u' A is assumed to be unit triangular. +*> +*> DIAG = 'N' or 'n' A is not assumed to be unit +*> triangular. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] AP +*> \verbatim +*> AP is REAL array, dimension at least +*> ( ( n*( n + 1 ) )/2 ). +*> Before entry with UPLO = 'U' or 'u', the array AP must +*> contain the upper triangular matrix packed sequentially, +*> column by column, so that AP( 1 ) contains a( 1, 1 ), +*> AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) +*> respectively, and so on. +*> Before entry with UPLO = 'L' or 'l', the array AP must +*> contain the lower triangular matrix packed sequentially, +*> column by column, so that AP( 1 ) contains a( 1, 1 ), +*> AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) +*> respectively, and so on. +*> Note that when DIAG = 'U' or 'u', the diagonal elements of +*> A are not referenced, but are assumed to be unity. +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is REAL array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element vector x. On exit, X is overwritten with the +*> transformed vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup tpmv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> The vector and matrix arguments are not referenced when N = 0, or M = 0 +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE STPMV(UPLO,TRANS,DIAG,N,AP,X,INCX) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,N + CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. + REAL AP(*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO + PARAMETER (ZERO=0.0E+0) +* .. +* .. Local Scalars .. + REAL TEMP + INTEGER I,INFO,IX,J,JX,K,KK,KX + LOGICAL NOUNIT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (.NOT.LSAME(TRANS,'N') .AND. + + .NOT.LSAME(TRANS,'T') .AND. + + .NOT.LSAME(TRANS,'C')) THEN + INFO = 2 + ELSE IF (.NOT.LSAME(DIAG,'U') .AND. + + .NOT.LSAME(DIAG,'N')) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (INCX.EQ.0) THEN + INFO = 7 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('STPMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (N.EQ.0) RETURN +* + NOUNIT = LSAME(DIAG,'N') +* +* Set up the start point in X if the increment is not unity. This +* will be ( N - 1 )*INCX too small for descending loops. +* + IF (INCX.LE.0) THEN + KX = 1 - (N-1)*INCX + ELSE IF (INCX.NE.1) THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of AP are +* accessed sequentially with one pass through AP. +* + IF (LSAME(TRANS,'N')) THEN +* +* Form x:= A*x. +* + IF (LSAME(UPLO,'U')) THEN + KK = 1 + IF (INCX.EQ.1) THEN + DO 20 J = 1,N + IF (X(J).NE.ZERO) THEN + TEMP = X(J) + K = KK + DO 10 I = 1,J - 1 + X(I) = X(I) + TEMP*AP(K) + K = K + 1 + 10 CONTINUE + IF (NOUNIT) X(J) = X(J)*AP(KK+J-1) + END IF + KK = KK + J + 20 CONTINUE + ELSE + JX = KX + DO 40 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = X(JX) + IX = KX + DO 30 K = KK,KK + J - 2 + X(IX) = X(IX) + TEMP*AP(K) + IX = IX + INCX + 30 CONTINUE + IF (NOUNIT) X(JX) = X(JX)*AP(KK+J-1) + END IF + JX = JX + INCX + KK = KK + J + 40 CONTINUE + END IF + ELSE + KK = (N* (N+1))/2 + IF (INCX.EQ.1) THEN + DO 60 J = N,1,-1 + IF (X(J).NE.ZERO) THEN + TEMP = X(J) + K = KK + DO 50 I = N,J + 1,-1 + X(I) = X(I) + TEMP*AP(K) + K = K - 1 + 50 CONTINUE + IF (NOUNIT) X(J) = X(J)*AP(KK-N+J) + END IF + KK = KK - (N-J+1) + 60 CONTINUE + ELSE + KX = KX + (N-1)*INCX + JX = KX + DO 80 J = N,1,-1 + IF (X(JX).NE.ZERO) THEN + TEMP = X(JX) + IX = KX + DO 70 K = KK,KK - (N- (J+1)),-1 + X(IX) = X(IX) + TEMP*AP(K) + IX = IX - INCX + 70 CONTINUE + IF (NOUNIT) X(JX) = X(JX)*AP(KK-N+J) + END IF + JX = JX - INCX + KK = KK - (N-J+1) + 80 CONTINUE + END IF + END IF + ELSE +* +* Form x := A**T*x. +* + IF (LSAME(UPLO,'U')) THEN + KK = (N* (N+1))/2 + IF (INCX.EQ.1) THEN + DO 100 J = N,1,-1 + TEMP = X(J) + IF (NOUNIT) TEMP = TEMP*AP(KK) + K = KK - 1 + DO 90 I = J - 1,1,-1 + TEMP = TEMP + AP(K)*X(I) + K = K - 1 + 90 CONTINUE + X(J) = TEMP + KK = KK - J + 100 CONTINUE + ELSE + JX = KX + (N-1)*INCX + DO 120 J = N,1,-1 + TEMP = X(JX) + IX = JX + IF (NOUNIT) TEMP = TEMP*AP(KK) + DO 110 K = KK - 1,KK - J + 1,-1 + IX = IX - INCX + TEMP = TEMP + AP(K)*X(IX) + 110 CONTINUE + X(JX) = TEMP + JX = JX - INCX + KK = KK - J + 120 CONTINUE + END IF + ELSE + KK = 1 + IF (INCX.EQ.1) THEN + DO 140 J = 1,N + TEMP = X(J) + IF (NOUNIT) TEMP = TEMP*AP(KK) + K = KK + 1 + DO 130 I = J + 1,N + TEMP = TEMP + AP(K)*X(I) + K = K + 1 + 130 CONTINUE + X(J) = TEMP + KK = KK + (N-J+1) + 140 CONTINUE + ELSE + JX = KX + DO 160 J = 1,N + TEMP = X(JX) + IX = JX + IF (NOUNIT) TEMP = TEMP*AP(KK) + DO 150 K = KK + 1,KK + N - J + IX = IX + INCX + TEMP = TEMP + AP(K)*X(IX) + 150 CONTINUE + X(JX) = TEMP + JX = JX + INCX + KK = KK + (N-J+1) + 160 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of STPMV +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/stpsv.f b/fortran_implementation/external_libraries/BLAS/SRC/stpsv.f new file mode 100644 index 0000000..b409964 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/stpsv.f @@ -0,0 +1,353 @@ +*> \brief \b STPSV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE STPSV(UPLO,TRANS,DIAG,N,AP,X,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,N +* CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. +* REAL AP(*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> STPSV solves one of the systems of equations +*> +*> A*x = b, or A**T*x = b, +*> +*> where b and x are n element vectors and A is an n by n unit, or +*> non-unit, upper or lower triangular matrix, supplied in packed form. +*> +*> No test for singularity or near-singularity is included in this +*> routine. Such tests must be performed before calling this routine. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the matrix is an upper or +*> lower triangular matrix as follows: +*> +*> UPLO = 'U' or 'u' A is an upper triangular matrix. +*> +*> UPLO = 'L' or 'l' A is a lower triangular matrix. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the equations to be solved as +*> follows: +*> +*> TRANS = 'N' or 'n' A*x = b. +*> +*> TRANS = 'T' or 't' A**T*x = b. +*> +*> TRANS = 'C' or 'c' A**T*x = b. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> On entry, DIAG specifies whether or not A is unit +*> triangular as follows: +*> +*> DIAG = 'U' or 'u' A is assumed to be unit triangular. +*> +*> DIAG = 'N' or 'n' A is not assumed to be unit +*> triangular. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] AP +*> \verbatim +*> AP is REAL array, dimension at least +*> ( ( n*( n + 1 ) )/2 ). +*> Before entry with UPLO = 'U' or 'u', the array AP must +*> contain the upper triangular matrix packed sequentially, +*> column by column, so that AP( 1 ) contains a( 1, 1 ), +*> AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) +*> respectively, and so on. +*> Before entry with UPLO = 'L' or 'l', the array AP must +*> contain the lower triangular matrix packed sequentially, +*> column by column, so that AP( 1 ) contains a( 1, 1 ), +*> AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) +*> respectively, and so on. +*> Note that when DIAG = 'U' or 'u', the diagonal elements of +*> A are not referenced, but are assumed to be unity. +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is REAL array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element right-hand side vector b. On exit, X is overwritten +*> with the solution vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup tpsv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE STPSV(UPLO,TRANS,DIAG,N,AP,X,INCX) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,N + CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. + REAL AP(*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO + PARAMETER (ZERO=0.0E+0) +* .. +* .. Local Scalars .. + REAL TEMP + INTEGER I,INFO,IX,J,JX,K,KK,KX + LOGICAL NOUNIT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (.NOT.LSAME(TRANS,'N') .AND. + + .NOT.LSAME(TRANS,'T') .AND. + + .NOT.LSAME(TRANS,'C')) THEN + INFO = 2 + ELSE IF (.NOT.LSAME(DIAG,'U') .AND. + + .NOT.LSAME(DIAG,'N')) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (INCX.EQ.0) THEN + INFO = 7 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('STPSV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (N.EQ.0) RETURN +* + NOUNIT = LSAME(DIAG,'N') +* +* Set up the start point in X if the increment is not unity. This +* will be ( N - 1 )*INCX too small for descending loops. +* + IF (INCX.LE.0) THEN + KX = 1 - (N-1)*INCX + ELSE IF (INCX.NE.1) THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of AP are +* accessed sequentially with one pass through AP. +* + IF (LSAME(TRANS,'N')) THEN +* +* Form x := inv( A )*x. +* + IF (LSAME(UPLO,'U')) THEN + KK = (N* (N+1))/2 + IF (INCX.EQ.1) THEN + DO 20 J = N,1,-1 + IF (X(J).NE.ZERO) THEN + IF (NOUNIT) X(J) = X(J)/AP(KK) + TEMP = X(J) + K = KK - 1 + DO 10 I = J - 1,1,-1 + X(I) = X(I) - TEMP*AP(K) + K = K - 1 + 10 CONTINUE + END IF + KK = KK - J + 20 CONTINUE + ELSE + JX = KX + (N-1)*INCX + DO 40 J = N,1,-1 + IF (X(JX).NE.ZERO) THEN + IF (NOUNIT) X(JX) = X(JX)/AP(KK) + TEMP = X(JX) + IX = JX + DO 30 K = KK - 1,KK - J + 1,-1 + IX = IX - INCX + X(IX) = X(IX) - TEMP*AP(K) + 30 CONTINUE + END IF + JX = JX - INCX + KK = KK - J + 40 CONTINUE + END IF + ELSE + KK = 1 + IF (INCX.EQ.1) THEN + DO 60 J = 1,N + IF (X(J).NE.ZERO) THEN + IF (NOUNIT) X(J) = X(J)/AP(KK) + TEMP = X(J) + K = KK + 1 + DO 50 I = J + 1,N + X(I) = X(I) - TEMP*AP(K) + K = K + 1 + 50 CONTINUE + END IF + KK = KK + (N-J+1) + 60 CONTINUE + ELSE + JX = KX + DO 80 J = 1,N + IF (X(JX).NE.ZERO) THEN + IF (NOUNIT) X(JX) = X(JX)/AP(KK) + TEMP = X(JX) + IX = JX + DO 70 K = KK + 1,KK + N - J + IX = IX + INCX + X(IX) = X(IX) - TEMP*AP(K) + 70 CONTINUE + END IF + JX = JX + INCX + KK = KK + (N-J+1) + 80 CONTINUE + END IF + END IF + ELSE +* +* Form x := inv( A**T )*x. +* + IF (LSAME(UPLO,'U')) THEN + KK = 1 + IF (INCX.EQ.1) THEN + DO 100 J = 1,N + TEMP = X(J) + K = KK + DO 90 I = 1,J - 1 + TEMP = TEMP - AP(K)*X(I) + K = K + 1 + 90 CONTINUE + IF (NOUNIT) TEMP = TEMP/AP(KK+J-1) + X(J) = TEMP + KK = KK + J + 100 CONTINUE + ELSE + JX = KX + DO 120 J = 1,N + TEMP = X(JX) + IX = KX + DO 110 K = KK,KK + J - 2 + TEMP = TEMP - AP(K)*X(IX) + IX = IX + INCX + 110 CONTINUE + IF (NOUNIT) TEMP = TEMP/AP(KK+J-1) + X(JX) = TEMP + JX = JX + INCX + KK = KK + J + 120 CONTINUE + END IF + ELSE + KK = (N* (N+1))/2 + IF (INCX.EQ.1) THEN + DO 140 J = N,1,-1 + TEMP = X(J) + K = KK + DO 130 I = N,J + 1,-1 + TEMP = TEMP - AP(K)*X(I) + K = K - 1 + 130 CONTINUE + IF (NOUNIT) TEMP = TEMP/AP(KK-N+J) + X(J) = TEMP + KK = KK - (N-J+1) + 140 CONTINUE + ELSE + KX = KX + (N-1)*INCX + JX = KX + DO 160 J = N,1,-1 + TEMP = X(JX) + IX = KX + DO 150 K = KK,KK - (N- (J+1)),-1 + TEMP = TEMP - AP(K)*X(IX) + IX = IX - INCX + 150 CONTINUE + IF (NOUNIT) TEMP = TEMP/AP(KK-N+J) + X(JX) = TEMP + JX = JX - INCX + KK = KK - (N-J+1) + 160 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of STPSV +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/strmm.f b/fortran_implementation/external_libraries/BLAS/SRC/strmm.f new file mode 100644 index 0000000..1139998 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/strmm.f @@ -0,0 +1,413 @@ +*> \brief \b STRMM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE STRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +* +* .. Scalar Arguments .. +* REAL ALPHA +* INTEGER LDA,LDB,M,N +* CHARACTER DIAG,SIDE,TRANSA,UPLO +* .. +* .. Array Arguments .. +* REAL A(LDA,*),B(LDB,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> STRMM performs one of the matrix-matrix operations +*> +*> B := alpha*op( A )*B, or B := alpha*B*op( A ), +*> +*> where alpha is a scalar, B is an m by n matrix, A is a unit, or +*> non-unit, upper or lower triangular matrix and op( A ) is one of +*> +*> op( A ) = A or op( A ) = A**T. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> On entry, SIDE specifies whether op( A ) multiplies B from +*> the left or right as follows: +*> +*> SIDE = 'L' or 'l' B := alpha*op( A )*B. +*> +*> SIDE = 'R' or 'r' B := alpha*B*op( A ). +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the matrix A is an upper or +*> lower triangular matrix as follows: +*> +*> UPLO = 'U' or 'u' A is an upper triangular matrix. +*> +*> UPLO = 'L' or 'l' A is a lower triangular matrix. +*> \endverbatim +*> +*> \param[in] TRANSA +*> \verbatim +*> TRANSA is CHARACTER*1 +*> On entry, TRANSA specifies the form of op( A ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSA = 'N' or 'n' op( A ) = A. +*> +*> TRANSA = 'T' or 't' op( A ) = A**T. +*> +*> TRANSA = 'C' or 'c' op( A ) = A**T. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> On entry, DIAG specifies whether or not A is unit triangular +*> as follows: +*> +*> DIAG = 'U' or 'u' A is assumed to be unit triangular. +*> +*> DIAG = 'N' or 'n' A is not assumed to be unit +*> triangular. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of B. M must be at +*> least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of B. N must be +*> at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is REAL +*> On entry, ALPHA specifies the scalar alpha. When alpha is +*> zero then A is not referenced and B need not be set before +*> entry. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is REAL array, dimension ( LDA, k ), where k is m +*> when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. +*> Before entry with UPLO = 'U' or 'u', the leading k by k +*> upper triangular part of the array A must contain the upper +*> triangular matrix and the strictly lower triangular part of +*> A is not referenced. +*> Before entry with UPLO = 'L' or 'l', the leading k by k +*> lower triangular part of the array A must contain the lower +*> triangular matrix and the strictly upper triangular part of +*> A is not referenced. +*> Note that when DIAG = 'U' or 'u', the diagonal elements of +*> A are not referenced either, but are assumed to be unity. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When SIDE = 'L' or 'l' then +*> LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' +*> then LDA must be at least max( 1, n ). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is REAL array, dimension ( LDB, N ) +*> Before entry, the leading m by n part of the array B must +*> contain the matrix B, and on exit is overwritten by the +*> transformed matrix. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. LDB must be at least +*> max( 1, m ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup trmm +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> -- Written on 8-February-1989. +*> Jack Dongarra, Argonne National Laboratory. +*> Iain Duff, AERE Harwell. +*> Jeremy Du Croz, Numerical Algorithms Group Ltd. +*> Sven Hammarling, Numerical Algorithms Group Ltd. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE STRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +* +* -- Reference BLAS level3 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + REAL ALPHA + INTEGER LDA,LDB,M,N + CHARACTER DIAG,SIDE,TRANSA,UPLO +* .. +* .. Array Arguments .. + REAL A(LDA,*),B(LDB,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + REAL TEMP + INTEGER I,INFO,J,K,NROWA + LOGICAL LSIDE,NOUNIT,UPPER +* .. +* .. Parameters .. + REAL ONE,ZERO + PARAMETER (ONE=1.0E+0,ZERO=0.0E+0) +* .. +* +* Test the input parameters. +* + LSIDE = LSAME(SIDE,'L') + IF (LSIDE) THEN + NROWA = M + ELSE + NROWA = N + END IF + NOUNIT = LSAME(DIAG,'N') + UPPER = LSAME(UPLO,'U') +* + INFO = 0 + IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN + INFO = 1 + ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN + INFO = 2 + ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND. + + (.NOT.LSAME(TRANSA,'T')) .AND. + + (.NOT.LSAME(TRANSA,'C'))) THEN + INFO = 3 + ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. + + (.NOT.LSAME(DIAG,'N'))) THEN + INFO = 4 + ELSE IF (M.LT.0) THEN + INFO = 5 + ELSE IF (N.LT.0) THEN + INFO = 6 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 9 + ELSE IF (LDB.LT.MAX(1,M)) THEN + INFO = 11 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('STRMM ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (M.EQ.0 .OR. N.EQ.0) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,M + B(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + RETURN + END IF +* +* Start the operations. +* + IF (LSIDE) THEN + IF (LSAME(TRANSA,'N')) THEN +* +* Form B := alpha*A*B. +* + IF (UPPER) THEN + DO 50 J = 1,N + DO 40 K = 1,M + IF (B(K,J).NE.ZERO) THEN + TEMP = ALPHA*B(K,J) + DO 30 I = 1,K - 1 + B(I,J) = B(I,J) + TEMP*A(I,K) + 30 CONTINUE + IF (NOUNIT) TEMP = TEMP*A(K,K) + B(K,J) = TEMP + END IF + 40 CONTINUE + 50 CONTINUE + ELSE + DO 80 J = 1,N + DO 70 K = M,1,-1 + IF (B(K,J).NE.ZERO) THEN + TEMP = ALPHA*B(K,J) + B(K,J) = TEMP + IF (NOUNIT) B(K,J) = B(K,J)*A(K,K) + DO 60 I = K + 1,M + B(I,J) = B(I,J) + TEMP*A(I,K) + 60 CONTINUE + END IF + 70 CONTINUE + 80 CONTINUE + END IF + ELSE +* +* Form B := alpha*A**T*B. +* + IF (UPPER) THEN + DO 110 J = 1,N + DO 100 I = M,1,-1 + TEMP = B(I,J) + IF (NOUNIT) TEMP = TEMP*A(I,I) + DO 90 K = 1,I - 1 + TEMP = TEMP + A(K,I)*B(K,J) + 90 CONTINUE + B(I,J) = ALPHA*TEMP + 100 CONTINUE + 110 CONTINUE + ELSE + DO 140 J = 1,N + DO 130 I = 1,M + TEMP = B(I,J) + IF (NOUNIT) TEMP = TEMP*A(I,I) + DO 120 K = I + 1,M + TEMP = TEMP + A(K,I)*B(K,J) + 120 CONTINUE + B(I,J) = ALPHA*TEMP + 130 CONTINUE + 140 CONTINUE + END IF + END IF + ELSE + IF (LSAME(TRANSA,'N')) THEN +* +* Form B := alpha*B*A. +* + IF (UPPER) THEN + DO 180 J = N,1,-1 + TEMP = ALPHA + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 150 I = 1,M + B(I,J) = TEMP*B(I,J) + 150 CONTINUE + DO 170 K = 1,J - 1 + IF (A(K,J).NE.ZERO) THEN + TEMP = ALPHA*A(K,J) + DO 160 I = 1,M + B(I,J) = B(I,J) + TEMP*B(I,K) + 160 CONTINUE + END IF + 170 CONTINUE + 180 CONTINUE + ELSE + DO 220 J = 1,N + TEMP = ALPHA + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 190 I = 1,M + B(I,J) = TEMP*B(I,J) + 190 CONTINUE + DO 210 K = J + 1,N + IF (A(K,J).NE.ZERO) THEN + TEMP = ALPHA*A(K,J) + DO 200 I = 1,M + B(I,J) = B(I,J) + TEMP*B(I,K) + 200 CONTINUE + END IF + 210 CONTINUE + 220 CONTINUE + END IF + ELSE +* +* Form B := alpha*B*A**T. +* + IF (UPPER) THEN + DO 260 K = 1,N + DO 240 J = 1,K - 1 + IF (A(J,K).NE.ZERO) THEN + TEMP = ALPHA*A(J,K) + DO 230 I = 1,M + B(I,J) = B(I,J) + TEMP*B(I,K) + 230 CONTINUE + END IF + 240 CONTINUE + TEMP = ALPHA + IF (NOUNIT) TEMP = TEMP*A(K,K) + IF (TEMP.NE.ONE) THEN + DO 250 I = 1,M + B(I,K) = TEMP*B(I,K) + 250 CONTINUE + END IF + 260 CONTINUE + ELSE + DO 300 K = N,1,-1 + DO 280 J = K + 1,N + IF (A(J,K).NE.ZERO) THEN + TEMP = ALPHA*A(J,K) + DO 270 I = 1,M + B(I,J) = B(I,J) + TEMP*B(I,K) + 270 CONTINUE + END IF + 280 CONTINUE + TEMP = ALPHA + IF (NOUNIT) TEMP = TEMP*A(K,K) + IF (TEMP.NE.ONE) THEN + DO 290 I = 1,M + B(I,K) = TEMP*B(I,K) + 290 CONTINUE + END IF + 300 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of STRMM +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/strmv.f b/fortran_implementation/external_libraries/BLAS/SRC/strmv.f new file mode 100644 index 0000000..ee40323 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/strmv.f @@ -0,0 +1,341 @@ +*> \brief \b STRMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE STRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,LDA,N +* CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. +* REAL A(LDA,*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> STRMV performs one of the matrix-vector operations +*> +*> x := A*x, or x := A**T*x, +*> +*> where x is an n element vector and A is an n by n unit, or non-unit, +*> upper or lower triangular matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the matrix is an upper or +*> lower triangular matrix as follows: +*> +*> UPLO = 'U' or 'u' A is an upper triangular matrix. +*> +*> UPLO = 'L' or 'l' A is a lower triangular matrix. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the operation to be performed as +*> follows: +*> +*> TRANS = 'N' or 'n' x := A*x. +*> +*> TRANS = 'T' or 't' x := A**T*x. +*> +*> TRANS = 'C' or 'c' x := A**T*x. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> On entry, DIAG specifies whether or not A is unit +*> triangular as follows: +*> +*> DIAG = 'U' or 'u' A is assumed to be unit triangular. +*> +*> DIAG = 'N' or 'n' A is not assumed to be unit +*> triangular. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is REAL array, dimension ( LDA, N ) +*> Before entry with UPLO = 'U' or 'u', the leading n by n +*> upper triangular part of the array A must contain the upper +*> triangular matrix and the strictly lower triangular part of +*> A is not referenced. +*> Before entry with UPLO = 'L' or 'l', the leading n by n +*> lower triangular part of the array A must contain the lower +*> triangular matrix and the strictly upper triangular part of +*> A is not referenced. +*> Note that when DIAG = 'U' or 'u', the diagonal elements of +*> A are not referenced either, but are assumed to be unity. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> max( 1, n ). +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is REAL array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element vector x. On exit, X is overwritten with the +*> transformed vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup trmv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> The vector and matrix arguments are not referenced when N = 0, or M = 0 +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE STRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,LDA,N + CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. + REAL A(LDA,*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO + PARAMETER (ZERO=0.0E+0) +* .. +* .. Local Scalars .. + REAL TEMP + INTEGER I,INFO,IX,J,JX,KX + LOGICAL NOUNIT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (.NOT.LSAME(TRANS,'N') .AND. + + .NOT.LSAME(TRANS,'T') .AND. + + .NOT.LSAME(TRANS,'C')) THEN + INFO = 2 + ELSE IF (.NOT.LSAME(DIAG,'U') .AND. + + .NOT.LSAME(DIAG,'N')) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (LDA.LT.MAX(1,N)) THEN + INFO = 6 + ELSE IF (INCX.EQ.0) THEN + INFO = 8 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('STRMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (N.EQ.0) RETURN +* + NOUNIT = LSAME(DIAG,'N') +* +* Set up the start point in X if the increment is not unity. This +* will be ( N - 1 )*INCX too small for descending loops. +* + IF (INCX.LE.0) THEN + KX = 1 - (N-1)*INCX + ELSE IF (INCX.NE.1) THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* + IF (LSAME(TRANS,'N')) THEN +* +* Form x := A*x. +* + IF (LSAME(UPLO,'U')) THEN + IF (INCX.EQ.1) THEN + DO 20 J = 1,N + IF (X(J).NE.ZERO) THEN + TEMP = X(J) + DO 10 I = 1,J - 1 + X(I) = X(I) + TEMP*A(I,J) + 10 CONTINUE + IF (NOUNIT) X(J) = X(J)*A(J,J) + END IF + 20 CONTINUE + ELSE + JX = KX + DO 40 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = X(JX) + IX = KX + DO 30 I = 1,J - 1 + X(IX) = X(IX) + TEMP*A(I,J) + IX = IX + INCX + 30 CONTINUE + IF (NOUNIT) X(JX) = X(JX)*A(J,J) + END IF + JX = JX + INCX + 40 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 60 J = N,1,-1 + IF (X(J).NE.ZERO) THEN + TEMP = X(J) + DO 50 I = N,J + 1,-1 + X(I) = X(I) + TEMP*A(I,J) + 50 CONTINUE + IF (NOUNIT) X(J) = X(J)*A(J,J) + END IF + 60 CONTINUE + ELSE + KX = KX + (N-1)*INCX + JX = KX + DO 80 J = N,1,-1 + IF (X(JX).NE.ZERO) THEN + TEMP = X(JX) + IX = KX + DO 70 I = N,J + 1,-1 + X(IX) = X(IX) + TEMP*A(I,J) + IX = IX - INCX + 70 CONTINUE + IF (NOUNIT) X(JX) = X(JX)*A(J,J) + END IF + JX = JX - INCX + 80 CONTINUE + END IF + END IF + ELSE +* +* Form x := A**T*x. +* + IF (LSAME(UPLO,'U')) THEN + IF (INCX.EQ.1) THEN + DO 100 J = N,1,-1 + TEMP = X(J) + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 90 I = J - 1,1,-1 + TEMP = TEMP + A(I,J)*X(I) + 90 CONTINUE + X(J) = TEMP + 100 CONTINUE + ELSE + JX = KX + (N-1)*INCX + DO 120 J = N,1,-1 + TEMP = X(JX) + IX = JX + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 110 I = J - 1,1,-1 + IX = IX - INCX + TEMP = TEMP + A(I,J)*X(IX) + 110 CONTINUE + X(JX) = TEMP + JX = JX - INCX + 120 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 140 J = 1,N + TEMP = X(J) + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 130 I = J + 1,N + TEMP = TEMP + A(I,J)*X(I) + 130 CONTINUE + X(J) = TEMP + 140 CONTINUE + ELSE + JX = KX + DO 160 J = 1,N + TEMP = X(JX) + IX = JX + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 150 I = J + 1,N + IX = IX + INCX + TEMP = TEMP + A(I,J)*X(IX) + 150 CONTINUE + X(JX) = TEMP + JX = JX + INCX + 160 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of STRMV +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/strsm.f b/fortran_implementation/external_libraries/BLAS/SRC/strsm.f new file mode 100644 index 0000000..66a295a --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/strsm.f @@ -0,0 +1,441 @@ +*> \brief \b STRSM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE STRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +* +* .. Scalar Arguments .. +* REAL ALPHA +* INTEGER LDA,LDB,M,N +* CHARACTER DIAG,SIDE,TRANSA,UPLO +* .. +* .. Array Arguments .. +* REAL A(LDA,*),B(LDB,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> STRSM solves one of the matrix equations +*> +*> op( A )*X = alpha*B, or X*op( A ) = alpha*B, +*> +*> where alpha is a scalar, X and B are m by n matrices, A is a unit, or +*> non-unit, upper or lower triangular matrix and op( A ) is one of +*> +*> op( A ) = A or op( A ) = A**T. +*> +*> The matrix X is overwritten on B. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> On entry, SIDE specifies whether op( A ) appears on the left +*> or right of X as follows: +*> +*> SIDE = 'L' or 'l' op( A )*X = alpha*B. +*> +*> SIDE = 'R' or 'r' X*op( A ) = alpha*B. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the matrix A is an upper or +*> lower triangular matrix as follows: +*> +*> UPLO = 'U' or 'u' A is an upper triangular matrix. +*> +*> UPLO = 'L' or 'l' A is a lower triangular matrix. +*> \endverbatim +*> +*> \param[in] TRANSA +*> \verbatim +*> TRANSA is CHARACTER*1 +*> On entry, TRANSA specifies the form of op( A ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSA = 'N' or 'n' op( A ) = A. +*> +*> TRANSA = 'T' or 't' op( A ) = A**T. +*> +*> TRANSA = 'C' or 'c' op( A ) = A**T. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> On entry, DIAG specifies whether or not A is unit triangular +*> as follows: +*> +*> DIAG = 'U' or 'u' A is assumed to be unit triangular. +*> +*> DIAG = 'N' or 'n' A is not assumed to be unit +*> triangular. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of B. M must be at +*> least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of B. N must be +*> at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is REAL +*> On entry, ALPHA specifies the scalar alpha. When alpha is +*> zero then A is not referenced and B need not be set before +*> entry. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is REAL array, dimension ( LDA, k ), +*> where k is m when SIDE = 'L' or 'l' +*> and k is n when SIDE = 'R' or 'r'. +*> Before entry with UPLO = 'U' or 'u', the leading k by k +*> upper triangular part of the array A must contain the upper +*> triangular matrix and the strictly lower triangular part of +*> A is not referenced. +*> Before entry with UPLO = 'L' or 'l', the leading k by k +*> lower triangular part of the array A must contain the lower +*> triangular matrix and the strictly upper triangular part of +*> A is not referenced. +*> Note that when DIAG = 'U' or 'u', the diagonal elements of +*> A are not referenced either, but are assumed to be unity. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When SIDE = 'L' or 'l' then +*> LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' +*> then LDA must be at least max( 1, n ). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is REAL array, dimension ( LDB, N ) +*> Before entry, the leading m by n part of the array B must +*> contain the right-hand side matrix B, and on exit is +*> overwritten by the solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. LDB must be at least +*> max( 1, m ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup trsm +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> +*> -- Written on 8-February-1989. +*> Jack Dongarra, Argonne National Laboratory. +*> Iain Duff, AERE Harwell. +*> Jeremy Du Croz, Numerical Algorithms Group Ltd. +*> Sven Hammarling, Numerical Algorithms Group Ltd. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE STRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +* +* -- Reference BLAS level3 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + REAL ALPHA + INTEGER LDA,LDB,M,N + CHARACTER DIAG,SIDE,TRANSA,UPLO +* .. +* .. Array Arguments .. + REAL A(LDA,*),B(LDB,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + REAL TEMP + INTEGER I,INFO,J,K,NROWA + LOGICAL LSIDE,NOUNIT,UPPER +* .. +* .. Parameters .. + REAL ONE,ZERO + PARAMETER (ONE=1.0E+0,ZERO=0.0E+0) +* .. +* +* Test the input parameters. +* + LSIDE = LSAME(SIDE,'L') + IF (LSIDE) THEN + NROWA = M + ELSE + NROWA = N + END IF + NOUNIT = LSAME(DIAG,'N') + UPPER = LSAME(UPLO,'U') +* + INFO = 0 + IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN + INFO = 1 + ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN + INFO = 2 + ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND. + + (.NOT.LSAME(TRANSA,'T')) .AND. + + (.NOT.LSAME(TRANSA,'C'))) THEN + INFO = 3 + ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. + + (.NOT.LSAME(DIAG,'N'))) THEN + INFO = 4 + ELSE IF (M.LT.0) THEN + INFO = 5 + ELSE IF (N.LT.0) THEN + INFO = 6 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 9 + ELSE IF (LDB.LT.MAX(1,M)) THEN + INFO = 11 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('STRSM ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (M.EQ.0 .OR. N.EQ.0) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,M + B(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + RETURN + END IF +* +* Start the operations. +* + IF (LSIDE) THEN + IF (LSAME(TRANSA,'N')) THEN +* +* Form B := alpha*inv( A )*B. +* + IF (UPPER) THEN + DO 60 J = 1,N + IF (ALPHA.NE.ONE) THEN + DO 30 I = 1,M + B(I,J) = ALPHA*B(I,J) + 30 CONTINUE + END IF + DO 50 K = M,1,-1 + IF (B(K,J).NE.ZERO) THEN + IF (NOUNIT) B(K,J) = B(K,J)/A(K,K) + DO 40 I = 1,K - 1 + B(I,J) = B(I,J) - B(K,J)*A(I,K) + 40 CONTINUE + END IF + 50 CONTINUE + 60 CONTINUE + ELSE + DO 100 J = 1,N + IF (ALPHA.NE.ONE) THEN + DO 70 I = 1,M + B(I,J) = ALPHA*B(I,J) + 70 CONTINUE + END IF + DO 90 K = 1,M + IF (B(K,J).NE.ZERO) THEN + IF (NOUNIT) B(K,J) = B(K,J)/A(K,K) + DO 80 I = K + 1,M + B(I,J) = B(I,J) - B(K,J)*A(I,K) + 80 CONTINUE + END IF + 90 CONTINUE + 100 CONTINUE + END IF + ELSE +* +* Form B := alpha*inv( A**T )*B. +* + IF (UPPER) THEN + DO 130 J = 1,N + DO 120 I = 1,M + TEMP = ALPHA*B(I,J) + DO 110 K = 1,I - 1 + TEMP = TEMP - A(K,I)*B(K,J) + 110 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(I,I) + B(I,J) = TEMP + 120 CONTINUE + 130 CONTINUE + ELSE + DO 160 J = 1,N + DO 150 I = M,1,-1 + TEMP = ALPHA*B(I,J) + DO 140 K = I + 1,M + TEMP = TEMP - A(K,I)*B(K,J) + 140 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(I,I) + B(I,J) = TEMP + 150 CONTINUE + 160 CONTINUE + END IF + END IF + ELSE + IF (LSAME(TRANSA,'N')) THEN +* +* Form B := alpha*B*inv( A ). +* + IF (UPPER) THEN + DO 210 J = 1,N + IF (ALPHA.NE.ONE) THEN + DO 170 I = 1,M + B(I,J) = ALPHA*B(I,J) + 170 CONTINUE + END IF + DO 190 K = 1,J - 1 + IF (A(K,J).NE.ZERO) THEN + DO 180 I = 1,M + B(I,J) = B(I,J) - A(K,J)*B(I,K) + 180 CONTINUE + END IF + 190 CONTINUE + IF (NOUNIT) THEN + TEMP = ONE/A(J,J) + DO 200 I = 1,M + B(I,J) = TEMP*B(I,J) + 200 CONTINUE + END IF + 210 CONTINUE + ELSE + DO 260 J = N,1,-1 + IF (ALPHA.NE.ONE) THEN + DO 220 I = 1,M + B(I,J) = ALPHA*B(I,J) + 220 CONTINUE + END IF + DO 240 K = J + 1,N + IF (A(K,J).NE.ZERO) THEN + DO 230 I = 1,M + B(I,J) = B(I,J) - A(K,J)*B(I,K) + 230 CONTINUE + END IF + 240 CONTINUE + IF (NOUNIT) THEN + TEMP = ONE/A(J,J) + DO 250 I = 1,M + B(I,J) = TEMP*B(I,J) + 250 CONTINUE + END IF + 260 CONTINUE + END IF + ELSE +* +* Form B := alpha*B*inv( A**T ). +* + IF (UPPER) THEN + DO 310 K = N,1,-1 + IF (NOUNIT) THEN + TEMP = ONE/A(K,K) + DO 270 I = 1,M + B(I,K) = TEMP*B(I,K) + 270 CONTINUE + END IF + DO 290 J = 1,K - 1 + IF (A(J,K).NE.ZERO) THEN + TEMP = A(J,K) + DO 280 I = 1,M + B(I,J) = B(I,J) - TEMP*B(I,K) + 280 CONTINUE + END IF + 290 CONTINUE + IF (ALPHA.NE.ONE) THEN + DO 300 I = 1,M + B(I,K) = ALPHA*B(I,K) + 300 CONTINUE + END IF + 310 CONTINUE + ELSE + DO 360 K = 1,N + IF (NOUNIT) THEN + TEMP = ONE/A(K,K) + DO 320 I = 1,M + B(I,K) = TEMP*B(I,K) + 320 CONTINUE + END IF + DO 340 J = K + 1,N + IF (A(J,K).NE.ZERO) THEN + TEMP = A(J,K) + DO 330 I = 1,M + B(I,J) = B(I,J) - TEMP*B(I,K) + 330 CONTINUE + END IF + 340 CONTINUE + IF (ALPHA.NE.ONE) THEN + DO 350 I = 1,M + B(I,K) = ALPHA*B(I,K) + 350 CONTINUE + END IF + 360 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of STRSM +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/strsv.f b/fortran_implementation/external_libraries/BLAS/SRC/strsv.f new file mode 100644 index 0000000..46c96de --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/strsv.f @@ -0,0 +1,343 @@ +*> \brief \b STRSV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE STRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,LDA,N +* CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. +* REAL A(LDA,*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> STRSV solves one of the systems of equations +*> +*> A*x = b, or A**T*x = b, +*> +*> where b and x are n element vectors and A is an n by n unit, or +*> non-unit, upper or lower triangular matrix. +*> +*> No test for singularity or near-singularity is included in this +*> routine. Such tests must be performed before calling this routine. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the matrix is an upper or +*> lower triangular matrix as follows: +*> +*> UPLO = 'U' or 'u' A is an upper triangular matrix. +*> +*> UPLO = 'L' or 'l' A is a lower triangular matrix. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the equations to be solved as +*> follows: +*> +*> TRANS = 'N' or 'n' A*x = b. +*> +*> TRANS = 'T' or 't' A**T*x = b. +*> +*> TRANS = 'C' or 'c' A**T*x = b. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> On entry, DIAG specifies whether or not A is unit +*> triangular as follows: +*> +*> DIAG = 'U' or 'u' A is assumed to be unit triangular. +*> +*> DIAG = 'N' or 'n' A is not assumed to be unit +*> triangular. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is REAL array, dimension ( LDA, N ) +*> Before entry with UPLO = 'U' or 'u', the leading n by n +*> upper triangular part of the array A must contain the upper +*> triangular matrix and the strictly lower triangular part of +*> A is not referenced. +*> Before entry with UPLO = 'L' or 'l', the leading n by n +*> lower triangular part of the array A must contain the lower +*> triangular matrix and the strictly upper triangular part of +*> A is not referenced. +*> Note that when DIAG = 'U' or 'u', the diagonal elements of +*> A are not referenced either, but are assumed to be unity. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> max( 1, n ). +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is REAL array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element right-hand side vector b. On exit, X is overwritten +*> with the solution vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup trsv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE STRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,LDA,N + CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. + REAL A(LDA,*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO + PARAMETER (ZERO=0.0E+0) +* .. +* .. Local Scalars .. + REAL TEMP + INTEGER I,INFO,IX,J,JX,KX + LOGICAL NOUNIT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (.NOT.LSAME(TRANS,'N') .AND. + + .NOT.LSAME(TRANS,'T') .AND. + + .NOT.LSAME(TRANS,'C')) THEN + INFO = 2 + ELSE IF (.NOT.LSAME(DIAG,'U') .AND. + + .NOT.LSAME(DIAG,'N')) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (LDA.LT.MAX(1,N)) THEN + INFO = 6 + ELSE IF (INCX.EQ.0) THEN + INFO = 8 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('STRSV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (N.EQ.0) RETURN +* + NOUNIT = LSAME(DIAG,'N') +* +* Set up the start point in X if the increment is not unity. This +* will be ( N - 1 )*INCX too small for descending loops. +* + IF (INCX.LE.0) THEN + KX = 1 - (N-1)*INCX + ELSE IF (INCX.NE.1) THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* + IF (LSAME(TRANS,'N')) THEN +* +* Form x := inv( A )*x. +* + IF (LSAME(UPLO,'U')) THEN + IF (INCX.EQ.1) THEN + DO 20 J = N,1,-1 + IF (X(J).NE.ZERO) THEN + IF (NOUNIT) X(J) = X(J)/A(J,J) + TEMP = X(J) + DO 10 I = J - 1,1,-1 + X(I) = X(I) - TEMP*A(I,J) + 10 CONTINUE + END IF + 20 CONTINUE + ELSE + JX = KX + (N-1)*INCX + DO 40 J = N,1,-1 + IF (X(JX).NE.ZERO) THEN + IF (NOUNIT) X(JX) = X(JX)/A(J,J) + TEMP = X(JX) + IX = JX + DO 30 I = J - 1,1,-1 + IX = IX - INCX + X(IX) = X(IX) - TEMP*A(I,J) + 30 CONTINUE + END IF + JX = JX - INCX + 40 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 60 J = 1,N + IF (X(J).NE.ZERO) THEN + IF (NOUNIT) X(J) = X(J)/A(J,J) + TEMP = X(J) + DO 50 I = J + 1,N + X(I) = X(I) - TEMP*A(I,J) + 50 CONTINUE + END IF + 60 CONTINUE + ELSE + JX = KX + DO 80 J = 1,N + IF (X(JX).NE.ZERO) THEN + IF (NOUNIT) X(JX) = X(JX)/A(J,J) + TEMP = X(JX) + IX = JX + DO 70 I = J + 1,N + IX = IX + INCX + X(IX) = X(IX) - TEMP*A(I,J) + 70 CONTINUE + END IF + JX = JX + INCX + 80 CONTINUE + END IF + END IF + ELSE +* +* Form x := inv( A**T )*x. +* + IF (LSAME(UPLO,'U')) THEN + IF (INCX.EQ.1) THEN + DO 100 J = 1,N + TEMP = X(J) + DO 90 I = 1,J - 1 + TEMP = TEMP - A(I,J)*X(I) + 90 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(J,J) + X(J) = TEMP + 100 CONTINUE + ELSE + JX = KX + DO 120 J = 1,N + TEMP = X(JX) + IX = KX + DO 110 I = 1,J - 1 + TEMP = TEMP - A(I,J)*X(IX) + IX = IX + INCX + 110 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(J,J) + X(JX) = TEMP + JX = JX + INCX + 120 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 140 J = N,1,-1 + TEMP = X(J) + DO 130 I = N,J + 1,-1 + TEMP = TEMP - A(I,J)*X(I) + 130 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(J,J) + X(J) = TEMP + 140 CONTINUE + ELSE + KX = KX + (N-1)*INCX + JX = KX + DO 160 J = N,1,-1 + TEMP = X(JX) + IX = KX + DO 150 I = N,J + 1,-1 + TEMP = TEMP - A(I,J)*X(IX) + IX = IX - INCX + 150 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(J,J) + X(JX) = TEMP + JX = JX - INCX + 160 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of STRSV +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/xerbla.f b/fortran_implementation/external_libraries/BLAS/SRC/xerbla.f new file mode 100644 index 0000000..8262cf4 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/xerbla.f @@ -0,0 +1,86 @@ +*> \brief \b XERBLA +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE XERBLA( SRNAME, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER*(*) SRNAME +* INTEGER INFO +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> XERBLA is an error handler for the LAPACK routines. +*> It is called by an LAPACK routine if an input parameter has an +*> invalid value. A message is printed and execution stops. +*> +*> Installers may consider modifying the STOP statement in order to +*> call system-specific exception-handling facilities. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SRNAME +*> \verbatim +*> SRNAME is CHARACTER*(*) +*> The name of the routine which called XERBLA. +*> \endverbatim +*> +*> \param[in] INFO +*> \verbatim +*> INFO is INTEGER +*> The position of the invalid parameter in the parameter list +*> of the calling routine. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup xerbla +* +* ===================================================================== + SUBROUTINE XERBLA( SRNAME, INFO ) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER*(*) SRNAME + INTEGER INFO +* .. +* +* ===================================================================== +* +* .. Intrinsic Functions .. + INTRINSIC LEN_TRIM +* .. +* .. Executable Statements .. +* + WRITE( *, FMT = 9999 )SRNAME( 1:LEN_TRIM( SRNAME ) ), INFO +* + STOP +* + 9999 FORMAT( ' ** On entry to ', A, ' parameter number ', I2, ' had ', + $ 'an illegal value' ) +* +* End of XERBLA +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/xerbla_array.f b/fortran_implementation/external_libraries/BLAS/SRC/xerbla_array.f new file mode 100644 index 0000000..5eeb548 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/xerbla_array.f @@ -0,0 +1,119 @@ +*> \brief \b XERBLA_ARRAY +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE XERBLA_ARRAY(SRNAME_ARRAY, SRNAME_LEN, INFO) +* +* .. Scalar Arguments .. +* INTEGER SRNAME_LEN, INFO +* .. +* .. Array Arguments .. +* CHARACTER(1) SRNAME_ARRAY(SRNAME_LEN) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> XERBLA_ARRAY assists other languages in calling XERBLA, the LAPACK +*> and BLAS error handler. Rather than taking a Fortran string argument +*> as the function's name, XERBLA_ARRAY takes an array of single +*> characters along with the array's length. XERBLA_ARRAY then copies +*> up to 32 characters of that array into a Fortran string and passes +*> that to XERBLA. If called with a non-positive SRNAME_LEN, +*> XERBLA_ARRAY will call XERBLA with a string of all blank characters. +*> +*> Say some macro or other device makes XERBLA_ARRAY available to C99 +*> by a name lapack_xerbla and with a common Fortran calling convention. +*> Then a C99 program could invoke XERBLA via: +*> { +*> int flen = strlen(__func__); +*> lapack_xerbla(__func__, &flen, &info); +*> } +*> +*> Providing XERBLA_ARRAY is not necessary for intercepting LAPACK +*> errors. XERBLA_ARRAY calls XERBLA. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SRNAME_ARRAY +*> \verbatim +*> SRNAME_ARRAY is CHARACTER(1) array, dimension (SRNAME_LEN) +*> The name of the routine which called XERBLA_ARRAY. +*> \endverbatim +*> +*> \param[in] SRNAME_LEN +*> \verbatim +*> SRNAME_LEN is INTEGER +*> The length of the name in SRNAME_ARRAY. +*> \endverbatim +*> +*> \param[in] INFO +*> \verbatim +*> INFO is INTEGER +*> The position of the invalid parameter in the parameter list +*> of the calling routine. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup xerbla_array +* +* ===================================================================== + SUBROUTINE XERBLA_ARRAY(SRNAME_ARRAY, SRNAME_LEN, INFO) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER SRNAME_LEN, INFO +* .. +* .. Array Arguments .. + CHARACTER(1) SRNAME_ARRAY(SRNAME_LEN) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + INTEGER I +* .. +* .. Local Arrays .. + CHARACTER*32 SRNAME +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN, LEN +* .. +* .. External Functions .. + EXTERNAL XERBLA +* .. +* .. Executable Statements .. + SRNAME = ' ' + DO I = 1, MIN( SRNAME_LEN, LEN( SRNAME ) ) + SRNAME( I:I ) = SRNAME_ARRAY( I ) + END DO + + CALL XERBLA( SRNAME, INFO ) + + RETURN +* +* End of XERBLA_ARRAY +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/zaxpy.f b/fortran_implementation/external_libraries/BLAS/SRC/zaxpy.f new file mode 100644 index 0000000..d39ccfc --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/zaxpy.f @@ -0,0 +1,139 @@ +*> \brief \b ZAXPY +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZAXPY(N,ZA,ZX,INCX,ZY,INCY) +* +* .. Scalar Arguments .. +* COMPLEX*16 ZA +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* COMPLEX*16 ZX(*),ZY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZAXPY constant times a vector plus a vector. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] ZA +*> \verbatim +*> ZA is COMPLEX*16 +*> On entry, ZA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] ZX +*> \verbatim +*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of ZX +*> \endverbatim +*> +*> \param[in,out] ZY +*> \verbatim +*> ZY is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of ZY +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup axpy +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, 3/11/78. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZAXPY(N,ZA,ZX,INCX,ZY,INCY) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX*16 ZA + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + COMPLEX*16 ZX(*),ZY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,IX,IY +* .. +* .. External Functions .. + DOUBLE PRECISION DCABS1 + EXTERNAL DCABS1 +* .. + IF (N.LE.0) RETURN + IF (DCABS1(ZA).EQ.0.0d0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* + DO I = 1,N + ZY(I) = ZY(I) + ZA*ZX(I) + END DO + ELSE +* +* code for unequal increments or equal increments +* not equal to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + ZY(IY) = ZY(IY) + ZA*ZX(IX) + IX = IX + INCX + IY = IY + INCY + END DO + END IF +* + RETURN +* +* End of ZAXPY +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/zcopy.f b/fortran_implementation/external_libraries/BLAS/SRC/zcopy.f new file mode 100644 index 0000000..c1ea412 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/zcopy.f @@ -0,0 +1,125 @@ +*> \brief \b ZCOPY +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZCOPY(N,ZX,INCX,ZY,INCY) +* +* .. Scalar Arguments .. +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* COMPLEX*16 ZX(*),ZY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZCOPY copies a vector, x, to a vector, y. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] ZX +*> \verbatim +*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of ZX +*> \endverbatim +*> +*> \param[out] ZY +*> \verbatim +*> ZY is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of ZY +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup copy +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, linpack, 4/11/78. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZCOPY(N,ZX,INCX,ZY,INCY) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + COMPLEX*16 ZX(*),ZY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,IX,IY +* .. + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* + DO I = 1,N + ZY(I) = ZX(I) + END DO + ELSE +* +* code for unequal increments or equal increments +* not equal to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + ZY(IY) = ZX(IX) + IX = IX + INCX + IY = IY + INCY + END DO + END IF + RETURN +* +* End of ZCOPY +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/zdotc.f b/fortran_implementation/external_libraries/BLAS/SRC/zdotc.f new file mode 100644 index 0000000..96b957e --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/zdotc.f @@ -0,0 +1,134 @@ +*> \brief \b ZDOTC +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* COMPLEX*16 FUNCTION ZDOTC(N,ZX,INCX,ZY,INCY) +* +* .. Scalar Arguments .. +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* COMPLEX*16 ZX(*),ZY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZDOTC forms the dot product of two complex vectors +*> ZDOTC = X^H * Y +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] ZX +*> \verbatim +*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of ZX +*> \endverbatim +*> +*> \param[in] ZY +*> \verbatim +*> ZY is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of ZY +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup dot +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, 3/11/78. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + COMPLEX*16 FUNCTION ZDOTC(N,ZX,INCX,ZY,INCY) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + COMPLEX*16 ZX(*),ZY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + COMPLEX*16 ZTEMP + INTEGER I,IX,IY +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG +* .. + ZTEMP = (0.0d0,0.0d0) + ZDOTC = (0.0d0,0.0d0) + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* + DO I = 1,N + ZTEMP = ZTEMP + DCONJG(ZX(I))*ZY(I) + END DO + ELSE +* +* code for unequal increments or equal increments +* not equal to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + ZTEMP = ZTEMP + DCONJG(ZX(IX))*ZY(IY) + IX = IX + INCX + IY = IY + INCY + END DO + END IF + ZDOTC = ZTEMP + RETURN +* +* End of ZDOTC +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/zdotu.f b/fortran_implementation/external_libraries/BLAS/SRC/zdotu.f new file mode 100644 index 0000000..82eed8b --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/zdotu.f @@ -0,0 +1,131 @@ +*> \brief \b ZDOTU +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* COMPLEX*16 FUNCTION ZDOTU(N,ZX,INCX,ZY,INCY) +* +* .. Scalar Arguments .. +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* COMPLEX*16 ZX(*),ZY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZDOTU forms the dot product of two complex vectors +*> ZDOTU = X^T * Y +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] ZX +*> \verbatim +*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of ZX +*> \endverbatim +*> +*> \param[in] ZY +*> \verbatim +*> ZY is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of ZY +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup dot +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, 3/11/78. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + COMPLEX*16 FUNCTION ZDOTU(N,ZX,INCX,ZY,INCY) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + COMPLEX*16 ZX(*),ZY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + COMPLEX*16 ZTEMP + INTEGER I,IX,IY +* .. + ZTEMP = (0.0d0,0.0d0) + ZDOTU = (0.0d0,0.0d0) + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* + DO I = 1,N + ZTEMP = ZTEMP + ZX(I)*ZY(I) + END DO + ELSE +* +* code for unequal increments or equal increments +* not equal to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + ZTEMP = ZTEMP + ZX(IX)*ZY(IY) + IX = IX + INCX + IY = IY + INCY + END DO + END IF + ZDOTU = ZTEMP + RETURN +* +* End of ZDOTU +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/zdrot.f b/fortran_implementation/external_libraries/BLAS/SRC/zdrot.f new file mode 100644 index 0000000..10ac3ac --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/zdrot.f @@ -0,0 +1,153 @@ +*> \brief \b ZDROT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZDROT( N, ZX, INCX, ZY, INCY, C, S ) +* +* .. Scalar Arguments .. +* INTEGER INCX, INCY, N +* DOUBLE PRECISION C, S +* .. +* .. Array Arguments .. +* COMPLEX*16 ZX( * ), ZY( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> Applies a plane rotation, where the cos and sin (c and s) are real +*> and the vectors cx and cy are complex. +*> jack dongarra, linpack, 3/11/78. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the vectors cx and cy. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in,out] ZX +*> \verbatim +*> ZX is COMPLEX*16 array, dimension at least +*> ( 1 + ( N - 1 )*abs( INCX ) ). +*> Before entry, the incremented array ZX must contain the n +*> element vector cx. On exit, ZX is overwritten by the updated +*> vector cx. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> ZX. INCX must not be zero. +*> \endverbatim +*> +*> \param[in,out] ZY +*> \verbatim +*> ZY is COMPLEX*16 array, dimension at least +*> ( 1 + ( N - 1 )*abs( INCY ) ). +*> Before entry, the incremented array ZY must contain the n +*> element vector cy. On exit, ZY is overwritten by the updated +*> vector cy. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> ZY. INCY must not be zero. +*> \endverbatim +*> +*> \param[in] C +*> \verbatim +*> C is DOUBLE PRECISION +*> On entry, C specifies the cosine, cos. +*> \endverbatim +*> +*> \param[in] S +*> \verbatim +*> S is DOUBLE PRECISION +*> On entry, S specifies the sine, sin. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup rot +* +* ===================================================================== + SUBROUTINE ZDROT( N, ZX, INCX, ZY, INCY, C, S ) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX, INCY, N + DOUBLE PRECISION C, S +* .. +* .. Array Arguments .. + COMPLEX*16 ZX( * ), ZY( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, IX, IY + COMPLEX*16 CTEMP +* .. +* .. Executable Statements .. +* + IF( N.LE.0 ) + $ RETURN + IF( INCX.EQ.1 .AND. INCY.EQ.1 ) THEN +* +* code for both increments equal to 1 +* + DO I = 1, N + CTEMP = C*ZX( I ) + S*ZY( I ) + ZY( I ) = C*ZY( I ) - S*ZX( I ) + ZX( I ) = CTEMP + END DO + ELSE +* +* code for unequal increments or equal increments not equal +* to 1 +* + IX = 1 + IY = 1 + IF( INCX.LT.0 ) + $ IX = ( -N+1 )*INCX + 1 + IF( INCY.LT.0 ) + $ IY = ( -N+1 )*INCY + 1 + DO I = 1, N + CTEMP = C*ZX( IX ) + S*ZY( IY ) + ZY( IY ) = C*ZY( IY ) - S*ZX( IX ) + ZX( IX ) = CTEMP + IX = IX + INCX + IY = IY + INCY + END DO + END IF + RETURN +* +* End of ZDROT +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/zdscal.f b/fortran_implementation/external_libraries/BLAS/SRC/zdscal.f new file mode 100644 index 0000000..28fa829 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/zdscal.f @@ -0,0 +1,123 @@ +*> \brief \b ZDSCAL +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZDSCAL(N,DA,ZX,INCX) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION DA +* INTEGER INCX,N +* .. +* .. Array Arguments .. +* COMPLEX*16 ZX(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZDSCAL scales a vector by a constant. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] DA +*> \verbatim +*> DA is DOUBLE PRECISION +*> On entry, DA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in,out] ZX +*> \verbatim +*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of ZX +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup scal +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, 3/11/78. +*> modified 3/93 to return if incx .le. 0. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZDSCAL(N,DA,ZX,INCX) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + DOUBLE PRECISION DA + INTEGER INCX,N +* .. +* .. Array Arguments .. + COMPLEX*16 ZX(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,NINCX +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER (ONE=1.0D+0) +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, DCMPLX, DIMAG +* .. + IF (N.LE.0 .OR. INCX.LE.0 .OR. DA.EQ.ONE) RETURN + IF (INCX.EQ.1) THEN +* +* code for increment equal to 1 +* + DO I = 1,N + ZX(I) = DCMPLX(DA*DBLE(ZX(I)),DA*DIMAG(ZX(I))) + END DO + ELSE +* +* code for increment not equal to 1 +* + NINCX = N*INCX + DO I = 1,NINCX,INCX + ZX(I) = DCMPLX(DA*DBLE(ZX(I)),DA*DIMAG(ZX(I))) + END DO + END IF + RETURN +* +* End of ZDSCAL +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/zgbmv.f b/fortran_implementation/external_libraries/BLAS/SRC/zgbmv.f new file mode 100644 index 0000000..25903cf --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/zgbmv.f @@ -0,0 +1,390 @@ +*> \brief \b ZGBMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA,BETA +* INTEGER INCX,INCY,KL,KU,LDA,M,N +* CHARACTER TRANS +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGBMV performs one of the matrix-vector operations +*> +*> y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, or +*> +*> y := alpha*A**H*x + beta*y, +*> +*> where alpha and beta are scalars, x and y are vectors and A is an +*> m by n band matrix, with kl sub-diagonals and ku super-diagonals. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the operation to be performed as +*> follows: +*> +*> TRANS = 'N' or 'n' y := alpha*A*x + beta*y. +*> +*> TRANS = 'T' or 't' y := alpha*A**T*x + beta*y. +*> +*> TRANS = 'C' or 'c' y := alpha*A**H*x + beta*y. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix A. +*> M must be at least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] KL +*> \verbatim +*> KL is INTEGER +*> On entry, KL specifies the number of sub-diagonals of the +*> matrix A. KL must satisfy 0 .le. KL. +*> \endverbatim +*> +*> \param[in] KU +*> \verbatim +*> KU is INTEGER +*> On entry, KU specifies the number of super-diagonals of the +*> matrix A. KU must satisfy 0 .le. KU. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX*16 +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension ( LDA, N ) +*> Before entry, the leading ( kl + ku + 1 ) by n part of the +*> array A must contain the matrix of coefficients, supplied +*> column by column, with the leading diagonal of the matrix in +*> row ( ku + 1 ) of the array, the first super-diagonal +*> starting at position 2 in row ku, the first sub-diagonal +*> starting at position 1 in row ( ku + 2 ), and so on. +*> Elements in the array A that do not correspond to elements +*> in the band matrix (such as the top left ku by ku triangle) +*> are not referenced. +*> The following program segment will transfer a band matrix +*> from conventional full matrix storage to band storage: +*> +*> DO 20, J = 1, N +*> K = KU + 1 - J +*> DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL ) +*> A( K + I, J ) = matrix( I, J ) +*> 10 CONTINUE +*> 20 CONTINUE +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> ( kl + ku + 1 ). +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is COMPLEX*16 array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' +*> and at least +*> ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. +*> Before entry, the incremented array X must contain the +*> vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is COMPLEX*16 +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then Y need not be set on input. +*> \endverbatim +*> +*> \param[in,out] Y +*> \verbatim +*> Y is COMPLEX*16 array, dimension at least +*> ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' +*> and at least +*> ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. +*> Before entry, the incremented array Y must contain the +*> vector y. On exit, Y is overwritten by the updated vector y. +*> If either m or n is zero, then Y not referenced and the function +*> performs a quick return. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> Y. INCY must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup gbmv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> The vector and matrix arguments are not referenced when N = 0, or M = 0 +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX, + + BETA,Y,INCY) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX*16 ALPHA,BETA + INTEGER INCX,INCY,KL,KU,LDA,M,N + CHARACTER TRANS +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER (ONE= (1.0D+0,0.0D+0)) + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,IX,IY,J,JX,JY,K,KUP1,KX,KY,LENX,LENY + LOGICAL NOCONJ +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG,MAX,MIN +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. + + .NOT.LSAME(TRANS,'C')) THEN + INFO = 1 + ELSE IF (M.LT.0) THEN + INFO = 2 + ELSE IF (N.LT.0) THEN + INFO = 3 + ELSE IF (KL.LT.0) THEN + INFO = 4 + ELSE IF (KU.LT.0) THEN + INFO = 5 + ELSE IF (LDA.LT. (KL+KU+1)) THEN + INFO = 8 + ELSE IF (INCX.EQ.0) THEN + INFO = 10 + ELSE IF (INCY.EQ.0) THEN + INFO = 13 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('ZGBMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. + + ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN +* + NOCONJ = LSAME(TRANS,'T') +* +* Set LENX and LENY, the lengths of the vectors x and y, and set +* up the start points in X and Y. +* + IF (LSAME(TRANS,'N')) THEN + LENX = N + LENY = M + ELSE + LENX = M + LENY = N + END IF + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (LENX-1)*INCX + END IF + IF (INCY.GT.0) THEN + KY = 1 + ELSE + KY = 1 - (LENY-1)*INCY + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through the band part of A. +* +* First form y := beta*y. +* + IF (BETA.NE.ONE) THEN + IF (INCY.EQ.1) THEN + IF (BETA.EQ.ZERO) THEN + DO 10 I = 1,LENY + Y(I) = ZERO + 10 CONTINUE + ELSE + DO 20 I = 1,LENY + Y(I) = BETA*Y(I) + 20 CONTINUE + END IF + ELSE + IY = KY + IF (BETA.EQ.ZERO) THEN + DO 30 I = 1,LENY + Y(IY) = ZERO + IY = IY + INCY + 30 CONTINUE + ELSE + DO 40 I = 1,LENY + Y(IY) = BETA*Y(IY) + IY = IY + INCY + 40 CONTINUE + END IF + END IF + END IF + IF (ALPHA.EQ.ZERO) RETURN + KUP1 = KU + 1 + IF (LSAME(TRANS,'N')) THEN +* +* Form y := alpha*A*x + y. +* + JX = KX + IF (INCY.EQ.1) THEN + DO 60 J = 1,N + TEMP = ALPHA*X(JX) + K = KUP1 - J + DO 50 I = MAX(1,J-KU),MIN(M,J+KL) + Y(I) = Y(I) + TEMP*A(K+I,J) + 50 CONTINUE + JX = JX + INCX + 60 CONTINUE + ELSE + DO 80 J = 1,N + TEMP = ALPHA*X(JX) + IY = KY + K = KUP1 - J + DO 70 I = MAX(1,J-KU),MIN(M,J+KL) + Y(IY) = Y(IY) + TEMP*A(K+I,J) + IY = IY + INCY + 70 CONTINUE + JX = JX + INCX + IF (J.GT.KU) KY = KY + INCY + 80 CONTINUE + END IF + ELSE +* +* Form y := alpha*A**T*x + y or y := alpha*A**H*x + y. +* + JY = KY + IF (INCX.EQ.1) THEN + DO 110 J = 1,N + TEMP = ZERO + K = KUP1 - J + IF (NOCONJ) THEN + DO 90 I = MAX(1,J-KU),MIN(M,J+KL) + TEMP = TEMP + A(K+I,J)*X(I) + 90 CONTINUE + ELSE + DO 100 I = MAX(1,J-KU),MIN(M,J+KL) + TEMP = TEMP + DCONJG(A(K+I,J))*X(I) + 100 CONTINUE + END IF + Y(JY) = Y(JY) + ALPHA*TEMP + JY = JY + INCY + 110 CONTINUE + ELSE + DO 140 J = 1,N + TEMP = ZERO + IX = KX + K = KUP1 - J + IF (NOCONJ) THEN + DO 120 I = MAX(1,J-KU),MIN(M,J+KL) + TEMP = TEMP + A(K+I,J)*X(IX) + IX = IX + INCX + 120 CONTINUE + ELSE + DO 130 I = MAX(1,J-KU),MIN(M,J+KL) + TEMP = TEMP + DCONJG(A(K+I,J))*X(IX) + IX = IX + INCX + 130 CONTINUE + END IF + Y(JY) = Y(JY) + ALPHA*TEMP + JY = JY + INCY + IF (J.GT.KU) KX = KX + INCX + 140 CONTINUE + END IF + END IF +* + RETURN +* +* End of ZGBMV +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/zgemm.f b/fortran_implementation/external_libraries/BLAS/SRC/zgemm.f new file mode 100644 index 0000000..3661195 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/zgemm.f @@ -0,0 +1,478 @@ +*> \brief \b ZGEMM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA,BETA +* INTEGER K,LDA,LDB,LDC,M,N +* CHARACTER TRANSA,TRANSB +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGEMM performs one of the matrix-matrix operations +*> +*> C := alpha*op( A )*op( B ) + beta*C, +*> +*> where op( X ) is one of +*> +*> op( X ) = X or op( X ) = X**T or op( X ) = X**H, +*> +*> alpha and beta are scalars, and A, B and C are matrices, with op( A ) +*> an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANSA +*> \verbatim +*> TRANSA is CHARACTER*1 +*> On entry, TRANSA specifies the form of op( A ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSA = 'N' or 'n', op( A ) = A. +*> +*> TRANSA = 'T' or 't', op( A ) = A**T. +*> +*> TRANSA = 'C' or 'c', op( A ) = A**H. +*> \endverbatim +*> +*> \param[in] TRANSB +*> \verbatim +*> TRANSB is CHARACTER*1 +*> On entry, TRANSB specifies the form of op( B ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSB = 'N' or 'n', op( B ) = B. +*> +*> TRANSB = 'T' or 't', op( B ) = B**T. +*> +*> TRANSB = 'C' or 'c', op( B ) = B**H. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix +*> op( A ) and of the matrix C. M must be at least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of the matrix +*> op( B ) and the number of columns of the matrix C. N must be +*> at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry, K specifies the number of columns of the matrix +*> op( A ) and the number of rows of the matrix op( B ). K must +*> be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX*16 +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension ( LDA, ka ), where ka is +*> k when TRANSA = 'N' or 'n', and is m otherwise. +*> Before entry with TRANSA = 'N' or 'n', the leading m by k +*> part of the array A must contain the matrix A, otherwise +*> the leading k by m part of the array A must contain the +*> matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When TRANSA = 'N' or 'n' then +*> LDA must be at least max( 1, m ), otherwise LDA must be at +*> least max( 1, k ). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is COMPLEX*16 array, dimension ( LDB, kb ), where kb is +*> n when TRANSB = 'N' or 'n', and is k otherwise. +*> Before entry with TRANSB = 'N' or 'n', the leading k by n +*> part of the array B must contain the matrix B, otherwise +*> the leading n by k part of the array B must contain the +*> matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. When TRANSB = 'N' or 'n' then +*> LDB must be at least max( 1, k ), otherwise LDB must be at +*> least max( 1, n ). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is COMPLEX*16 +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then C need not be set on input. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX*16 array, dimension ( LDC, N ) +*> Before entry, the leading m by n part of the array C must +*> contain the matrix C, except when beta is zero, in which +*> case C need not be set on entry. +*> On exit, the array C is overwritten by the m by n matrix +*> ( alpha*op( A )*op( B ) + beta*C ). +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> On entry, LDC specifies the first dimension of C as declared +*> in the calling (sub) program. LDC must be at least +*> max( 1, m ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup gemm +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> -- Written on 8-February-1989. +*> Jack Dongarra, Argonne National Laboratory. +*> Iain Duff, AERE Harwell. +*> Jeremy Du Croz, Numerical Algorithms Group Ltd. +*> Sven Hammarling, Numerical Algorithms Group Ltd. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB, + + BETA,C,LDC) +* +* -- Reference BLAS level3 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX*16 ALPHA,BETA + INTEGER K,LDA,LDB,LDC,M,N + CHARACTER TRANSA,TRANSB +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG,MAX +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,J,L,NROWA,NROWB + LOGICAL CONJA,CONJB,NOTA,NOTB +* .. +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER (ONE= (1.0D+0,0.0D+0)) + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* +* Set NOTA and NOTB as true if A and B respectively are not +* conjugated or transposed, set CONJA and CONJB as true if A and +* B respectively are to be transposed but not conjugated and set +* NROWA and NROWB as the number of rows of A and B respectively. +* + NOTA = LSAME(TRANSA,'N') + NOTB = LSAME(TRANSB,'N') + CONJA = LSAME(TRANSA,'C') + CONJB = LSAME(TRANSB,'C') + IF (NOTA) THEN + NROWA = M + ELSE + NROWA = K + END IF + IF (NOTB) THEN + NROWB = K + ELSE + NROWB = N + END IF +* +* Test the input parameters. +* + INFO = 0 + IF ((.NOT.NOTA) .AND. (.NOT.CONJA) .AND. + + (.NOT.LSAME(TRANSA,'T'))) THEN + INFO = 1 + ELSE IF ((.NOT.NOTB) .AND. (.NOT.CONJB) .AND. + + (.NOT.LSAME(TRANSB,'T'))) THEN + INFO = 2 + ELSE IF (M.LT.0) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (K.LT.0) THEN + INFO = 5 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 8 + ELSE IF (LDB.LT.MAX(1,NROWB)) THEN + INFO = 10 + ELSE IF (LDC.LT.MAX(1,M)) THEN + INFO = 13 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('ZGEMM ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. + + (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + IF (BETA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,M + C(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1,N + DO 30 I = 1,M + C(I,J) = BETA*C(I,J) + 30 CONTINUE + 40 CONTINUE + END IF + RETURN + END IF +* +* Start the operations. +* + IF (NOTB) THEN + IF (NOTA) THEN +* +* Form C := alpha*A*B + beta*C. +* + DO 90 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 50 I = 1,M + C(I,J) = ZERO + 50 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 60 I = 1,M + C(I,J) = BETA*C(I,J) + 60 CONTINUE + END IF + DO 80 L = 1,K + TEMP = ALPHA*B(L,J) + DO 70 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + ELSE IF (CONJA) THEN +* +* Form C := alpha*A**H*B + beta*C. +* + DO 120 J = 1,N + DO 110 I = 1,M + TEMP = ZERO + DO 100 L = 1,K + TEMP = TEMP + DCONJG(A(L,I))*B(L,J) + 100 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 110 CONTINUE + 120 CONTINUE + ELSE +* +* Form C := alpha*A**T*B + beta*C +* + DO 150 J = 1,N + DO 140 I = 1,M + TEMP = ZERO + DO 130 L = 1,K + TEMP = TEMP + A(L,I)*B(L,J) + 130 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 140 CONTINUE + 150 CONTINUE + END IF + ELSE IF (NOTA) THEN + IF (CONJB) THEN +* +* Form C := alpha*A*B**H + beta*C. +* + DO 200 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 160 I = 1,M + C(I,J) = ZERO + 160 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 170 I = 1,M + C(I,J) = BETA*C(I,J) + 170 CONTINUE + END IF + DO 190 L = 1,K + TEMP = ALPHA*DCONJG(B(J,L)) + DO 180 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 180 CONTINUE + 190 CONTINUE + 200 CONTINUE + ELSE +* +* Form C := alpha*A*B**T + beta*C +* + DO 250 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 210 I = 1,M + C(I,J) = ZERO + 210 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 220 I = 1,M + C(I,J) = BETA*C(I,J) + 220 CONTINUE + END IF + DO 240 L = 1,K + TEMP = ALPHA*B(J,L) + DO 230 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 230 CONTINUE + 240 CONTINUE + 250 CONTINUE + END IF + ELSE IF (CONJA) THEN + IF (CONJB) THEN +* +* Form C := alpha*A**H*B**H + beta*C. +* + DO 280 J = 1,N + DO 270 I = 1,M + TEMP = ZERO + DO 260 L = 1,K + TEMP = TEMP + DCONJG(A(L,I))*DCONJG(B(J,L)) + 260 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 270 CONTINUE + 280 CONTINUE + ELSE +* +* Form C := alpha*A**H*B**T + beta*C +* + DO 310 J = 1,N + DO 300 I = 1,M + TEMP = ZERO + DO 290 L = 1,K + TEMP = TEMP + DCONJG(A(L,I))*B(J,L) + 290 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 300 CONTINUE + 310 CONTINUE + END IF + ELSE + IF (CONJB) THEN +* +* Form C := alpha*A**T*B**H + beta*C +* + DO 340 J = 1,N + DO 330 I = 1,M + TEMP = ZERO + DO 320 L = 1,K + TEMP = TEMP + A(L,I)*DCONJG(B(J,L)) + 320 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 330 CONTINUE + 340 CONTINUE + ELSE +* +* Form C := alpha*A**T*B**T + beta*C +* + DO 370 J = 1,N + DO 360 I = 1,M + TEMP = ZERO + DO 350 L = 1,K + TEMP = TEMP + A(L,I)*B(J,L) + 350 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 360 CONTINUE + 370 CONTINUE + END IF + END IF +* + RETURN +* +* End of ZGEMM +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/zgemmtr.f b/fortran_implementation/external_libraries/BLAS/SRC/zgemmtr.f new file mode 100644 index 0000000..01dd91c --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/zgemmtr.f @@ -0,0 +1,569 @@ +*> \brief \b ZGEMMTR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZGEMMTR(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB,BETA, +* C,LDC) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA,BETA +* INTEGER K,LDA,LDB,LDC,N +* CHARACTER TRANSA,TRANSB, UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGEMMTR performs one of the matrix-matrix operations +*> +*> C := alpha*op( A )*op( B ) + beta*C, +*> +*> where op( X ) is one of +*> +*> op( X ) = X or op( X ) = X**T, +*> +*> alpha and beta are scalars, and A, B and C are matrices, with op( A ) +*> an n by k matrix, op( B ) a k by n matrix and C an n by n matrix. +*> Thereby, the routine only accesses and updates the upper or lower +*> triangular part of the result matrix C. This behaviour can be used if +*> the resulting matrix C is known to be Hermitian or symmetric. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the lower or the upper +*> triangular part of C is access and updated. +*> +*> UPLO = 'L' or 'l', the lower triangular part of C is used. +*> +*> UPLO = 'U' or 'u', the upper triangular part of C is used. +*> \endverbatim +* +*> \param[in] TRANSA +*> \verbatim +*> TRANSA is CHARACTER*1 +*> On entry, TRANSA specifies the form of op( A ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSA = 'N' or 'n', op( A ) = A. +*> +*> TRANSA = 'T' or 't', op( A ) = A**T. +*> +*> TRANSA = 'C' or 'c', op( A ) = A**H. +*> \endverbatim +*> +*> \param[in] TRANSB +*> \verbatim +*> TRANSB is CHARACTER*1 +*> On entry, TRANSB specifies the form of op( B ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSB = 'N' or 'n', op( B ) = B. +*> +*> TRANSB = 'T' or 't', op( B ) = B**T. +*> +*> TRANSB = 'C' or 'c', op( B ) = B**H. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of rows and columns of +*> the matrix C, the number of columns of op(B) and the number +*> of rows of op(A). N must be at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry, K specifies the number of columns of the matrix +*> op( A ) and the number of rows of the matrix op( B ). K must +*> be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX*16. +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension ( LDA, ka ), where ka is +*> k when TRANSA = 'N' or 'n', and is n otherwise. +*> Before entry with TRANSA = 'N' or 'n', the leading n by k +*> part of the array A must contain the matrix A, otherwise +*> the leading k by m part of the array A must contain the +*> matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When TRANSA = 'N' or 'n' then +*> LDA must be at least max( 1, n ), otherwise LDA must be at +*> least max( 1, k ). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is COMPLEX*16 array, dimension ( LDB, kb ), where kb is +*> n when TRANSB = 'N' or 'n', and is k otherwise. +*> Before entry with TRANSB = 'N' or 'n', the leading k by n +*> part of the array B must contain the matrix B, otherwise +*> the leading n by k part of the array B must contain the +*> matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. When TRANSB = 'N' or 'n' then +*> LDB must be at least max( 1, k ), otherwise LDB must be at +*> least max( 1, n ). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is COMPLEX*16. +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then C need not be set on input. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX*16 array, dimension ( LDC, N ) +*> Before entry, the leading n by n part of the array C must +*> contain the matrix C, except when beta is zero, in which +*> case C need not be set on entry. +*> On exit, the upper or lower triangular part of the matrix +*> C is overwritten by the n by n matrix +*> ( alpha*op( A )*op( B ) + beta*C ). +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> On entry, LDC specifies the first dimension of C as declared +*> in the calling (sub) program. LDC must be at least +*> max( 1, n ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Martin Koehler +* +*> \ingroup gemmtr +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> -- Written on 19-July-2023. +*> Martin Koehler, MPI Magdeburg +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZGEMMTR(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB, + + BETA,C,LDC) + IMPLICIT NONE +* +* -- Reference BLAS level3 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX*16 ALPHA,BETA + INTEGER K,LDA,LDB,LDC,N + CHARACTER TRANSA,TRANSB,UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC CONJG,MAX +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,J,L,NROWA,NROWB,ISTART, ISTOP + LOGICAL CONJA,CONJB,NOTA,NOTB,UPPER +* .. +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER (ONE= (1.0D+0,0.0D+0)) + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* +* Set NOTA and NOTB as true if A and B respectively are not +* conjugated or transposed, set CONJA and CONJB as true if A and +* B respectively are to be transposed but not conjugated and set +* NROWA and NROWB as the number of rows of A and B respectively. +* + NOTA = LSAME(TRANSA,'N') + NOTB = LSAME(TRANSB,'N') + CONJA = LSAME(TRANSA,'C') + CONJB = LSAME(TRANSB,'C') + IF (NOTA) THEN + NROWA = N + ELSE + NROWA = K + END IF + IF (NOTB) THEN + NROWB = K + ELSE + NROWB = N + END IF + UPPER = LSAME(UPLO, 'U') + +* +* Test the input parameters. +* + INFO = 0 + IF ((.NOT. UPPER) .AND. (.NOT. LSAME(UPLO, 'L'))) THEN + INFO = 1 + ELSE IF ((.NOT.NOTA) .AND. (.NOT.CONJA) .AND. + + (.NOT.LSAME(TRANSA,'T'))) THEN + INFO = 2 + ELSE IF ((.NOT.NOTB) .AND. (.NOT.CONJB) .AND. + + (.NOT.LSAME(TRANSB,'T'))) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (K.LT.0) THEN + INFO = 5 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 8 + ELSE IF (LDB.LT.MAX(1,NROWB)) THEN + INFO = 10 + ELSE IF (LDC.LT.MAX(1,N)) THEN + INFO = 13 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('ZGEMMTR',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (N.EQ.0) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + IF (BETA.EQ.ZERO) THEN + DO 20 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + DO 10 I = ISTART, ISTOP + C(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + DO 30 I = ISTART, ISTOP + C(I,J) = BETA*C(I,J) + 30 CONTINUE + 40 CONTINUE + END IF + RETURN + END IF +* +* Start the operations. +* + IF (NOTB) THEN + IF (NOTA) THEN +* +* Form C := alpha*A*B + beta*C. +* + DO 90 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + IF (BETA.EQ.ZERO) THEN + DO 50 I = ISTART, ISTOP + C(I,J) = ZERO + 50 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 60 I = ISTART, ISTOP + C(I,J) = BETA*C(I,J) + 60 CONTINUE + END IF + DO 80 L = 1,K + TEMP = ALPHA*B(L,J) + DO 70 I = ISTART, ISTOP + C(I,J) = C(I,J) + TEMP*A(I,L) + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + ELSE IF (CONJA) THEN +* +* Form C := alpha*A**H*B + beta*C. +* + DO 120 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + DO 110 I = ISTART, ISTOP + TEMP = ZERO + DO 100 L = 1,K + TEMP = TEMP + CONJG(A(L,I))*B(L,J) + 100 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 110 CONTINUE + 120 CONTINUE + ELSE +* +* Form C := alpha*A**T*B + beta*C +* + DO 150 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + DO 140 I = ISTART, ISTOP + TEMP = ZERO + DO 130 L = 1,K + TEMP = TEMP + A(L,I)*B(L,J) + 130 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 140 CONTINUE + 150 CONTINUE + END IF + ELSE IF (NOTA) THEN + IF (CONJB) THEN +* +* Form C := alpha*A*B**H + beta*C. +* + DO 200 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + IF (BETA.EQ.ZERO) THEN + DO 160 I = ISTART,ISTOP + C(I,J) = ZERO + 160 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 170 I = ISTART, ISTOP + C(I,J) = BETA*C(I,J) + 170 CONTINUE + END IF + DO 190 L = 1,K + TEMP = ALPHA*CONJG(B(J,L)) + DO 180 I = ISTART, ISTOP + C(I,J) = C(I,J) + TEMP*A(I,L) + 180 CONTINUE + 190 CONTINUE + 200 CONTINUE + ELSE +* +* Form C := alpha*A*B**T + beta*C +* + DO 250 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + IF (BETA.EQ.ZERO) THEN + DO 210 I = ISTART, ISTOP + C(I,J) = ZERO + 210 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 220 I = ISTART, ISTOP + C(I,J) = BETA*C(I,J) + 220 CONTINUE + END IF + DO 240 L = 1,K + TEMP = ALPHA*B(J,L) + DO 230 I = ISTART, ISTOP + C(I,J) = C(I,J) + TEMP*A(I,L) + 230 CONTINUE + 240 CONTINUE + 250 CONTINUE + END IF + ELSE IF (CONJA) THEN + IF (CONJB) THEN +* +* Form C := alpha*A**H*B**H + beta*C. +* + DO 280 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + DO 270 I = ISTART, ISTOP + TEMP = ZERO + DO 260 L = 1,K + TEMP = TEMP + CONJG(A(L,I))*CONJG(B(J,L)) + 260 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 270 CONTINUE + 280 CONTINUE + ELSE +* +* Form C := alpha*A**H*B**T + beta*C +* + DO 310 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + DO 300 I = ISTART, ISTOP + TEMP = ZERO + DO 290 L = 1,K + TEMP = TEMP + CONJG(A(L,I))*B(J,L) + 290 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 300 CONTINUE + 310 CONTINUE + END IF + ELSE + IF (CONJB) THEN +* +* Form C := alpha*A**T*B**H + beta*C +* + DO 340 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + DO 330 I = ISTART, ISTOP + TEMP = ZERO + DO 320 L = 1,K + TEMP = TEMP + A(L,I)*CONJG(B(J,L)) + 320 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 330 CONTINUE + 340 CONTINUE + ELSE +* +* Form C := alpha*A**T*B**T + beta*C +* + DO 370 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + DO 360 I = ISTART, ISTOP + TEMP = ZERO + DO 350 L = 1,K + TEMP = TEMP + A(L,I)*B(J,L) + 350 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 360 CONTINUE + 370 CONTINUE + END IF + END IF +* + RETURN +* +* End of ZGEMMTR +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/zgemv.f b/fortran_implementation/external_libraries/BLAS/SRC/zgemv.f new file mode 100644 index 0000000..ccc256b --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/zgemv.f @@ -0,0 +1,349 @@ +*> \brief \b ZGEMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA,BETA +* INTEGER INCX,INCY,LDA,M,N +* CHARACTER TRANS +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGEMV performs one of the matrix-vector operations +*> +*> y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, or +*> +*> y := alpha*A**H*x + beta*y, +*> +*> where alpha and beta are scalars, x and y are vectors and A is an +*> m by n matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the operation to be performed as +*> follows: +*> +*> TRANS = 'N' or 'n' y := alpha*A*x + beta*y. +*> +*> TRANS = 'T' or 't' y := alpha*A**T*x + beta*y. +*> +*> TRANS = 'C' or 'c' y := alpha*A**H*x + beta*y. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix A. +*> M must be at least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX*16 +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension ( LDA, N ) +*> Before entry, the leading m by n part of the array A must +*> contain the matrix of coefficients. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> max( 1, m ). +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is COMPLEX*16 array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' +*> and at least +*> ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. +*> Before entry, the incremented array X must contain the +*> vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is COMPLEX*16 +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then Y need not be set on input. +*> \endverbatim +*> +*> \param[in,out] Y +*> \verbatim +*> Y is COMPLEX*16 array, dimension at least +*> ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' +*> and at least +*> ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. +*> Before entry with BETA non-zero, the incremented array Y +*> must contain the vector y. On exit, Y is overwritten by the +*> updated vector y. +*> If either m or n is zero, then Y not referenced and the function +*> performs a quick return. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> Y. INCY must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup gemv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> The vector and matrix arguments are not referenced when N = 0, or M = 0 +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX*16 ALPHA,BETA + INTEGER INCX,INCY,LDA,M,N + CHARACTER TRANS +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER (ONE= (1.0D+0,0.0D+0)) + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY,LENX,LENY + LOGICAL NOCONJ +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG,MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. + + .NOT.LSAME(TRANS,'C')) THEN + INFO = 1 + ELSE IF (M.LT.0) THEN + INFO = 2 + ELSE IF (N.LT.0) THEN + INFO = 3 + ELSE IF (LDA.LT.MAX(1,M)) THEN + INFO = 6 + ELSE IF (INCX.EQ.0) THEN + INFO = 8 + ELSE IF (INCY.EQ.0) THEN + INFO = 11 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('ZGEMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. + + ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN +* + NOCONJ = LSAME(TRANS,'T') +* +* Set LENX and LENY, the lengths of the vectors x and y, and set +* up the start points in X and Y. +* + IF (LSAME(TRANS,'N')) THEN + LENX = N + LENY = M + ELSE + LENX = M + LENY = N + END IF + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (LENX-1)*INCX + END IF + IF (INCY.GT.0) THEN + KY = 1 + ELSE + KY = 1 - (LENY-1)*INCY + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* +* First form y := beta*y. +* + IF (BETA.NE.ONE) THEN + IF (INCY.EQ.1) THEN + IF (BETA.EQ.ZERO) THEN + DO 10 I = 1,LENY + Y(I) = ZERO + 10 CONTINUE + ELSE + DO 20 I = 1,LENY + Y(I) = BETA*Y(I) + 20 CONTINUE + END IF + ELSE + IY = KY + IF (BETA.EQ.ZERO) THEN + DO 30 I = 1,LENY + Y(IY) = ZERO + IY = IY + INCY + 30 CONTINUE + ELSE + DO 40 I = 1,LENY + Y(IY) = BETA*Y(IY) + IY = IY + INCY + 40 CONTINUE + END IF + END IF + END IF + IF (ALPHA.EQ.ZERO) RETURN + IF (LSAME(TRANS,'N')) THEN +* +* Form y := alpha*A*x + y. +* + JX = KX + IF (INCY.EQ.1) THEN + DO 60 J = 1,N + TEMP = ALPHA*X(JX) + DO 50 I = 1,M + Y(I) = Y(I) + TEMP*A(I,J) + 50 CONTINUE + JX = JX + INCX + 60 CONTINUE + ELSE + DO 80 J = 1,N + TEMP = ALPHA*X(JX) + IY = KY + DO 70 I = 1,M + Y(IY) = Y(IY) + TEMP*A(I,J) + IY = IY + INCY + 70 CONTINUE + JX = JX + INCX + 80 CONTINUE + END IF + ELSE +* +* Form y := alpha*A**T*x + y or y := alpha*A**H*x + y. +* + JY = KY + IF (INCX.EQ.1) THEN + DO 110 J = 1,N + TEMP = ZERO + IF (NOCONJ) THEN + DO 90 I = 1,M + TEMP = TEMP + A(I,J)*X(I) + 90 CONTINUE + ELSE + DO 100 I = 1,M + TEMP = TEMP + DCONJG(A(I,J))*X(I) + 100 CONTINUE + END IF + Y(JY) = Y(JY) + ALPHA*TEMP + JY = JY + INCY + 110 CONTINUE + ELSE + DO 140 J = 1,N + TEMP = ZERO + IX = KX + IF (NOCONJ) THEN + DO 120 I = 1,M + TEMP = TEMP + A(I,J)*X(IX) + IX = IX + INCX + 120 CONTINUE + ELSE + DO 130 I = 1,M + TEMP = TEMP + DCONJG(A(I,J))*X(IX) + IX = IX + INCX + 130 CONTINUE + END IF + Y(JY) = Y(JY) + ALPHA*TEMP + JY = JY + INCY + 140 CONTINUE + END IF + END IF +* + RETURN +* +* End of ZGEMV +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/zgerc.f b/fortran_implementation/external_libraries/BLAS/SRC/zgerc.f new file mode 100644 index 0000000..42060d3 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/zgerc.f @@ -0,0 +1,224 @@ +*> \brief \b ZGERC +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZGERC(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA +* INTEGER INCX,INCY,LDA,M,N +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGERC performs the rank 1 operation +*> +*> A := alpha*x*y**H + A, +*> +*> where alpha is a scalar, x is an m element vector, y is an n element +*> vector and A is an m by n matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix A. +*> M must be at least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX*16 +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is COMPLEX*16 array, dimension at least +*> ( 1 + ( m - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the m +*> element vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in] Y +*> \verbatim +*> Y is COMPLEX*16 array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCY ) ). +*> Before entry, the incremented array Y must contain the n +*> element vector y. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> Y. INCY must not be zero. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension ( LDA, N ) +*> Before entry, the leading m by n part of the array A must +*> contain the matrix of coefficients. On exit, A is +*> overwritten by the updated matrix. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> max( 1, m ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup ger +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZGERC(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX*16 ALPHA + INTEGER INCX,INCY,LDA,M,N +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,IX,J,JY,KX +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG,MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (M.LT.0) THEN + INFO = 1 + ELSE IF (N.LT.0) THEN + INFO = 2 + ELSE IF (INCX.EQ.0) THEN + INFO = 5 + ELSE IF (INCY.EQ.0) THEN + INFO = 7 + ELSE IF (LDA.LT.MAX(1,M)) THEN + INFO = 9 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('ZGERC ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* + IF (INCY.GT.0) THEN + JY = 1 + ELSE + JY = 1 - (N-1)*INCY + END IF + IF (INCX.EQ.1) THEN + DO 20 J = 1,N + IF (Y(JY).NE.ZERO) THEN + TEMP = ALPHA*DCONJG(Y(JY)) + DO 10 I = 1,M + A(I,J) = A(I,J) + X(I)*TEMP + 10 CONTINUE + END IF + JY = JY + INCY + 20 CONTINUE + ELSE + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (M-1)*INCX + END IF + DO 40 J = 1,N + IF (Y(JY).NE.ZERO) THEN + TEMP = ALPHA*DCONJG(Y(JY)) + IX = KX + DO 30 I = 1,M + A(I,J) = A(I,J) + X(IX)*TEMP + IX = IX + INCX + 30 CONTINUE + END IF + JY = JY + INCY + 40 CONTINUE + END IF +* + RETURN +* +* End of ZGERC +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/zgeru.f b/fortran_implementation/external_libraries/BLAS/SRC/zgeru.f new file mode 100644 index 0000000..65df5ed --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/zgeru.f @@ -0,0 +1,224 @@ +*> \brief \b ZGERU +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZGERU(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA +* INTEGER INCX,INCY,LDA,M,N +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGERU performs the rank 1 operation +*> +*> A := alpha*x*y**T + A, +*> +*> where alpha is a scalar, x is an m element vector, y is an n element +*> vector and A is an m by n matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix A. +*> M must be at least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX*16 +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is COMPLEX*16 array, dimension at least +*> ( 1 + ( m - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the m +*> element vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in] Y +*> \verbatim +*> Y is COMPLEX*16 array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCY ) ). +*> Before entry, the incremented array Y must contain the n +*> element vector y. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> Y. INCY must not be zero. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension ( LDA, N ) +*> Before entry, the leading m by n part of the array A must +*> contain the matrix of coefficients. On exit, A is +*> overwritten by the updated matrix. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> max( 1, m ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup ger +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZGERU(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX*16 ALPHA + INTEGER INCX,INCY,LDA,M,N +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,IX,J,JY,KX +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (M.LT.0) THEN + INFO = 1 + ELSE IF (N.LT.0) THEN + INFO = 2 + ELSE IF (INCX.EQ.0) THEN + INFO = 5 + ELSE IF (INCY.EQ.0) THEN + INFO = 7 + ELSE IF (LDA.LT.MAX(1,M)) THEN + INFO = 9 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('ZGERU ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* + IF (INCY.GT.0) THEN + JY = 1 + ELSE + JY = 1 - (N-1)*INCY + END IF + IF (INCX.EQ.1) THEN + DO 20 J = 1,N + IF (Y(JY).NE.ZERO) THEN + TEMP = ALPHA*Y(JY) + DO 10 I = 1,M + A(I,J) = A(I,J) + X(I)*TEMP + 10 CONTINUE + END IF + JY = JY + INCY + 20 CONTINUE + ELSE + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (M-1)*INCX + END IF + DO 40 J = 1,N + IF (Y(JY).NE.ZERO) THEN + TEMP = ALPHA*Y(JY) + IX = KX + DO 30 I = 1,M + A(I,J) = A(I,J) + X(IX)*TEMP + IX = IX + INCX + 30 CONTINUE + END IF + JY = JY + INCY + 40 CONTINUE + END IF +* + RETURN +* +* End of ZGERU +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/zhbmv.f b/fortran_implementation/external_libraries/BLAS/SRC/zhbmv.f new file mode 100644 index 0000000..c98a3e4 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/zhbmv.f @@ -0,0 +1,377 @@ +*> \brief \b ZHBMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZHBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA,BETA +* INTEGER INCX,INCY,K,LDA,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHBMV performs the matrix-vector operation +*> +*> y := alpha*A*x + beta*y, +*> +*> where alpha and beta are scalars, x and y are n element vectors and +*> A is an n by n hermitian band matrix, with k super-diagonals. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the band matrix A is being supplied as +*> follows: +*> +*> UPLO = 'U' or 'u' The upper triangular part of A is +*> being supplied. +*> +*> UPLO = 'L' or 'l' The lower triangular part of A is +*> being supplied. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry, K specifies the number of super-diagonals of the +*> matrix A. K must satisfy 0 .le. K. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX*16 +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension ( LDA, N ) +*> Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) +*> by n part of the array A must contain the upper triangular +*> band part of the hermitian matrix, supplied column by +*> column, with the leading diagonal of the matrix in row +*> ( k + 1 ) of the array, the first super-diagonal starting at +*> position 2 in row k, and so on. The top left k by k triangle +*> of the array A is not referenced. +*> The following program segment will transfer the upper +*> triangular part of a hermitian band matrix from conventional +*> full matrix storage to band storage: +*> +*> DO 20, J = 1, N +*> M = K + 1 - J +*> DO 10, I = MAX( 1, J - K ), J +*> A( M + I, J ) = matrix( I, J ) +*> 10 CONTINUE +*> 20 CONTINUE +*> +*> Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) +*> by n part of the array A must contain the lower triangular +*> band part of the hermitian matrix, supplied column by +*> column, with the leading diagonal of the matrix in row 1 of +*> the array, the first sub-diagonal starting at position 1 in +*> row 2, and so on. The bottom right k by k triangle of the +*> array A is not referenced. +*> The following program segment will transfer the lower +*> triangular part of a hermitian band matrix from conventional +*> full matrix storage to band storage: +*> +*> DO 20, J = 1, N +*> M = 1 - J +*> DO 10, I = J, MIN( N, J + K ) +*> A( M + I, J ) = matrix( I, J ) +*> 10 CONTINUE +*> 20 CONTINUE +*> +*> Note that the imaginary parts of the diagonal elements need +*> not be set and are assumed to be zero. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> ( k + 1 ). +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is COMPLEX*16 array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the +*> vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is COMPLEX*16 +*> On entry, BETA specifies the scalar beta. +*> \endverbatim +*> +*> \param[in,out] Y +*> \verbatim +*> Y is COMPLEX*16 array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCY ) ). +*> Before entry, the incremented array Y must contain the +*> vector y. On exit, Y is overwritten by the updated vector y. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> Y. INCY must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup hbmv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> The vector and matrix arguments are not referenced when N = 0, or M = 0 +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZHBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX*16 ALPHA,BETA + INTEGER INCX,INCY,K,LDA,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER (ONE= (1.0D+0,0.0D+0)) + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP1,TEMP2 + INTEGER I,INFO,IX,IY,J,JX,JY,KPLUS1,KX,KY,L +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE,DCONJG,MAX,MIN +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (N.LT.0) THEN + INFO = 2 + ELSE IF (K.LT.0) THEN + INFO = 3 + ELSE IF (LDA.LT. (K+1)) THEN + INFO = 6 + ELSE IF (INCX.EQ.0) THEN + INFO = 8 + ELSE IF (INCY.EQ.0) THEN + INFO = 11 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('ZHBMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN +* +* Set up the start points in X and Y. +* + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (N-1)*INCX + END IF + IF (INCY.GT.0) THEN + KY = 1 + ELSE + KY = 1 - (N-1)*INCY + END IF +* +* Start the operations. In this version the elements of the array A +* are accessed sequentially with one pass through A. +* +* First form y := beta*y. +* + IF (BETA.NE.ONE) THEN + IF (INCY.EQ.1) THEN + IF (BETA.EQ.ZERO) THEN + DO 10 I = 1,N + Y(I) = ZERO + 10 CONTINUE + ELSE + DO 20 I = 1,N + Y(I) = BETA*Y(I) + 20 CONTINUE + END IF + ELSE + IY = KY + IF (BETA.EQ.ZERO) THEN + DO 30 I = 1,N + Y(IY) = ZERO + IY = IY + INCY + 30 CONTINUE + ELSE + DO 40 I = 1,N + Y(IY) = BETA*Y(IY) + IY = IY + INCY + 40 CONTINUE + END IF + END IF + END IF + IF (ALPHA.EQ.ZERO) RETURN + IF (LSAME(UPLO,'U')) THEN +* +* Form y when upper triangle of A is stored. +* + KPLUS1 = K + 1 + IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN + DO 60 J = 1,N + TEMP1 = ALPHA*X(J) + TEMP2 = ZERO + L = KPLUS1 - J + DO 50 I = MAX(1,J-K),J - 1 + Y(I) = Y(I) + TEMP1*A(L+I,J) + TEMP2 = TEMP2 + DCONJG(A(L+I,J))*X(I) + 50 CONTINUE + Y(J) = Y(J) + TEMP1*DBLE(A(KPLUS1,J)) + ALPHA*TEMP2 + 60 CONTINUE + ELSE + JX = KX + JY = KY + DO 80 J = 1,N + TEMP1 = ALPHA*X(JX) + TEMP2 = ZERO + IX = KX + IY = KY + L = KPLUS1 - J + DO 70 I = MAX(1,J-K),J - 1 + Y(IY) = Y(IY) + TEMP1*A(L+I,J) + TEMP2 = TEMP2 + DCONJG(A(L+I,J))*X(IX) + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + Y(JY) = Y(JY) + TEMP1*DBLE(A(KPLUS1,J)) + ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + IF (J.GT.K) THEN + KX = KX + INCX + KY = KY + INCY + END IF + 80 CONTINUE + END IF + ELSE +* +* Form y when lower triangle of A is stored. +* + IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN + DO 100 J = 1,N + TEMP1 = ALPHA*X(J) + TEMP2 = ZERO + Y(J) = Y(J) + TEMP1*DBLE(A(1,J)) + L = 1 - J + DO 90 I = J + 1,MIN(N,J+K) + Y(I) = Y(I) + TEMP1*A(L+I,J) + TEMP2 = TEMP2 + DCONJG(A(L+I,J))*X(I) + 90 CONTINUE + Y(J) = Y(J) + ALPHA*TEMP2 + 100 CONTINUE + ELSE + JX = KX + JY = KY + DO 120 J = 1,N + TEMP1 = ALPHA*X(JX) + TEMP2 = ZERO + Y(JY) = Y(JY) + TEMP1*DBLE(A(1,J)) + L = 1 - J + IX = JX + IY = JY + DO 110 I = J + 1,MIN(N,J+K) + IX = IX + INCX + IY = IY + INCY + Y(IY) = Y(IY) + TEMP1*A(L+I,J) + TEMP2 = TEMP2 + DCONJG(A(L+I,J))*X(IX) + 110 CONTINUE + Y(JY) = Y(JY) + ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + 120 CONTINUE + END IF + END IF +* + RETURN +* +* End of ZHBMV +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/zhemm.f b/fortran_implementation/external_libraries/BLAS/SRC/zhemm.f new file mode 100644 index 0000000..3eb5ee6 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/zhemm.f @@ -0,0 +1,370 @@ +*> \brief \b ZHEMM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZHEMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA,BETA +* INTEGER LDA,LDB,LDC,M,N +* CHARACTER SIDE,UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHEMM performs one of the matrix-matrix operations +*> +*> C := alpha*A*B + beta*C, +*> +*> or +*> +*> C := alpha*B*A + beta*C, +*> +*> where alpha and beta are scalars, A is an hermitian matrix and B and +*> C are m by n matrices. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> On entry, SIDE specifies whether the hermitian matrix A +*> appears on the left or right in the operation as follows: +*> +*> SIDE = 'L' or 'l' C := alpha*A*B + beta*C, +*> +*> SIDE = 'R' or 'r' C := alpha*B*A + beta*C, +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the hermitian matrix A is to be +*> referenced as follows: +*> +*> UPLO = 'U' or 'u' Only the upper triangular part of the +*> hermitian matrix is to be referenced. +*> +*> UPLO = 'L' or 'l' Only the lower triangular part of the +*> hermitian matrix is to be referenced. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix C. +*> M must be at least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of the matrix C. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX*16 +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension ( LDA, ka ), where ka is +*> m when SIDE = 'L' or 'l' and is n otherwise. +*> Before entry with SIDE = 'L' or 'l', the m by m part of +*> the array A must contain the hermitian matrix, such that +*> when UPLO = 'U' or 'u', the leading m by m upper triangular +*> part of the array A must contain the upper triangular part +*> of the hermitian matrix and the strictly lower triangular +*> part of A is not referenced, and when UPLO = 'L' or 'l', +*> the leading m by m lower triangular part of the array A +*> must contain the lower triangular part of the hermitian +*> matrix and the strictly upper triangular part of A is not +*> referenced. +*> Before entry with SIDE = 'R' or 'r', the n by n part of +*> the array A must contain the hermitian matrix, such that +*> when UPLO = 'U' or 'u', the leading n by n upper triangular +*> part of the array A must contain the upper triangular part +*> of the hermitian matrix and the strictly lower triangular +*> part of A is not referenced, and when UPLO = 'L' or 'l', +*> the leading n by n lower triangular part of the array A +*> must contain the lower triangular part of the hermitian +*> matrix and the strictly upper triangular part of A is not +*> referenced. +*> Note that the imaginary parts of the diagonal elements need +*> not be set, they are assumed to be zero. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When SIDE = 'L' or 'l' then +*> LDA must be at least max( 1, m ), otherwise LDA must be at +*> least max( 1, n ). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is COMPLEX*16 array, dimension ( LDB, N ) +*> Before entry, the leading m by n part of the array B must +*> contain the matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. LDB must be at least +*> max( 1, m ). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is COMPLEX*16 +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then C need not be set on input. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX*16 array, dimension ( LDC, N ) +*> Before entry, the leading m by n part of the array C must +*> contain the matrix C, except when beta is zero, in which +*> case C need not be set on entry. +*> On exit, the array C is overwritten by the m by n updated +*> matrix. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> On entry, LDC specifies the first dimension of C as declared +*> in the calling (sub) program. LDC must be at least +*> max( 1, m ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup hemm +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> -- Written on 8-February-1989. +*> Jack Dongarra, Argonne National Laboratory. +*> Iain Duff, AERE Harwell. +*> Jeremy Du Croz, Numerical Algorithms Group Ltd. +*> Sven Hammarling, Numerical Algorithms Group Ltd. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZHEMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* -- Reference BLAS level3 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX*16 ALPHA,BETA + INTEGER LDA,LDB,LDC,M,N + CHARACTER SIDE,UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE,DCONJG,MAX +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP1,TEMP2 + INTEGER I,INFO,J,K,NROWA + LOGICAL UPPER +* .. +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER (ONE= (1.0D+0,0.0D+0)) + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* +* Set NROWA as the number of rows of A. +* + IF (LSAME(SIDE,'L')) THEN + NROWA = M + ELSE + NROWA = N + END IF + UPPER = LSAME(UPLO,'U') +* +* Test the input parameters. +* + INFO = 0 + IF ((.NOT.LSAME(SIDE,'L')) .AND. + + (.NOT.LSAME(SIDE,'R'))) THEN + INFO = 1 + ELSE IF ((.NOT.UPPER) .AND. + + (.NOT.LSAME(UPLO,'L'))) THEN + INFO = 2 + ELSE IF (M.LT.0) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 7 + ELSE IF (LDB.LT.MAX(1,M)) THEN + INFO = 9 + ELSE IF (LDC.LT.MAX(1,M)) THEN + INFO = 12 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('ZHEMM ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. + + ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + IF (BETA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,M + C(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1,N + DO 30 I = 1,M + C(I,J) = BETA*C(I,J) + 30 CONTINUE + 40 CONTINUE + END IF + RETURN + END IF +* +* Start the operations. +* + IF (LSAME(SIDE,'L')) THEN +* +* Form C := alpha*A*B + beta*C. +* + IF (UPPER) THEN + DO 70 J = 1,N + DO 60 I = 1,M + TEMP1 = ALPHA*B(I,J) + TEMP2 = ZERO + DO 50 K = 1,I - 1 + C(K,J) = C(K,J) + TEMP1*A(K,I) + TEMP2 = TEMP2 + B(K,J)*DCONJG(A(K,I)) + 50 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = TEMP1*DBLE(A(I,I)) + ALPHA*TEMP2 + ELSE + C(I,J) = BETA*C(I,J) + TEMP1*DBLE(A(I,I)) + + + ALPHA*TEMP2 + END IF + 60 CONTINUE + 70 CONTINUE + ELSE + DO 100 J = 1,N + DO 90 I = M,1,-1 + TEMP1 = ALPHA*B(I,J) + TEMP2 = ZERO + DO 80 K = I + 1,M + C(K,J) = C(K,J) + TEMP1*A(K,I) + TEMP2 = TEMP2 + B(K,J)*DCONJG(A(K,I)) + 80 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = TEMP1*DBLE(A(I,I)) + ALPHA*TEMP2 + ELSE + C(I,J) = BETA*C(I,J) + TEMP1*DBLE(A(I,I)) + + + ALPHA*TEMP2 + END IF + 90 CONTINUE + 100 CONTINUE + END IF + ELSE +* +* Form C := alpha*B*A + beta*C. +* + DO 170 J = 1,N + TEMP1 = ALPHA*DBLE(A(J,J)) + IF (BETA.EQ.ZERO) THEN + DO 110 I = 1,M + C(I,J) = TEMP1*B(I,J) + 110 CONTINUE + ELSE + DO 120 I = 1,M + C(I,J) = BETA*C(I,J) + TEMP1*B(I,J) + 120 CONTINUE + END IF + DO 140 K = 1,J - 1 + IF (UPPER) THEN + TEMP1 = ALPHA*A(K,J) + ELSE + TEMP1 = ALPHA*DCONJG(A(J,K)) + END IF + DO 130 I = 1,M + C(I,J) = C(I,J) + TEMP1*B(I,K) + 130 CONTINUE + 140 CONTINUE + DO 160 K = J + 1,N + IF (UPPER) THEN + TEMP1 = ALPHA*DCONJG(A(J,K)) + ELSE + TEMP1 = ALPHA*A(K,J) + END IF + DO 150 I = 1,M + C(I,J) = C(I,J) + TEMP1*B(I,K) + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE + END IF +* + RETURN +* +* End of ZHEMM +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/zhemv.f b/fortran_implementation/external_libraries/BLAS/SRC/zhemv.f new file mode 100644 index 0000000..444f156 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/zhemv.f @@ -0,0 +1,334 @@ +*> \brief \b ZHEMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZHEMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA,BETA +* INTEGER INCX,INCY,LDA,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHEMV performs the matrix-vector operation +*> +*> y := alpha*A*x + beta*y, +*> +*> where alpha and beta are scalars, x and y are n element vectors and +*> A is an n by n hermitian matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the array A is to be referenced as +*> follows: +*> +*> UPLO = 'U' or 'u' Only the upper triangular part of A +*> is to be referenced. +*> +*> UPLO = 'L' or 'l' Only the lower triangular part of A +*> is to be referenced. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX*16 +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension ( LDA, N ) +*> Before entry with UPLO = 'U' or 'u', the leading n by n +*> upper triangular part of the array A must contain the upper +*> triangular part of the hermitian matrix and the strictly +*> lower triangular part of A is not referenced. +*> Before entry with UPLO = 'L' or 'l', the leading n by n +*> lower triangular part of the array A must contain the lower +*> triangular part of the hermitian matrix and the strictly +*> upper triangular part of A is not referenced. +*> Note that the imaginary parts of the diagonal elements need +*> not be set and are assumed to be zero. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> max( 1, n ). +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is COMPLEX*16 array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is COMPLEX*16 +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then Y need not be set on input. +*> \endverbatim +*> +*> \param[in,out] Y +*> \verbatim +*> Y is COMPLEX*16 array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCY ) ). +*> Before entry, the incremented array Y must contain the n +*> element vector y. On exit, Y is overwritten by the updated +*> vector y. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> Y. INCY must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup hemv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> The vector and matrix arguments are not referenced when N = 0, or M = 0 +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZHEMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX*16 ALPHA,BETA + INTEGER INCX,INCY,LDA,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER (ONE= (1.0D+0,0.0D+0)) + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP1,TEMP2 + INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE,DCONJG,MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (N.LT.0) THEN + INFO = 2 + ELSE IF (LDA.LT.MAX(1,N)) THEN + INFO = 5 + ELSE IF (INCX.EQ.0) THEN + INFO = 7 + ELSE IF (INCY.EQ.0) THEN + INFO = 10 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('ZHEMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN +* +* Set up the start points in X and Y. +* + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (N-1)*INCX + END IF + IF (INCY.GT.0) THEN + KY = 1 + ELSE + KY = 1 - (N-1)*INCY + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through the triangular part +* of A. +* +* First form y := beta*y. +* + IF (BETA.NE.ONE) THEN + IF (INCY.EQ.1) THEN + IF (BETA.EQ.ZERO) THEN + DO 10 I = 1,N + Y(I) = ZERO + 10 CONTINUE + ELSE + DO 20 I = 1,N + Y(I) = BETA*Y(I) + 20 CONTINUE + END IF + ELSE + IY = KY + IF (BETA.EQ.ZERO) THEN + DO 30 I = 1,N + Y(IY) = ZERO + IY = IY + INCY + 30 CONTINUE + ELSE + DO 40 I = 1,N + Y(IY) = BETA*Y(IY) + IY = IY + INCY + 40 CONTINUE + END IF + END IF + END IF + IF (ALPHA.EQ.ZERO) RETURN + IF (LSAME(UPLO,'U')) THEN +* +* Form y when A is stored in upper triangle. +* + IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN + DO 60 J = 1,N + TEMP1 = ALPHA*X(J) + TEMP2 = ZERO + DO 50 I = 1,J - 1 + Y(I) = Y(I) + TEMP1*A(I,J) + TEMP2 = TEMP2 + DCONJG(A(I,J))*X(I) + 50 CONTINUE + Y(J) = Y(J) + TEMP1*DBLE(A(J,J)) + ALPHA*TEMP2 + 60 CONTINUE + ELSE + JX = KX + JY = KY + DO 80 J = 1,N + TEMP1 = ALPHA*X(JX) + TEMP2 = ZERO + IX = KX + IY = KY + DO 70 I = 1,J - 1 + Y(IY) = Y(IY) + TEMP1*A(I,J) + TEMP2 = TEMP2 + DCONJG(A(I,J))*X(IX) + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + Y(JY) = Y(JY) + TEMP1*DBLE(A(J,J)) + ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + 80 CONTINUE + END IF + ELSE +* +* Form y when A is stored in lower triangle. +* + IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN + DO 100 J = 1,N + TEMP1 = ALPHA*X(J) + TEMP2 = ZERO + Y(J) = Y(J) + TEMP1*DBLE(A(J,J)) + DO 90 I = J + 1,N + Y(I) = Y(I) + TEMP1*A(I,J) + TEMP2 = TEMP2 + DCONJG(A(I,J))*X(I) + 90 CONTINUE + Y(J) = Y(J) + ALPHA*TEMP2 + 100 CONTINUE + ELSE + JX = KX + JY = KY + DO 120 J = 1,N + TEMP1 = ALPHA*X(JX) + TEMP2 = ZERO + Y(JY) = Y(JY) + TEMP1*DBLE(A(J,J)) + IX = JX + IY = JY + DO 110 I = J + 1,N + IX = IX + INCX + IY = IY + INCY + Y(IY) = Y(IY) + TEMP1*A(I,J) + TEMP2 = TEMP2 + DCONJG(A(I,J))*X(IX) + 110 CONTINUE + Y(JY) = Y(JY) + ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + 120 CONTINUE + END IF + END IF +* + RETURN +* +* End of ZHEMV +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/zher.f b/fortran_implementation/external_libraries/BLAS/SRC/zher.f new file mode 100644 index 0000000..fd4265e --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/zher.f @@ -0,0 +1,275 @@ +*> \brief \b ZHER +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZHER(UPLO,N,ALPHA,X,INCX,A,LDA) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION ALPHA +* INTEGER INCX,LDA,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHER performs the hermitian rank 1 operation +*> +*> A := alpha*x*x**H + A, +*> +*> where alpha is a real scalar, x is an n element vector and A is an +*> n by n hermitian matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the array A is to be referenced as +*> follows: +*> +*> UPLO = 'U' or 'u' Only the upper triangular part of A +*> is to be referenced. +*> +*> UPLO = 'L' or 'l' Only the lower triangular part of A +*> is to be referenced. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is DOUBLE PRECISION. +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is COMPLEX*16 array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension ( LDA, N ) +*> Before entry with UPLO = 'U' or 'u', the leading n by n +*> upper triangular part of the array A must contain the upper +*> triangular part of the hermitian matrix and the strictly +*> lower triangular part of A is not referenced. On exit, the +*> upper triangular part of the array A is overwritten by the +*> upper triangular part of the updated matrix. +*> Before entry with UPLO = 'L' or 'l', the leading n by n +*> lower triangular part of the array A must contain the lower +*> triangular part of the hermitian matrix and the strictly +*> upper triangular part of A is not referenced. On exit, the +*> lower triangular part of the array A is overwritten by the +*> lower triangular part of the updated matrix. +*> Note that the imaginary parts of the diagonal elements need +*> not be set, they are assumed to be zero, and on exit they +*> are set to zero. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> max( 1, n ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup her +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZHER(UPLO,N,ALPHA,X,INCX,A,LDA) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA + INTEGER INCX,LDA,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,IX,J,JX,KX +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE,DCONJG,MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (N.LT.0) THEN + INFO = 2 + ELSE IF (INCX.EQ.0) THEN + INFO = 5 + ELSE IF (LDA.LT.MAX(1,N)) THEN + INFO = 7 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('ZHER ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. (ALPHA.EQ.DBLE(ZERO))) RETURN +* +* Set the start point in X if the increment is not unity. +* + IF (INCX.LE.0) THEN + KX = 1 - (N-1)*INCX + ELSE IF (INCX.NE.1) THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through the triangular part +* of A. +* + IF (LSAME(UPLO,'U')) THEN +* +* Form A when A is stored in upper triangle. +* + IF (INCX.EQ.1) THEN + DO 20 J = 1,N + IF (X(J).NE.ZERO) THEN + TEMP = ALPHA*DCONJG(X(J)) + DO 10 I = 1,J - 1 + A(I,J) = A(I,J) + X(I)*TEMP + 10 CONTINUE + A(J,J) = DBLE(A(J,J)) + DBLE(X(J)*TEMP) + ELSE + A(J,J) = DBLE(A(J,J)) + END IF + 20 CONTINUE + ELSE + JX = KX + DO 40 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = ALPHA*DCONJG(X(JX)) + IX = KX + DO 30 I = 1,J - 1 + A(I,J) = A(I,J) + X(IX)*TEMP + IX = IX + INCX + 30 CONTINUE + A(J,J) = DBLE(A(J,J)) + DBLE(X(JX)*TEMP) + ELSE + A(J,J) = DBLE(A(J,J)) + END IF + JX = JX + INCX + 40 CONTINUE + END IF + ELSE +* +* Form A when A is stored in lower triangle. +* + IF (INCX.EQ.1) THEN + DO 60 J = 1,N + IF (X(J).NE.ZERO) THEN + TEMP = ALPHA*DCONJG(X(J)) + A(J,J) = DBLE(A(J,J)) + DBLE(TEMP*X(J)) + DO 50 I = J + 1,N + A(I,J) = A(I,J) + X(I)*TEMP + 50 CONTINUE + ELSE + A(J,J) = DBLE(A(J,J)) + END IF + 60 CONTINUE + ELSE + JX = KX + DO 80 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = ALPHA*DCONJG(X(JX)) + A(J,J) = DBLE(A(J,J)) + DBLE(TEMP*X(JX)) + IX = JX + DO 70 I = J + 1,N + IX = IX + INCX + A(I,J) = A(I,J) + X(IX)*TEMP + 70 CONTINUE + ELSE + A(J,J) = DBLE(A(J,J)) + END IF + JX = JX + INCX + 80 CONTINUE + END IF + END IF +* + RETURN +* +* End of ZHER +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/zher2.f b/fortran_implementation/external_libraries/BLAS/SRC/zher2.f new file mode 100644 index 0000000..7d0a553 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/zher2.f @@ -0,0 +1,314 @@ +*> \brief \b ZHER2 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZHER2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA +* INTEGER INCX,INCY,LDA,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHER2 performs the hermitian rank 2 operation +*> +*> A := alpha*x*y**H + conjg( alpha )*y*x**H + A, +*> +*> where alpha is a scalar, x and y are n element vectors and A is an n +*> by n hermitian matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the array A is to be referenced as +*> follows: +*> +*> UPLO = 'U' or 'u' Only the upper triangular part of A +*> is to be referenced. +*> +*> UPLO = 'L' or 'l' Only the lower triangular part of A +*> is to be referenced. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX*16 +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is COMPLEX*16 array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in] Y +*> \verbatim +*> Y is COMPLEX*16 array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCY ) ). +*> Before entry, the incremented array Y must contain the n +*> element vector y. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> Y. INCY must not be zero. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension ( LDA, N ) +*> Before entry with UPLO = 'U' or 'u', the leading n by n +*> upper triangular part of the array A must contain the upper +*> triangular part of the hermitian matrix and the strictly +*> lower triangular part of A is not referenced. On exit, the +*> upper triangular part of the array A is overwritten by the +*> upper triangular part of the updated matrix. +*> Before entry with UPLO = 'L' or 'l', the leading n by n +*> lower triangular part of the array A must contain the lower +*> triangular part of the hermitian matrix and the strictly +*> upper triangular part of A is not referenced. On exit, the +*> lower triangular part of the array A is overwritten by the +*> lower triangular part of the updated matrix. +*> Note that the imaginary parts of the diagonal elements need +*> not be set, they are assumed to be zero, and on exit they +*> are set to zero. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> max( 1, n ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup her2 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZHER2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX*16 ALPHA + INTEGER INCX,INCY,LDA,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP1,TEMP2 + INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE,DCONJG,MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (N.LT.0) THEN + INFO = 2 + ELSE IF (INCX.EQ.0) THEN + INFO = 5 + ELSE IF (INCY.EQ.0) THEN + INFO = 7 + ELSE IF (LDA.LT.MAX(1,N)) THEN + INFO = 9 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('ZHER2 ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN +* +* Set up the start points in X and Y if the increments are not both +* unity. +* + IF ((INCX.NE.1) .OR. (INCY.NE.1)) THEN + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (N-1)*INCX + END IF + IF (INCY.GT.0) THEN + KY = 1 + ELSE + KY = 1 - (N-1)*INCY + END IF + JX = KX + JY = KY + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through the triangular part +* of A. +* + IF (LSAME(UPLO,'U')) THEN +* +* Form A when A is stored in the upper triangle. +* + IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN + DO 20 J = 1,N + IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN + TEMP1 = ALPHA*DCONJG(Y(J)) + TEMP2 = DCONJG(ALPHA*X(J)) + DO 10 I = 1,J - 1 + A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2 + 10 CONTINUE + A(J,J) = DBLE(A(J,J)) + + + DBLE(X(J)*TEMP1+Y(J)*TEMP2) + ELSE + A(J,J) = DBLE(A(J,J)) + END IF + 20 CONTINUE + ELSE + DO 40 J = 1,N + IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN + TEMP1 = ALPHA*DCONJG(Y(JY)) + TEMP2 = DCONJG(ALPHA*X(JX)) + IX = KX + IY = KY + DO 30 I = 1,J - 1 + A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2 + IX = IX + INCX + IY = IY + INCY + 30 CONTINUE + A(J,J) = DBLE(A(J,J)) + + + DBLE(X(JX)*TEMP1+Y(JY)*TEMP2) + ELSE + A(J,J) = DBLE(A(J,J)) + END IF + JX = JX + INCX + JY = JY + INCY + 40 CONTINUE + END IF + ELSE +* +* Form A when A is stored in the lower triangle. +* + IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN + DO 60 J = 1,N + IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN + TEMP1 = ALPHA*DCONJG(Y(J)) + TEMP2 = DCONJG(ALPHA*X(J)) + A(J,J) = DBLE(A(J,J)) + + + DBLE(X(J)*TEMP1+Y(J)*TEMP2) + DO 50 I = J + 1,N + A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2 + 50 CONTINUE + ELSE + A(J,J) = DBLE(A(J,J)) + END IF + 60 CONTINUE + ELSE + DO 80 J = 1,N + IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN + TEMP1 = ALPHA*DCONJG(Y(JY)) + TEMP2 = DCONJG(ALPHA*X(JX)) + A(J,J) = DBLE(A(J,J)) + + + DBLE(X(JX)*TEMP1+Y(JY)*TEMP2) + IX = JX + IY = JY + DO 70 I = J + 1,N + IX = IX + INCX + IY = IY + INCY + A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2 + 70 CONTINUE + ELSE + A(J,J) = DBLE(A(J,J)) + END IF + JX = JX + INCX + JY = JY + INCY + 80 CONTINUE + END IF + END IF +* + RETURN +* +* End of ZHER2 +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/zher2k.f b/fortran_implementation/external_libraries/BLAS/SRC/zher2k.f new file mode 100644 index 0000000..f507ff2 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/zher2k.f @@ -0,0 +1,440 @@ +*> \brief \b ZHER2K +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZHER2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA +* DOUBLE PRECISION BETA +* INTEGER K,LDA,LDB,LDC,N +* CHARACTER TRANS,UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHER2K performs one of the hermitian rank 2k operations +*> +*> C := alpha*A*B**H + conjg( alpha )*B*A**H + beta*C, +*> +*> or +*> +*> C := alpha*A**H*B + conjg( alpha )*B**H*A + beta*C, +*> +*> where alpha and beta are scalars with beta real, C is an n by n +*> hermitian matrix and A and B are n by k matrices in the first case +*> and k by n matrices in the second case. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the array C is to be referenced as +*> follows: +*> +*> UPLO = 'U' or 'u' Only the upper triangular part of C +*> is to be referenced. +*> +*> UPLO = 'L' or 'l' Only the lower triangular part of C +*> is to be referenced. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the operation to be performed as +*> follows: +*> +*> TRANS = 'N' or 'n' C := alpha*A*B**H + +*> conjg( alpha )*B*A**H + +*> beta*C. +*> +*> TRANS = 'C' or 'c' C := alpha*A**H*B + +*> conjg( alpha )*B**H*A + +*> beta*C. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix C. N must be +*> at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry with TRANS = 'N' or 'n', K specifies the number +*> of columns of the matrices A and B, and on entry with +*> TRANS = 'C' or 'c', K specifies the number of rows of the +*> matrices A and B. K must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX*16 . +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension ( LDA, ka ), where ka is +*> k when TRANS = 'N' or 'n', and is n otherwise. +*> Before entry with TRANS = 'N' or 'n', the leading n by k +*> part of the array A must contain the matrix A, otherwise +*> the leading k by n part of the array A must contain the +*> matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When TRANS = 'N' or 'n' +*> then LDA must be at least max( 1, n ), otherwise LDA must +*> be at least max( 1, k ). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is COMPLEX*16 array, dimension ( LDB, kb ), where kb is +*> k when TRANS = 'N' or 'n', and is n otherwise. +*> Before entry with TRANS = 'N' or 'n', the leading n by k +*> part of the array B must contain the matrix B, otherwise +*> the leading k by n part of the array B must contain the +*> matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. When TRANS = 'N' or 'n' +*> then LDB must be at least max( 1, n ), otherwise LDB must +*> be at least max( 1, k ). +*> Unchanged on exit. +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is DOUBLE PRECISION . +*> On entry, BETA specifies the scalar beta. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX*16 array, dimension ( LDC, N ) +*> Before entry with UPLO = 'U' or 'u', the leading n by n +*> upper triangular part of the array C must contain the upper +*> triangular part of the hermitian matrix and the strictly +*> lower triangular part of C is not referenced. On exit, the +*> upper triangular part of the array C is overwritten by the +*> upper triangular part of the updated matrix. +*> Before entry with UPLO = 'L' or 'l', the leading n by n +*> lower triangular part of the array C must contain the lower +*> triangular part of the hermitian matrix and the strictly +*> upper triangular part of C is not referenced. On exit, the +*> lower triangular part of the array C is overwritten by the +*> lower triangular part of the updated matrix. +*> Note that the imaginary parts of the diagonal elements need +*> not be set, they are assumed to be zero, and on exit they +*> are set to zero. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> On entry, LDC specifies the first dimension of C as declared +*> in the calling (sub) program. LDC must be at least +*> max( 1, n ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup her2k +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> -- Written on 8-February-1989. +*> Jack Dongarra, Argonne National Laboratory. +*> Iain Duff, AERE Harwell. +*> Jeremy Du Croz, Numerical Algorithms Group Ltd. +*> Sven Hammarling, Numerical Algorithms Group Ltd. +*> +*> -- Modified 8-Nov-93 to set C(J,J) to DBLE( C(J,J) ) when BETA = 1. +*> Ed Anderson, Cray Research Inc. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZHER2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* -- Reference BLAS level3 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX*16 ALPHA + DOUBLE PRECISION BETA + INTEGER K,LDA,LDB,LDC,N + CHARACTER TRANS,UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE,DCONJG,MAX +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP1,TEMP2 + INTEGER I,INFO,J,L,NROWA + LOGICAL UPPER +* .. +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER (ONE=1.0D+0) + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* +* Test the input parameters. +* + IF (LSAME(TRANS,'N')) THEN + NROWA = N + ELSE + NROWA = K + END IF + UPPER = LSAME(UPLO,'U') +* + INFO = 0 + IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN + INFO = 1 + ELSE IF ((.NOT.LSAME(TRANS,'N')) .AND. + + (.NOT.LSAME(TRANS,'C'))) THEN + INFO = 2 + ELSE IF (N.LT.0) THEN + INFO = 3 + ELSE IF (K.LT.0) THEN + INFO = 4 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 7 + ELSE IF (LDB.LT.MAX(1,NROWA)) THEN + INFO = 9 + ELSE IF (LDC.LT.MAX(1,N)) THEN + INFO = 12 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('ZHER2K',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR. + + (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + IF (UPPER) THEN + IF (BETA.EQ.DBLE(ZERO)) THEN + DO 20 J = 1,N + DO 10 I = 1,J + C(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1,N + DO 30 I = 1,J - 1 + C(I,J) = BETA*C(I,J) + 30 CONTINUE + C(J,J) = BETA*DBLE(C(J,J)) + 40 CONTINUE + END IF + ELSE + IF (BETA.EQ.DBLE(ZERO)) THEN + DO 60 J = 1,N + DO 50 I = J,N + C(I,J) = ZERO + 50 CONTINUE + 60 CONTINUE + ELSE + DO 80 J = 1,N + C(J,J) = BETA*DBLE(C(J,J)) + DO 70 I = J + 1,N + C(I,J) = BETA*C(I,J) + 70 CONTINUE + 80 CONTINUE + END IF + END IF + RETURN + END IF +* +* Start the operations. +* + IF (LSAME(TRANS,'N')) THEN +* +* Form C := alpha*A*B**H + conjg( alpha )*B*A**H + +* C. +* + IF (UPPER) THEN + DO 130 J = 1,N + IF (BETA.EQ.DBLE(ZERO)) THEN + DO 90 I = 1,J + C(I,J) = ZERO + 90 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 100 I = 1,J - 1 + C(I,J) = BETA*C(I,J) + 100 CONTINUE + C(J,J) = BETA*DBLE(C(J,J)) + ELSE + C(J,J) = DBLE(C(J,J)) + END IF + DO 120 L = 1,K + IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN + TEMP1 = ALPHA*DCONJG(B(J,L)) + TEMP2 = DCONJG(ALPHA*A(J,L)) + DO 110 I = 1,J - 1 + C(I,J) = C(I,J) + A(I,L)*TEMP1 + + + B(I,L)*TEMP2 + 110 CONTINUE + C(J,J) = DBLE(C(J,J)) + + + DBLE(A(J,L)*TEMP1+B(J,L)*TEMP2) + END IF + 120 CONTINUE + 130 CONTINUE + ELSE + DO 180 J = 1,N + IF (BETA.EQ.DBLE(ZERO)) THEN + DO 140 I = J,N + C(I,J) = ZERO + 140 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 150 I = J + 1,N + C(I,J) = BETA*C(I,J) + 150 CONTINUE + C(J,J) = BETA*DBLE(C(J,J)) + ELSE + C(J,J) = DBLE(C(J,J)) + END IF + DO 170 L = 1,K + IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN + TEMP1 = ALPHA*DCONJG(B(J,L)) + TEMP2 = DCONJG(ALPHA*A(J,L)) + DO 160 I = J + 1,N + C(I,J) = C(I,J) + A(I,L)*TEMP1 + + + B(I,L)*TEMP2 + 160 CONTINUE + C(J,J) = DBLE(C(J,J)) + + + DBLE(A(J,L)*TEMP1+B(J,L)*TEMP2) + END IF + 170 CONTINUE + 180 CONTINUE + END IF + ELSE +* +* Form C := alpha*A**H*B + conjg( alpha )*B**H*A + +* C. +* + IF (UPPER) THEN + DO 210 J = 1,N + DO 200 I = 1,J + TEMP1 = ZERO + TEMP2 = ZERO + DO 190 L = 1,K + TEMP1 = TEMP1 + DCONJG(A(L,I))*B(L,J) + TEMP2 = TEMP2 + DCONJG(B(L,I))*A(L,J) + 190 CONTINUE + IF (I.EQ.J) THEN + IF (BETA.EQ.DBLE(ZERO)) THEN + C(J,J) = DBLE(ALPHA*TEMP1+ + + DCONJG(ALPHA)*TEMP2) + ELSE + C(J,J) = BETA*DBLE(C(J,J)) + + + DBLE(ALPHA*TEMP1+ + + DCONJG(ALPHA)*TEMP2) + END IF + ELSE + IF (BETA.EQ.DBLE(ZERO)) THEN + C(I,J) = ALPHA*TEMP1 + DCONJG(ALPHA)*TEMP2 + ELSE + C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 + + + DCONJG(ALPHA)*TEMP2 + END IF + END IF + 200 CONTINUE + 210 CONTINUE + ELSE + DO 240 J = 1,N + DO 230 I = J,N + TEMP1 = ZERO + TEMP2 = ZERO + DO 220 L = 1,K + TEMP1 = TEMP1 + DCONJG(A(L,I))*B(L,J) + TEMP2 = TEMP2 + DCONJG(B(L,I))*A(L,J) + 220 CONTINUE + IF (I.EQ.J) THEN + IF (BETA.EQ.DBLE(ZERO)) THEN + C(J,J) = DBLE(ALPHA*TEMP1+ + + DCONJG(ALPHA)*TEMP2) + ELSE + C(J,J) = BETA*DBLE(C(J,J)) + + + DBLE(ALPHA*TEMP1+ + + DCONJG(ALPHA)*TEMP2) + END IF + ELSE + IF (BETA.EQ.DBLE(ZERO)) THEN + C(I,J) = ALPHA*TEMP1 + DCONJG(ALPHA)*TEMP2 + ELSE + C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 + + + DCONJG(ALPHA)*TEMP2 + END IF + END IF + 230 CONTINUE + 240 CONTINUE + END IF + END IF +* + RETURN +* +* End of ZHER2K +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/zherk.f b/fortran_implementation/external_libraries/BLAS/SRC/zherk.f new file mode 100644 index 0000000..ebe35d5 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/zherk.f @@ -0,0 +1,393 @@ +*> \brief \b ZHERK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZHERK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION ALPHA,BETA +* INTEGER K,LDA,LDC,N +* CHARACTER TRANS,UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHERK performs one of the hermitian rank k operations +*> +*> C := alpha*A*A**H + beta*C, +*> +*> or +*> +*> C := alpha*A**H*A + beta*C, +*> +*> where alpha and beta are real scalars, C is an n by n hermitian +*> matrix and A is an n by k matrix in the first case and a k by n +*> matrix in the second case. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the array C is to be referenced as +*> follows: +*> +*> UPLO = 'U' or 'u' Only the upper triangular part of C +*> is to be referenced. +*> +*> UPLO = 'L' or 'l' Only the lower triangular part of C +*> is to be referenced. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the operation to be performed as +*> follows: +*> +*> TRANS = 'N' or 'n' C := alpha*A*A**H + beta*C. +*> +*> TRANS = 'C' or 'c' C := alpha*A**H*A + beta*C. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix C. N must be +*> at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry with TRANS = 'N' or 'n', K specifies the number +*> of columns of the matrix A, and on entry with +*> TRANS = 'C' or 'c', K specifies the number of rows of the +*> matrix A. K must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is DOUBLE PRECISION . +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension ( LDA, ka ), where ka is +*> k when TRANS = 'N' or 'n', and is n otherwise. +*> Before entry with TRANS = 'N' or 'n', the leading n by k +*> part of the array A must contain the matrix A, otherwise +*> the leading k by n part of the array A must contain the +*> matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When TRANS = 'N' or 'n' +*> then LDA must be at least max( 1, n ), otherwise LDA must +*> be at least max( 1, k ). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is DOUBLE PRECISION. +*> On entry, BETA specifies the scalar beta. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX*16 array, dimension ( LDC, N ) +*> Before entry with UPLO = 'U' or 'u', the leading n by n +*> upper triangular part of the array C must contain the upper +*> triangular part of the hermitian matrix and the strictly +*> lower triangular part of C is not referenced. On exit, the +*> upper triangular part of the array C is overwritten by the +*> upper triangular part of the updated matrix. +*> Before entry with UPLO = 'L' or 'l', the leading n by n +*> lower triangular part of the array C must contain the lower +*> triangular part of the hermitian matrix and the strictly +*> upper triangular part of C is not referenced. On exit, the +*> lower triangular part of the array C is overwritten by the +*> lower triangular part of the updated matrix. +*> Note that the imaginary parts of the diagonal elements need +*> not be set, they are assumed to be zero, and on exit they +*> are set to zero. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> On entry, LDC specifies the first dimension of C as declared +*> in the calling (sub) program. LDC must be at least +*> max( 1, n ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup herk +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> -- Written on 8-February-1989. +*> Jack Dongarra, Argonne National Laboratory. +*> Iain Duff, AERE Harwell. +*> Jeremy Du Croz, Numerical Algorithms Group Ltd. +*> Sven Hammarling, Numerical Algorithms Group Ltd. +*> +*> -- Modified 8-Nov-93 to set C(J,J) to DBLE( C(J,J) ) when BETA = 1. +*> Ed Anderson, Cray Research Inc. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZHERK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) +* +* -- Reference BLAS level3 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA,BETA + INTEGER K,LDA,LDC,N + CHARACTER TRANS,UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE,DCMPLX,DCONJG,MAX +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + DOUBLE PRECISION RTEMP + INTEGER I,INFO,J,L,NROWA + LOGICAL UPPER +* .. +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) +* .. +* +* Test the input parameters. +* + IF (LSAME(TRANS,'N')) THEN + NROWA = N + ELSE + NROWA = K + END IF + UPPER = LSAME(UPLO,'U') +* + INFO = 0 + IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN + INFO = 1 + ELSE IF ((.NOT.LSAME(TRANS,'N')) .AND. + + (.NOT.LSAME(TRANS,'C'))) THEN + INFO = 2 + ELSE IF (N.LT.0) THEN + INFO = 3 + ELSE IF (K.LT.0) THEN + INFO = 4 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 7 + ELSE IF (LDC.LT.MAX(1,N)) THEN + INFO = 10 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('ZHERK ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR. + + (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + IF (UPPER) THEN + IF (BETA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,J + C(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1,N + DO 30 I = 1,J - 1 + C(I,J) = BETA*C(I,J) + 30 CONTINUE + C(J,J) = BETA*DBLE(C(J,J)) + 40 CONTINUE + END IF + ELSE + IF (BETA.EQ.ZERO) THEN + DO 60 J = 1,N + DO 50 I = J,N + C(I,J) = ZERO + 50 CONTINUE + 60 CONTINUE + ELSE + DO 80 J = 1,N + C(J,J) = BETA*DBLE(C(J,J)) + DO 70 I = J + 1,N + C(I,J) = BETA*C(I,J) + 70 CONTINUE + 80 CONTINUE + END IF + END IF + RETURN + END IF +* +* Start the operations. +* + IF (LSAME(TRANS,'N')) THEN +* +* Form C := alpha*A*A**H + beta*C. +* + IF (UPPER) THEN + DO 130 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 90 I = 1,J + C(I,J) = ZERO + 90 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 100 I = 1,J - 1 + C(I,J) = BETA*C(I,J) + 100 CONTINUE + C(J,J) = BETA*DBLE(C(J,J)) + ELSE + C(J,J) = DBLE(C(J,J)) + END IF + DO 120 L = 1,K + IF (A(J,L).NE.DCMPLX(ZERO)) THEN + TEMP = ALPHA*DCONJG(A(J,L)) + DO 110 I = 1,J - 1 + C(I,J) = C(I,J) + TEMP*A(I,L) + 110 CONTINUE + C(J,J) = DBLE(C(J,J)) + DBLE(TEMP*A(I,L)) + END IF + 120 CONTINUE + 130 CONTINUE + ELSE + DO 180 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 140 I = J,N + C(I,J) = ZERO + 140 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + C(J,J) = BETA*DBLE(C(J,J)) + DO 150 I = J + 1,N + C(I,J) = BETA*C(I,J) + 150 CONTINUE + ELSE + C(J,J) = DBLE(C(J,J)) + END IF + DO 170 L = 1,K + IF (A(J,L).NE.DCMPLX(ZERO)) THEN + TEMP = ALPHA*DCONJG(A(J,L)) + C(J,J) = DBLE(C(J,J)) + DBLE(TEMP*A(J,L)) + DO 160 I = J + 1,N + C(I,J) = C(I,J) + TEMP*A(I,L) + 160 CONTINUE + END IF + 170 CONTINUE + 180 CONTINUE + END IF + ELSE +* +* Form C := alpha*A**H*A + beta*C. +* + IF (UPPER) THEN + DO 220 J = 1,N + DO 200 I = 1,J - 1 + TEMP = ZERO + DO 190 L = 1,K + TEMP = TEMP + DCONJG(A(L,I))*A(L,J) + 190 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 200 CONTINUE + RTEMP = ZERO + DO 210 L = 1,K + RTEMP = RTEMP + DBLE(DCONJG(A(L,J))*A(L,J)) + 210 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(J,J) = ALPHA*RTEMP + ELSE + C(J,J) = ALPHA*RTEMP + BETA*DBLE(C(J,J)) + END IF + 220 CONTINUE + ELSE + DO 260 J = 1,N + RTEMP = ZERO + DO 230 L = 1,K + RTEMP = RTEMP + DBLE(DCONJG(A(L,J))*A(L,J)) + 230 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(J,J) = ALPHA*RTEMP + ELSE + C(J,J) = ALPHA*RTEMP + BETA*DBLE(C(J,J)) + END IF + DO 250 I = J + 1,N + TEMP = ZERO + DO 240 L = 1,K + TEMP = TEMP + DCONJG(A(L,I))*A(L,J) + 240 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 250 CONTINUE + 260 CONTINUE + END IF + END IF +* + RETURN +* +* End of ZHERK +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/zhpmv.f b/fortran_implementation/external_libraries/BLAS/SRC/zhpmv.f new file mode 100644 index 0000000..ac12365 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/zhpmv.f @@ -0,0 +1,335 @@ +*> \brief \b ZHPMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZHPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA,BETA +* INTEGER INCX,INCY,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 AP(*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHPMV performs the matrix-vector operation +*> +*> y := alpha*A*x + beta*y, +*> +*> where alpha and beta are scalars, x and y are n element vectors and +*> A is an n by n hermitian matrix, supplied in packed form. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the matrix A is supplied in the packed +*> array AP as follows: +*> +*> UPLO = 'U' or 'u' The upper triangular part of A is +*> supplied in AP. +*> +*> UPLO = 'L' or 'l' The lower triangular part of A is +*> supplied in AP. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX*16 +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] AP +*> \verbatim +*> AP is COMPLEX*16 array, dimension at least +*> ( ( n*( n + 1 ) )/2 ). +*> Before entry with UPLO = 'U' or 'u', the array AP must +*> contain the upper triangular part of the hermitian matrix +*> packed sequentially, column by column, so that AP( 1 ) +*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) +*> and a( 2, 2 ) respectively, and so on. +*> Before entry with UPLO = 'L' or 'l', the array AP must +*> contain the lower triangular part of the hermitian matrix +*> packed sequentially, column by column, so that AP( 1 ) +*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) +*> and a( 3, 1 ) respectively, and so on. +*> Note that the imaginary parts of the diagonal elements need +*> not be set and are assumed to be zero. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is COMPLEX*16 array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is COMPLEX*16 +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then Y need not be set on input. +*> \endverbatim +*> +*> \param[in,out] Y +*> \verbatim +*> Y is COMPLEX*16 array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCY ) ). +*> Before entry, the incremented array Y must contain the n +*> element vector y. On exit, Y is overwritten by the updated +*> vector y. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> Y. INCY must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup hpmv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> The vector and matrix arguments are not referenced when N = 0, or M = 0 +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZHPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX*16 ALPHA,BETA + INTEGER INCX,INCY,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 AP(*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER (ONE= (1.0D+0,0.0D+0)) + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP1,TEMP2 + INTEGER I,INFO,IX,IY,J,JX,JY,K,KK,KX,KY +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE,DCONJG +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (N.LT.0) THEN + INFO = 2 + ELSE IF (INCX.EQ.0) THEN + INFO = 6 + ELSE IF (INCY.EQ.0) THEN + INFO = 9 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('ZHPMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN +* +* Set up the start points in X and Y. +* + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (N-1)*INCX + END IF + IF (INCY.GT.0) THEN + KY = 1 + ELSE + KY = 1 - (N-1)*INCY + END IF +* +* Start the operations. In this version the elements of the array AP +* are accessed sequentially with one pass through AP. +* +* First form y := beta*y. +* + IF (BETA.NE.ONE) THEN + IF (INCY.EQ.1) THEN + IF (BETA.EQ.ZERO) THEN + DO 10 I = 1,N + Y(I) = ZERO + 10 CONTINUE + ELSE + DO 20 I = 1,N + Y(I) = BETA*Y(I) + 20 CONTINUE + END IF + ELSE + IY = KY + IF (BETA.EQ.ZERO) THEN + DO 30 I = 1,N + Y(IY) = ZERO + IY = IY + INCY + 30 CONTINUE + ELSE + DO 40 I = 1,N + Y(IY) = BETA*Y(IY) + IY = IY + INCY + 40 CONTINUE + END IF + END IF + END IF + IF (ALPHA.EQ.ZERO) RETURN + KK = 1 + IF (LSAME(UPLO,'U')) THEN +* +* Form y when AP contains the upper triangle. +* + IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN + DO 60 J = 1,N + TEMP1 = ALPHA*X(J) + TEMP2 = ZERO + K = KK + DO 50 I = 1,J - 1 + Y(I) = Y(I) + TEMP1*AP(K) + TEMP2 = TEMP2 + DCONJG(AP(K))*X(I) + K = K + 1 + 50 CONTINUE + Y(J) = Y(J) + TEMP1*DBLE(AP(KK+J-1)) + ALPHA*TEMP2 + KK = KK + J + 60 CONTINUE + ELSE + JX = KX + JY = KY + DO 80 J = 1,N + TEMP1 = ALPHA*X(JX) + TEMP2 = ZERO + IX = KX + IY = KY + DO 70 K = KK,KK + J - 2 + Y(IY) = Y(IY) + TEMP1*AP(K) + TEMP2 = TEMP2 + DCONJG(AP(K))*X(IX) + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + Y(JY) = Y(JY) + TEMP1*DBLE(AP(KK+J-1)) + ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + KK = KK + J + 80 CONTINUE + END IF + ELSE +* +* Form y when AP contains the lower triangle. +* + IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN + DO 100 J = 1,N + TEMP1 = ALPHA*X(J) + TEMP2 = ZERO + Y(J) = Y(J) + TEMP1*DBLE(AP(KK)) + K = KK + 1 + DO 90 I = J + 1,N + Y(I) = Y(I) + TEMP1*AP(K) + TEMP2 = TEMP2 + DCONJG(AP(K))*X(I) + K = K + 1 + 90 CONTINUE + Y(J) = Y(J) + ALPHA*TEMP2 + KK = KK + (N-J+1) + 100 CONTINUE + ELSE + JX = KX + JY = KY + DO 120 J = 1,N + TEMP1 = ALPHA*X(JX) + TEMP2 = ZERO + Y(JY) = Y(JY) + TEMP1*DBLE(AP(KK)) + IX = JX + IY = JY + DO 110 K = KK + 1,KK + N - J + IX = IX + INCX + IY = IY + INCY + Y(IY) = Y(IY) + TEMP1*AP(K) + TEMP2 = TEMP2 + DCONJG(AP(K))*X(IX) + 110 CONTINUE + Y(JY) = Y(JY) + ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + KK = KK + (N-J+1) + 120 CONTINUE + END IF + END IF +* + RETURN +* +* End of ZHPMV +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/zhpr.f b/fortran_implementation/external_libraries/BLAS/SRC/zhpr.f new file mode 100644 index 0000000..5ef5562 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/zhpr.f @@ -0,0 +1,276 @@ +*> \brief \b ZHPR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZHPR(UPLO,N,ALPHA,X,INCX,AP) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION ALPHA +* INTEGER INCX,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 AP(*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHPR performs the hermitian rank 1 operation +*> +*> A := alpha*x*x**H + A, +*> +*> where alpha is a real scalar, x is an n element vector and A is an +*> n by n hermitian matrix, supplied in packed form. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the matrix A is supplied in the packed +*> array AP as follows: +*> +*> UPLO = 'U' or 'u' The upper triangular part of A is +*> supplied in AP. +*> +*> UPLO = 'L' or 'l' The lower triangular part of A is +*> supplied in AP. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is DOUBLE PRECISION. +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is COMPLEX*16 array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in,out] AP +*> \verbatim +*> AP is COMPLEX*16 array, dimension at least +*> ( ( n*( n + 1 ) )/2 ). +*> Before entry with UPLO = 'U' or 'u', the array AP must +*> contain the upper triangular part of the hermitian matrix +*> packed sequentially, column by column, so that AP( 1 ) +*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) +*> and a( 2, 2 ) respectively, and so on. On exit, the array +*> AP is overwritten by the upper triangular part of the +*> updated matrix. +*> Before entry with UPLO = 'L' or 'l', the array AP must +*> contain the lower triangular part of the hermitian matrix +*> packed sequentially, column by column, so that AP( 1 ) +*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) +*> and a( 3, 1 ) respectively, and so on. On exit, the array +*> AP is overwritten by the lower triangular part of the +*> updated matrix. +*> Note that the imaginary parts of the diagonal elements need +*> not be set, they are assumed to be zero, and on exit they +*> are set to zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup hpr +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZHPR(UPLO,N,ALPHA,X,INCX,AP) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA + INTEGER INCX,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 AP(*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,IX,J,JX,K,KK,KX +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE,DCONJG +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (N.LT.0) THEN + INFO = 2 + ELSE IF (INCX.EQ.0) THEN + INFO = 5 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('ZHPR ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. (ALPHA.EQ.DBLE(ZERO))) RETURN +* +* Set the start point in X if the increment is not unity. +* + IF (INCX.LE.0) THEN + KX = 1 - (N-1)*INCX + ELSE IF (INCX.NE.1) THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of the array AP +* are accessed sequentially with one pass through AP. +* + KK = 1 + IF (LSAME(UPLO,'U')) THEN +* +* Form A when upper triangle is stored in AP. +* + IF (INCX.EQ.1) THEN + DO 20 J = 1,N + IF (X(J).NE.ZERO) THEN + TEMP = ALPHA*DCONJG(X(J)) + K = KK + DO 10 I = 1,J - 1 + AP(K) = AP(K) + X(I)*TEMP + K = K + 1 + 10 CONTINUE + AP(KK+J-1) = DBLE(AP(KK+J-1)) + DBLE(X(J)*TEMP) + ELSE + AP(KK+J-1) = DBLE(AP(KK+J-1)) + END IF + KK = KK + J + 20 CONTINUE + ELSE + JX = KX + DO 40 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = ALPHA*DCONJG(X(JX)) + IX = KX + DO 30 K = KK,KK + J - 2 + AP(K) = AP(K) + X(IX)*TEMP + IX = IX + INCX + 30 CONTINUE + AP(KK+J-1) = DBLE(AP(KK+J-1)) + DBLE(X(JX)*TEMP) + ELSE + AP(KK+J-1) = DBLE(AP(KK+J-1)) + END IF + JX = JX + INCX + KK = KK + J + 40 CONTINUE + END IF + ELSE +* +* Form A when lower triangle is stored in AP. +* + IF (INCX.EQ.1) THEN + DO 60 J = 1,N + IF (X(J).NE.ZERO) THEN + TEMP = ALPHA*DCONJG(X(J)) + AP(KK) = DBLE(AP(KK)) + DBLE(TEMP*X(J)) + K = KK + 1 + DO 50 I = J + 1,N + AP(K) = AP(K) + X(I)*TEMP + K = K + 1 + 50 CONTINUE + ELSE + AP(KK) = DBLE(AP(KK)) + END IF + KK = KK + N - J + 1 + 60 CONTINUE + ELSE + JX = KX + DO 80 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = ALPHA*DCONJG(X(JX)) + AP(KK) = DBLE(AP(KK)) + DBLE(TEMP*X(JX)) + IX = JX + DO 70 K = KK + 1,KK + N - J + IX = IX + INCX + AP(K) = AP(K) + X(IX)*TEMP + 70 CONTINUE + ELSE + AP(KK) = DBLE(AP(KK)) + END IF + JX = JX + INCX + KK = KK + N - J + 1 + 80 CONTINUE + END IF + END IF +* + RETURN +* +* End of ZHPR +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/zhpr2.f b/fortran_implementation/external_libraries/BLAS/SRC/zhpr2.f new file mode 100644 index 0000000..8f5a088 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/zhpr2.f @@ -0,0 +1,315 @@ +*> \brief \b ZHPR2 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZHPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA +* INTEGER INCX,INCY,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 AP(*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHPR2 performs the hermitian rank 2 operation +*> +*> A := alpha*x*y**H + conjg( alpha )*y*x**H + A, +*> +*> where alpha is a scalar, x and y are n element vectors and A is an +*> n by n hermitian matrix, supplied in packed form. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the matrix A is supplied in the packed +*> array AP as follows: +*> +*> UPLO = 'U' or 'u' The upper triangular part of A is +*> supplied in AP. +*> +*> UPLO = 'L' or 'l' The lower triangular part of A is +*> supplied in AP. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX*16 +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is COMPLEX*16 array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in] Y +*> \verbatim +*> Y is COMPLEX*16 array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCY ) ). +*> Before entry, the incremented array Y must contain the n +*> element vector y. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> Y. INCY must not be zero. +*> \endverbatim +*> +*> \param[in,out] AP +*> \verbatim +*> AP is COMPLEX*16 array, dimension at least +*> ( ( n*( n + 1 ) )/2 ). +*> Before entry with UPLO = 'U' or 'u', the array AP must +*> contain the upper triangular part of the hermitian matrix +*> packed sequentially, column by column, so that AP( 1 ) +*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) +*> and a( 2, 2 ) respectively, and so on. On exit, the array +*> AP is overwritten by the upper triangular part of the +*> updated matrix. +*> Before entry with UPLO = 'L' or 'l', the array AP must +*> contain the lower triangular part of the hermitian matrix +*> packed sequentially, column by column, so that AP( 1 ) +*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) +*> and a( 3, 1 ) respectively, and so on. On exit, the array +*> AP is overwritten by the lower triangular part of the +*> updated matrix. +*> Note that the imaginary parts of the diagonal elements need +*> not be set, they are assumed to be zero, and on exit they +*> are set to zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup hpr2 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZHPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX*16 ALPHA + INTEGER INCX,INCY,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 AP(*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP1,TEMP2 + INTEGER I,INFO,IX,IY,J,JX,JY,K,KK,KX,KY +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE,DCONJG +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (N.LT.0) THEN + INFO = 2 + ELSE IF (INCX.EQ.0) THEN + INFO = 5 + ELSE IF (INCY.EQ.0) THEN + INFO = 7 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('ZHPR2 ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN +* +* Set up the start points in X and Y if the increments are not both +* unity. +* + IF ((INCX.NE.1) .OR. (INCY.NE.1)) THEN + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (N-1)*INCX + END IF + IF (INCY.GT.0) THEN + KY = 1 + ELSE + KY = 1 - (N-1)*INCY + END IF + JX = KX + JY = KY + END IF +* +* Start the operations. In this version the elements of the array AP +* are accessed sequentially with one pass through AP. +* + KK = 1 + IF (LSAME(UPLO,'U')) THEN +* +* Form A when upper triangle is stored in AP. +* + IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN + DO 20 J = 1,N + IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN + TEMP1 = ALPHA*DCONJG(Y(J)) + TEMP2 = DCONJG(ALPHA*X(J)) + K = KK + DO 10 I = 1,J - 1 + AP(K) = AP(K) + X(I)*TEMP1 + Y(I)*TEMP2 + K = K + 1 + 10 CONTINUE + AP(KK+J-1) = DBLE(AP(KK+J-1)) + + + DBLE(X(J)*TEMP1+Y(J)*TEMP2) + ELSE + AP(KK+J-1) = DBLE(AP(KK+J-1)) + END IF + KK = KK + J + 20 CONTINUE + ELSE + DO 40 J = 1,N + IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN + TEMP1 = ALPHA*DCONJG(Y(JY)) + TEMP2 = DCONJG(ALPHA*X(JX)) + IX = KX + IY = KY + DO 30 K = KK,KK + J - 2 + AP(K) = AP(K) + X(IX)*TEMP1 + Y(IY)*TEMP2 + IX = IX + INCX + IY = IY + INCY + 30 CONTINUE + AP(KK+J-1) = DBLE(AP(KK+J-1)) + + + DBLE(X(JX)*TEMP1+Y(JY)*TEMP2) + ELSE + AP(KK+J-1) = DBLE(AP(KK+J-1)) + END IF + JX = JX + INCX + JY = JY + INCY + KK = KK + J + 40 CONTINUE + END IF + ELSE +* +* Form A when lower triangle is stored in AP. +* + IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN + DO 60 J = 1,N + IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN + TEMP1 = ALPHA*DCONJG(Y(J)) + TEMP2 = DCONJG(ALPHA*X(J)) + AP(KK) = DBLE(AP(KK)) + + + DBLE(X(J)*TEMP1+Y(J)*TEMP2) + K = KK + 1 + DO 50 I = J + 1,N + AP(K) = AP(K) + X(I)*TEMP1 + Y(I)*TEMP2 + K = K + 1 + 50 CONTINUE + ELSE + AP(KK) = DBLE(AP(KK)) + END IF + KK = KK + N - J + 1 + 60 CONTINUE + ELSE + DO 80 J = 1,N + IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN + TEMP1 = ALPHA*DCONJG(Y(JY)) + TEMP2 = DCONJG(ALPHA*X(JX)) + AP(KK) = DBLE(AP(KK)) + + + DBLE(X(JX)*TEMP1+Y(JY)*TEMP2) + IX = JX + IY = JY + DO 70 K = KK + 1,KK + N - J + IX = IX + INCX + IY = IY + INCY + AP(K) = AP(K) + X(IX)*TEMP1 + Y(IY)*TEMP2 + 70 CONTINUE + ELSE + AP(KK) = DBLE(AP(KK)) + END IF + JX = JX + INCX + JY = JY + INCY + KK = KK + N - J + 1 + 80 CONTINUE + END IF + END IF +* + RETURN +* +* End of ZHPR2 +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/zrotg.f90 b/fortran_implementation/external_libraries/BLAS/SRC/zrotg.f90 new file mode 100644 index 0000000..551bea1 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/zrotg.f90 @@ -0,0 +1,276 @@ +!> \brief \b ZROTG generates a Givens rotation with real cosine and complex sine. +! +! =========== DOCUMENTATION =========== +! +! Online html documentation available at +! http://www.netlib.org/lapack/explore-html/ +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> ZROTG constructs a plane rotation +!> [ c s ] [ a ] = [ r ] +!> [ -conjg(s) c ] [ b ] [ 0 ] +!> where c is real, s is complex, and c**2 + conjg(s)*s = 1. +!> +!> The computation uses the formulas +!> |x| = sqrt( Re(x)**2 + Im(x)**2 ) +!> sgn(x) = x / |x| if x /= 0 +!> = 1 if x = 0 +!> c = |a| / sqrt(|a|**2 + |b|**2) +!> s = sgn(a) * conjg(b) / sqrt(|a|**2 + |b|**2) +!> r = sgn(a)*sqrt(|a|**2 + |b|**2) +!> When a and b are real and r /= 0, the formulas simplify to +!> c = a / r +!> s = b / r +!> the same as in DROTG when |a| > |b|. When |b| >= |a|, the +!> sign of c and s will be different from those computed by DROTG +!> if the signs of a and b are not the same. +!> +!> \endverbatim +!> +!> @see lartg, @see lartgp +! +! Arguments: +! ========== +! +!> \param[in,out] A +!> \verbatim +!> A is DOUBLE COMPLEX +!> On entry, the scalar a. +!> On exit, the scalar r. +!> \endverbatim +!> +!> \param[in] B +!> \verbatim +!> B is DOUBLE COMPLEX +!> The scalar b. +!> \endverbatim +!> +!> \param[out] C +!> \verbatim +!> C is DOUBLE PRECISION +!> The scalar c. +!> \endverbatim +!> +!> \param[out] S +!> \verbatim +!> S is DOUBLE COMPLEX +!> The scalar s. +!> \endverbatim +! +! Authors: +! ======== +! +!> \author Weslley Pereira, University of Colorado Denver, USA +! +!> \date December 2021 +! +!> \ingroup rotg +! +!> \par Further Details: +! ===================== +!> +!> \verbatim +!> +!> Based on the algorithm from +!> +!> Anderson E. (2017) +!> Algorithm 978: Safe Scaling in the Level 1 BLAS +!> ACM Trans Math Softw 44:1--28 +!> https://doi.org/10.1145/3061665 +!> +!> \endverbatim +! +! ===================================================================== +subroutine ZROTG( a, b, c, s ) + integer, parameter :: wp = kind(1.d0) +! +! -- Reference BLAS level1 routine -- +! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +! +! .. Constants .. + real(wp), parameter :: zero = 0.0_wp + real(wp), parameter :: one = 1.0_wp + complex(wp), parameter :: czero = 0.0_wp +! .. +! .. Scaling constants .. + real(wp), parameter :: safmin = real(radix(0._wp),wp)**max( & + minexponent(0._wp)-1, & + 1-maxexponent(0._wp) & + ) + real(wp), parameter :: safmax = real(radix(0._wp),wp)**max( & + 1-minexponent(0._wp), & + maxexponent(0._wp)-1 & + ) + real(wp), parameter :: rtmin = sqrt( safmin ) +! .. +! .. Scalar Arguments .. + real(wp) :: c + complex(wp) :: a, b, s +! .. +! .. Local Scalars .. + real(wp) :: d, f1, f2, g1, g2, h2, u, v, w, rtmax + complex(wp) :: f, fs, g, gs, r, t +! .. +! .. Intrinsic Functions .. + intrinsic :: abs, aimag, conjg, max, min, real, sqrt +! .. +! .. Statement Functions .. + real(wp) :: ABSSQ +! .. +! .. Statement Function definitions .. + ABSSQ( t ) = real( t )**2 + aimag( t )**2 +! .. +! .. Executable Statements .. +! + f = a + g = b + if( g == czero ) then + c = one + s = czero + r = f + else if( f == czero ) then + c = zero + if( real(g) == zero ) then + r = abs(aimag(g)) + s = conjg( g ) / r + elseif( aimag(g) == zero ) then + r = abs(real(g)) + s = conjg( g ) / r + else + g1 = max( abs(real(g)), abs(aimag(g)) ) + rtmax = sqrt( safmax/2 ) + if( g1 > rtmin .and. g1 < rtmax ) then +! +! Use unscaled algorithm +! +! The following two lines can be replaced by `d = abs( g )`. +! This algorithm do not use the intrinsic complex abs. + g2 = ABSSQ( g ) + d = sqrt( g2 ) + s = conjg( g ) / d + r = d + else +! +! Use scaled algorithm +! + u = min( safmax, max( safmin, g1 ) ) + gs = g / u +! The following two lines can be replaced by `d = abs( gs )`. +! This algorithm do not use the intrinsic complex abs. + g2 = ABSSQ( gs ) + d = sqrt( g2 ) + s = conjg( gs ) / d + r = d*u + end if + end if + else + f1 = max( abs(real(f)), abs(aimag(f)) ) + g1 = max( abs(real(g)), abs(aimag(g)) ) + rtmax = sqrt( safmax/4 ) + if( f1 > rtmin .and. f1 < rtmax .and. & + g1 > rtmin .and. g1 < rtmax ) then +! +! Use unscaled algorithm +! + f2 = ABSSQ( f ) + g2 = ABSSQ( g ) + h2 = f2 + g2 + ! safmin <= f2 <= h2 <= safmax + if( f2 >= h2 * safmin ) then + ! safmin <= f2/h2 <= 1, and h2/f2 is finite + c = sqrt( f2 / h2 ) + r = f / c + rtmax = rtmax * 2 + if( f2 > rtmin .and. h2 < rtmax ) then + ! safmin <= sqrt( f2*h2 ) <= safmax + s = conjg( g ) * ( f / sqrt( f2*h2 ) ) + else + s = conjg( g ) * ( r / h2 ) + end if + else + ! f2/h2 <= safmin may be subnormal, and h2/f2 may overflow. + ! Moreover, + ! safmin <= f2*f2 * safmax < f2 * h2 < h2*h2 * safmin <= safmax, + ! sqrt(safmin) <= sqrt(f2 * h2) <= sqrt(safmax). + ! Also, + ! g2 >> f2, which means that h2 = g2. + d = sqrt( f2 * h2 ) + c = f2 / d + if( c >= safmin ) then + r = f / c + else + ! f2 / sqrt(f2 * h2) < safmin, then + ! sqrt(safmin) <= f2 * sqrt(safmax) <= h2 / sqrt(f2 * h2) <= h2 * (safmin / f2) <= h2 <= safmax + r = f * ( h2 / d ) + end if + s = conjg( g ) * ( f / d ) + end if + else +! +! Use scaled algorithm +! + u = min( safmax, max( safmin, f1, g1 ) ) + gs = g / u + g2 = ABSSQ( gs ) + if( f1 / u < rtmin ) then +! +! f is not well-scaled when scaled by g1. +! Use a different scaling for f. +! + v = min( safmax, max( safmin, f1 ) ) + w = v / u + fs = f / v + f2 = ABSSQ( fs ) + h2 = f2*w**2 + g2 + else +! +! Otherwise use the same scaling for f and g. +! + w = one + fs = f / u + f2 = ABSSQ( fs ) + h2 = f2 + g2 + end if + ! safmin <= f2 <= h2 <= safmax + if( f2 >= h2 * safmin ) then + ! safmin <= f2/h2 <= 1, and h2/f2 is finite + c = sqrt( f2 / h2 ) + r = fs / c + rtmax = rtmax * 2 + if( f2 > rtmin .and. h2 < rtmax ) then + ! safmin <= sqrt( f2*h2 ) <= safmax + s = conjg( gs ) * ( fs / sqrt( f2*h2 ) ) + else + s = conjg( gs ) * ( r / h2 ) + end if + else + ! f2/h2 <= safmin may be subnormal, and h2/f2 may overflow. + ! Moreover, + ! safmin <= f2*f2 * safmax < f2 * h2 < h2*h2 * safmin <= safmax, + ! sqrt(safmin) <= sqrt(f2 * h2) <= sqrt(safmax). + ! Also, + ! g2 >> f2, which means that h2 = g2. + d = sqrt( f2 * h2 ) + c = f2 / d + if( c >= safmin ) then + r = fs / c + else + ! f2 / sqrt(f2 * h2) < safmin, then + ! sqrt(safmin) <= f2 * sqrt(safmax) <= h2 / sqrt(f2 * h2) <= h2 * (safmin / f2) <= h2 <= safmax + r = fs * ( h2 / d ) + end if + s = conjg( gs ) * ( fs / d ) + end if + ! Rescale c and r + c = c * w + r = r * u + end if + end if + a = r + return +end subroutine diff --git a/fortran_implementation/external_libraries/BLAS/SRC/zscal.f b/fortran_implementation/external_libraries/BLAS/SRC/zscal.f new file mode 100644 index 0000000..8bbb4fd --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/zscal.f @@ -0,0 +1,121 @@ +*> \brief \b ZSCAL +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZSCAL(N,ZA,ZX,INCX) +* +* .. Scalar Arguments .. +* COMPLEX*16 ZA +* INTEGER INCX,N +* .. +* .. Array Arguments .. +* COMPLEX*16 ZX(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZSCAL scales a vector by a constant. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] ZA +*> \verbatim +*> ZA is COMPLEX*16 +*> On entry, ZA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in,out] ZX +*> \verbatim +*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of ZX +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup scal +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, 3/11/78. +*> modified 3/93 to return if incx .le. 0. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZSCAL(N,ZA,ZX,INCX) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX*16 ZA + INTEGER INCX,N +* .. +* .. Array Arguments .. + COMPLEX*16 ZX(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,NINCX +* .. +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER (ONE= (1.0D+0,0.0D+0)) +* .. + IF (N.LE.0 .OR. INCX.LE.0 .OR. ZA.EQ.ONE) RETURN + IF (INCX.EQ.1) THEN +* +* code for increment equal to 1 +* + DO I = 1,N + ZX(I) = ZA*ZX(I) + END DO + ELSE +* +* code for increment not equal to 1 +* + NINCX = N*INCX + DO I = 1,NINCX,INCX + ZX(I) = ZA*ZX(I) + END DO + END IF + RETURN +* +* End of ZSCAL +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/zswap.f b/fortran_implementation/external_libraries/BLAS/SRC/zswap.f new file mode 100644 index 0000000..d27d432 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/zswap.f @@ -0,0 +1,129 @@ +*> \brief \b ZSWAP +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZSWAP(N,ZX,INCX,ZY,INCY) +* +* .. Scalar Arguments .. +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* COMPLEX*16 ZX(*),ZY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZSWAP interchanges two vectors. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in,out] ZX +*> \verbatim +*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of ZX +*> \endverbatim +*> +*> \param[in,out] ZY +*> \verbatim +*> ZY is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of ZY +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup swap +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, 3/11/78. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZSWAP(N,ZX,INCX,ZY,INCY) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + COMPLEX*16 ZX(*),ZY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + COMPLEX*16 ZTEMP + INTEGER I,IX,IY +* .. + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 + DO I = 1,N + ZTEMP = ZX(I) + ZX(I) = ZY(I) + ZY(I) = ZTEMP + END DO + ELSE +* +* code for unequal increments or equal increments not equal +* to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + ZTEMP = ZX(IX) + ZX(IX) = ZY(IY) + ZY(IY) = ZTEMP + IX = IX + INCX + IY = IY + INCY + END DO + END IF + RETURN +* +* End of ZSWAP +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/zsymm.f b/fortran_implementation/external_libraries/BLAS/SRC/zsymm.f new file mode 100644 index 0000000..7da6a0e --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/zsymm.f @@ -0,0 +1,368 @@ +*> \brief \b ZSYMM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA,BETA +* INTEGER LDA,LDB,LDC,M,N +* CHARACTER SIDE,UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZSYMM performs one of the matrix-matrix operations +*> +*> C := alpha*A*B + beta*C, +*> +*> or +*> +*> C := alpha*B*A + beta*C, +*> +*> where alpha and beta are scalars, A is a symmetric matrix and B and +*> C are m by n matrices. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> On entry, SIDE specifies whether the symmetric matrix A +*> appears on the left or right in the operation as follows: +*> +*> SIDE = 'L' or 'l' C := alpha*A*B + beta*C, +*> +*> SIDE = 'R' or 'r' C := alpha*B*A + beta*C, +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the symmetric matrix A is to be +*> referenced as follows: +*> +*> UPLO = 'U' or 'u' Only the upper triangular part of the +*> symmetric matrix is to be referenced. +*> +*> UPLO = 'L' or 'l' Only the lower triangular part of the +*> symmetric matrix is to be referenced. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix C. +*> M must be at least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of the matrix C. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX*16 +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension ( LDA, ka ), where ka is +*> m when SIDE = 'L' or 'l' and is n otherwise. +*> Before entry with SIDE = 'L' or 'l', the m by m part of +*> the array A must contain the symmetric matrix, such that +*> when UPLO = 'U' or 'u', the leading m by m upper triangular +*> part of the array A must contain the upper triangular part +*> of the symmetric matrix and the strictly lower triangular +*> part of A is not referenced, and when UPLO = 'L' or 'l', +*> the leading m by m lower triangular part of the array A +*> must contain the lower triangular part of the symmetric +*> matrix and the strictly upper triangular part of A is not +*> referenced. +*> Before entry with SIDE = 'R' or 'r', the n by n part of +*> the array A must contain the symmetric matrix, such that +*> when UPLO = 'U' or 'u', the leading n by n upper triangular +*> part of the array A must contain the upper triangular part +*> of the symmetric matrix and the strictly lower triangular +*> part of A is not referenced, and when UPLO = 'L' or 'l', +*> the leading n by n lower triangular part of the array A +*> must contain the lower triangular part of the symmetric +*> matrix and the strictly upper triangular part of A is not +*> referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When SIDE = 'L' or 'l' then +*> LDA must be at least max( 1, m ), otherwise LDA must be at +*> least max( 1, n ). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is COMPLEX*16 array, dimension ( LDB, N ) +*> Before entry, the leading m by n part of the array B must +*> contain the matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. LDB must be at least +*> max( 1, m ). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is COMPLEX*16 +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then C need not be set on input. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX*16 array, dimension ( LDC, N ) +*> Before entry, the leading m by n part of the array C must +*> contain the matrix C, except when beta is zero, in which +*> case C need not be set on entry. +*> On exit, the array C is overwritten by the m by n updated +*> matrix. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> On entry, LDC specifies the first dimension of C as declared +*> in the calling (sub) program. LDC must be at least +*> max( 1, m ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup hemm +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> -- Written on 8-February-1989. +*> Jack Dongarra, Argonne National Laboratory. +*> Iain Duff, AERE Harwell. +*> Jeremy Du Croz, Numerical Algorithms Group Ltd. +*> Sven Hammarling, Numerical Algorithms Group Ltd. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* -- Reference BLAS level3 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX*16 ALPHA,BETA + INTEGER LDA,LDB,LDC,M,N + CHARACTER SIDE,UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP1,TEMP2 + INTEGER I,INFO,J,K,NROWA + LOGICAL UPPER +* .. +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER (ONE= (1.0D+0,0.0D+0)) + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* +* Set NROWA as the number of rows of A. +* + IF (LSAME(SIDE,'L')) THEN + NROWA = M + ELSE + NROWA = N + END IF + UPPER = LSAME(UPLO,'U') +* +* Test the input parameters. +* + INFO = 0 + IF ((.NOT.LSAME(SIDE,'L')) .AND. + + (.NOT.LSAME(SIDE,'R'))) THEN + INFO = 1 + ELSE IF ((.NOT.UPPER) .AND. + + (.NOT.LSAME(UPLO,'L'))) THEN + INFO = 2 + ELSE IF (M.LT.0) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 7 + ELSE IF (LDB.LT.MAX(1,M)) THEN + INFO = 9 + ELSE IF (LDC.LT.MAX(1,M)) THEN + INFO = 12 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('ZSYMM ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. + + ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + IF (BETA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,M + C(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1,N + DO 30 I = 1,M + C(I,J) = BETA*C(I,J) + 30 CONTINUE + 40 CONTINUE + END IF + RETURN + END IF +* +* Start the operations. +* + IF (LSAME(SIDE,'L')) THEN +* +* Form C := alpha*A*B + beta*C. +* + IF (UPPER) THEN + DO 70 J = 1,N + DO 60 I = 1,M + TEMP1 = ALPHA*B(I,J) + TEMP2 = ZERO + DO 50 K = 1,I - 1 + C(K,J) = C(K,J) + TEMP1*A(K,I) + TEMP2 = TEMP2 + B(K,J)*A(K,I) + 50 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = TEMP1*A(I,I) + ALPHA*TEMP2 + ELSE + C(I,J) = BETA*C(I,J) + TEMP1*A(I,I) + + + ALPHA*TEMP2 + END IF + 60 CONTINUE + 70 CONTINUE + ELSE + DO 100 J = 1,N + DO 90 I = M,1,-1 + TEMP1 = ALPHA*B(I,J) + TEMP2 = ZERO + DO 80 K = I + 1,M + C(K,J) = C(K,J) + TEMP1*A(K,I) + TEMP2 = TEMP2 + B(K,J)*A(K,I) + 80 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = TEMP1*A(I,I) + ALPHA*TEMP2 + ELSE + C(I,J) = BETA*C(I,J) + TEMP1*A(I,I) + + + ALPHA*TEMP2 + END IF + 90 CONTINUE + 100 CONTINUE + END IF + ELSE +* +* Form C := alpha*B*A + beta*C. +* + DO 170 J = 1,N + TEMP1 = ALPHA*A(J,J) + IF (BETA.EQ.ZERO) THEN + DO 110 I = 1,M + C(I,J) = TEMP1*B(I,J) + 110 CONTINUE + ELSE + DO 120 I = 1,M + C(I,J) = BETA*C(I,J) + TEMP1*B(I,J) + 120 CONTINUE + END IF + DO 140 K = 1,J - 1 + IF (UPPER) THEN + TEMP1 = ALPHA*A(K,J) + ELSE + TEMP1 = ALPHA*A(J,K) + END IF + DO 130 I = 1,M + C(I,J) = C(I,J) + TEMP1*B(I,K) + 130 CONTINUE + 140 CONTINUE + DO 160 K = J + 1,N + IF (UPPER) THEN + TEMP1 = ALPHA*A(J,K) + ELSE + TEMP1 = ALPHA*A(K,J) + END IF + DO 150 I = 1,M + C(I,J) = C(I,J) + TEMP1*B(I,K) + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE + END IF +* + RETURN +* +* End of ZSYMM +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/zsyr2k.f b/fortran_implementation/external_libraries/BLAS/SRC/zsyr2k.f new file mode 100644 index 0000000..40d6fe8 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/zsyr2k.f @@ -0,0 +1,393 @@ +*> \brief \b ZSYR2K +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA,BETA +* INTEGER K,LDA,LDB,LDC,N +* CHARACTER TRANS,UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZSYR2K performs one of the symmetric rank 2k operations +*> +*> C := alpha*A*B**T + alpha*B*A**T + beta*C, +*> +*> or +*> +*> C := alpha*A**T*B + alpha*B**T*A + beta*C, +*> +*> where alpha and beta are scalars, C is an n by n symmetric matrix +*> and A and B are n by k matrices in the first case and k by n +*> matrices in the second case. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the array C is to be referenced as +*> follows: +*> +*> UPLO = 'U' or 'u' Only the upper triangular part of C +*> is to be referenced. +*> +*> UPLO = 'L' or 'l' Only the lower triangular part of C +*> is to be referenced. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the operation to be performed as +*> follows: +*> +*> TRANS = 'N' or 'n' C := alpha*A*B**T + alpha*B*A**T + +*> beta*C. +*> +*> TRANS = 'T' or 't' C := alpha*A**T*B + alpha*B**T*A + +*> beta*C. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix C. N must be +*> at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry with TRANS = 'N' or 'n', K specifies the number +*> of columns of the matrices A and B, and on entry with +*> TRANS = 'T' or 't', K specifies the number of rows of the +*> matrices A and B. K must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX*16 +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension ( LDA, ka ), where ka is +*> k when TRANS = 'N' or 'n', and is n otherwise. +*> Before entry with TRANS = 'N' or 'n', the leading n by k +*> part of the array A must contain the matrix A, otherwise +*> the leading k by n part of the array A must contain the +*> matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When TRANS = 'N' or 'n' +*> then LDA must be at least max( 1, n ), otherwise LDA must +*> be at least max( 1, k ). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is COMPLEX*16 array, dimension ( LDB, kb ), where kb is +*> k when TRANS = 'N' or 'n', and is n otherwise. +*> Before entry with TRANS = 'N' or 'n', the leading n by k +*> part of the array B must contain the matrix B, otherwise +*> the leading k by n part of the array B must contain the +*> matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. When TRANS = 'N' or 'n' +*> then LDB must be at least max( 1, n ), otherwise LDB must +*> be at least max( 1, k ). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is COMPLEX*16 +*> On entry, BETA specifies the scalar beta. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX*16 array, dimension ( LDC, N ) +*> Before entry with UPLO = 'U' or 'u', the leading n by n +*> upper triangular part of the array C must contain the upper +*> triangular part of the symmetric matrix and the strictly +*> lower triangular part of C is not referenced. On exit, the +*> upper triangular part of the array C is overwritten by the +*> upper triangular part of the updated matrix. +*> Before entry with UPLO = 'L' or 'l', the leading n by n +*> lower triangular part of the array C must contain the lower +*> triangular part of the symmetric matrix and the strictly +*> upper triangular part of C is not referenced. On exit, the +*> lower triangular part of the array C is overwritten by the +*> lower triangular part of the updated matrix. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> On entry, LDC specifies the first dimension of C as declared +*> in the calling (sub) program. LDC must be at least +*> max( 1, n ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup her2k +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> -- Written on 8-February-1989. +*> Jack Dongarra, Argonne National Laboratory. +*> Iain Duff, AERE Harwell. +*> Jeremy Du Croz, Numerical Algorithms Group Ltd. +*> Sven Hammarling, Numerical Algorithms Group Ltd. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* -- Reference BLAS level3 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX*16 ALPHA,BETA + INTEGER K,LDA,LDB,LDC,N + CHARACTER TRANS,UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP1,TEMP2 + INTEGER I,INFO,J,L,NROWA + LOGICAL UPPER +* .. +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER (ONE= (1.0D+0,0.0D+0)) + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* +* Test the input parameters. +* + IF (LSAME(TRANS,'N')) THEN + NROWA = N + ELSE + NROWA = K + END IF + UPPER = LSAME(UPLO,'U') +* + INFO = 0 + IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN + INFO = 1 + ELSE IF ((.NOT.LSAME(TRANS,'N')) .AND. + + (.NOT.LSAME(TRANS,'T'))) THEN + INFO = 2 + ELSE IF (N.LT.0) THEN + INFO = 3 + ELSE IF (K.LT.0) THEN + INFO = 4 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 7 + ELSE IF (LDB.LT.MAX(1,NROWA)) THEN + INFO = 9 + ELSE IF (LDC.LT.MAX(1,N)) THEN + INFO = 12 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('ZSYR2K',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR. + + (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + IF (UPPER) THEN + IF (BETA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,J + C(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1,N + DO 30 I = 1,J + C(I,J) = BETA*C(I,J) + 30 CONTINUE + 40 CONTINUE + END IF + ELSE + IF (BETA.EQ.ZERO) THEN + DO 60 J = 1,N + DO 50 I = J,N + C(I,J) = ZERO + 50 CONTINUE + 60 CONTINUE + ELSE + DO 80 J = 1,N + DO 70 I = J,N + C(I,J) = BETA*C(I,J) + 70 CONTINUE + 80 CONTINUE + END IF + END IF + RETURN + END IF +* +* Start the operations. +* + IF (LSAME(TRANS,'N')) THEN +* +* Form C := alpha*A*B**T + alpha*B*A**T + C. +* + IF (UPPER) THEN + DO 130 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 90 I = 1,J + C(I,J) = ZERO + 90 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 100 I = 1,J + C(I,J) = BETA*C(I,J) + 100 CONTINUE + END IF + DO 120 L = 1,K + IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN + TEMP1 = ALPHA*B(J,L) + TEMP2 = ALPHA*A(J,L) + DO 110 I = 1,J + C(I,J) = C(I,J) + A(I,L)*TEMP1 + + + B(I,L)*TEMP2 + 110 CONTINUE + END IF + 120 CONTINUE + 130 CONTINUE + ELSE + DO 180 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 140 I = J,N + C(I,J) = ZERO + 140 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 150 I = J,N + C(I,J) = BETA*C(I,J) + 150 CONTINUE + END IF + DO 170 L = 1,K + IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN + TEMP1 = ALPHA*B(J,L) + TEMP2 = ALPHA*A(J,L) + DO 160 I = J,N + C(I,J) = C(I,J) + A(I,L)*TEMP1 + + + B(I,L)*TEMP2 + 160 CONTINUE + END IF + 170 CONTINUE + 180 CONTINUE + END IF + ELSE +* +* Form C := alpha*A**T*B + alpha*B**T*A + C. +* + IF (UPPER) THEN + DO 210 J = 1,N + DO 200 I = 1,J + TEMP1 = ZERO + TEMP2 = ZERO + DO 190 L = 1,K + TEMP1 = TEMP1 + A(L,I)*B(L,J) + TEMP2 = TEMP2 + B(L,I)*A(L,J) + 190 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP1 + ALPHA*TEMP2 + ELSE + C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 + + + ALPHA*TEMP2 + END IF + 200 CONTINUE + 210 CONTINUE + ELSE + DO 240 J = 1,N + DO 230 I = J,N + TEMP1 = ZERO + TEMP2 = ZERO + DO 220 L = 1,K + TEMP1 = TEMP1 + A(L,I)*B(L,J) + TEMP2 = TEMP2 + B(L,I)*A(L,J) + 220 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP1 + ALPHA*TEMP2 + ELSE + C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 + + + ALPHA*TEMP2 + END IF + 230 CONTINUE + 240 CONTINUE + END IF + END IF +* + RETURN +* +* End of ZSYR2K +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/zsyrk.f b/fortran_implementation/external_libraries/BLAS/SRC/zsyrk.f new file mode 100644 index 0000000..c9ddc6c --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/zsyrk.f @@ -0,0 +1,360 @@ +*> \brief \b ZSYRK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA,BETA +* INTEGER K,LDA,LDC,N +* CHARACTER TRANS,UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZSYRK performs one of the symmetric rank k operations +*> +*> C := alpha*A*A**T + beta*C, +*> +*> or +*> +*> C := alpha*A**T*A + beta*C, +*> +*> where alpha and beta are scalars, C is an n by n symmetric matrix +*> and A is an n by k matrix in the first case and a k by n matrix +*> in the second case. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the array C is to be referenced as +*> follows: +*> +*> UPLO = 'U' or 'u' Only the upper triangular part of C +*> is to be referenced. +*> +*> UPLO = 'L' or 'l' Only the lower triangular part of C +*> is to be referenced. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the operation to be performed as +*> follows: +*> +*> TRANS = 'N' or 'n' C := alpha*A*A**T + beta*C. +*> +*> TRANS = 'T' or 't' C := alpha*A**T*A + beta*C. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix C. N must be +*> at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry with TRANS = 'N' or 'n', K specifies the number +*> of columns of the matrix A, and on entry with +*> TRANS = 'T' or 't', K specifies the number of rows of the +*> matrix A. K must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX*16 +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension ( LDA, ka ), where ka is +*> k when TRANS = 'N' or 'n', and is n otherwise. +*> Before entry with TRANS = 'N' or 'n', the leading n by k +*> part of the array A must contain the matrix A, otherwise +*> the leading k by n part of the array A must contain the +*> matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When TRANS = 'N' or 'n' +*> then LDA must be at least max( 1, n ), otherwise LDA must +*> be at least max( 1, k ). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is COMPLEX*16 +*> On entry, BETA specifies the scalar beta. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX*16 array, dimension ( LDC, N ) +*> Before entry with UPLO = 'U' or 'u', the leading n by n +*> upper triangular part of the array C must contain the upper +*> triangular part of the symmetric matrix and the strictly +*> lower triangular part of C is not referenced. On exit, the +*> upper triangular part of the array C is overwritten by the +*> upper triangular part of the updated matrix. +*> Before entry with UPLO = 'L' or 'l', the leading n by n +*> lower triangular part of the array C must contain the lower +*> triangular part of the symmetric matrix and the strictly +*> upper triangular part of C is not referenced. On exit, the +*> lower triangular part of the array C is overwritten by the +*> lower triangular part of the updated matrix. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> On entry, LDC specifies the first dimension of C as declared +*> in the calling (sub) program. LDC must be at least +*> max( 1, n ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup herk +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> -- Written on 8-February-1989. +*> Jack Dongarra, Argonne National Laboratory. +*> Iain Duff, AERE Harwell. +*> Jeremy Du Croz, Numerical Algorithms Group Ltd. +*> Sven Hammarling, Numerical Algorithms Group Ltd. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) +* +* -- Reference BLAS level3 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX*16 ALPHA,BETA + INTEGER K,LDA,LDC,N + CHARACTER TRANS,UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,J,L,NROWA + LOGICAL UPPER +* .. +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER (ONE= (1.0D+0,0.0D+0)) + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* +* Test the input parameters. +* + IF (LSAME(TRANS,'N')) THEN + NROWA = N + ELSE + NROWA = K + END IF + UPPER = LSAME(UPLO,'U') +* + INFO = 0 + IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN + INFO = 1 + ELSE IF ((.NOT.LSAME(TRANS,'N')) .AND. + + (.NOT.LSAME(TRANS,'T'))) THEN + INFO = 2 + ELSE IF (N.LT.0) THEN + INFO = 3 + ELSE IF (K.LT.0) THEN + INFO = 4 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 7 + ELSE IF (LDC.LT.MAX(1,N)) THEN + INFO = 10 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('ZSYRK ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR. + + (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + IF (UPPER) THEN + IF (BETA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,J + C(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1,N + DO 30 I = 1,J + C(I,J) = BETA*C(I,J) + 30 CONTINUE + 40 CONTINUE + END IF + ELSE + IF (BETA.EQ.ZERO) THEN + DO 60 J = 1,N + DO 50 I = J,N + C(I,J) = ZERO + 50 CONTINUE + 60 CONTINUE + ELSE + DO 80 J = 1,N + DO 70 I = J,N + C(I,J) = BETA*C(I,J) + 70 CONTINUE + 80 CONTINUE + END IF + END IF + RETURN + END IF +* +* Start the operations. +* + IF (LSAME(TRANS,'N')) THEN +* +* Form C := alpha*A*A**T + beta*C. +* + IF (UPPER) THEN + DO 130 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 90 I = 1,J + C(I,J) = ZERO + 90 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 100 I = 1,J + C(I,J) = BETA*C(I,J) + 100 CONTINUE + END IF + DO 120 L = 1,K + IF (A(J,L).NE.ZERO) THEN + TEMP = ALPHA*A(J,L) + DO 110 I = 1,J + C(I,J) = C(I,J) + TEMP*A(I,L) + 110 CONTINUE + END IF + 120 CONTINUE + 130 CONTINUE + ELSE + DO 180 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 140 I = J,N + C(I,J) = ZERO + 140 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 150 I = J,N + C(I,J) = BETA*C(I,J) + 150 CONTINUE + END IF + DO 170 L = 1,K + IF (A(J,L).NE.ZERO) THEN + TEMP = ALPHA*A(J,L) + DO 160 I = J,N + C(I,J) = C(I,J) + TEMP*A(I,L) + 160 CONTINUE + END IF + 170 CONTINUE + 180 CONTINUE + END IF + ELSE +* +* Form C := alpha*A**T*A + beta*C. +* + IF (UPPER) THEN + DO 210 J = 1,N + DO 200 I = 1,J + TEMP = ZERO + DO 190 L = 1,K + TEMP = TEMP + A(L,I)*A(L,J) + 190 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 200 CONTINUE + 210 CONTINUE + ELSE + DO 240 J = 1,N + DO 230 I = J,N + TEMP = ZERO + DO 220 L = 1,K + TEMP = TEMP + A(L,I)*A(L,J) + 220 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 230 CONTINUE + 240 CONTINUE + END IF + END IF +* + RETURN +* +* End of ZSYRK +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/ztbmv.f b/fortran_implementation/external_libraries/BLAS/SRC/ztbmv.f new file mode 100644 index 0000000..1a11d3a --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/ztbmv.f @@ -0,0 +1,428 @@ +*> \brief \b ZTBMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZTBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,K,LDA,N +* CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZTBMV performs one of the matrix-vector operations +*> +*> x := A*x, or x := A**T*x, or x := A**H*x, +*> +*> where x is an n element vector and A is an n by n unit, or non-unit, +*> upper or lower triangular band matrix, with ( k + 1 ) diagonals. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the matrix is an upper or +*> lower triangular matrix as follows: +*> +*> UPLO = 'U' or 'u' A is an upper triangular matrix. +*> +*> UPLO = 'L' or 'l' A is a lower triangular matrix. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the operation to be performed as +*> follows: +*> +*> TRANS = 'N' or 'n' x := A*x. +*> +*> TRANS = 'T' or 't' x := A**T*x. +*> +*> TRANS = 'C' or 'c' x := A**H*x. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> On entry, DIAG specifies whether or not A is unit +*> triangular as follows: +*> +*> DIAG = 'U' or 'u' A is assumed to be unit triangular. +*> +*> DIAG = 'N' or 'n' A is not assumed to be unit +*> triangular. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry with UPLO = 'U' or 'u', K specifies the number of +*> super-diagonals of the matrix A. +*> On entry with UPLO = 'L' or 'l', K specifies the number of +*> sub-diagonals of the matrix A. +*> K must satisfy 0 .le. K. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension ( LDA, N ). +*> Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) +*> by n part of the array A must contain the upper triangular +*> band part of the matrix of coefficients, supplied column by +*> column, with the leading diagonal of the matrix in row +*> ( k + 1 ) of the array, the first super-diagonal starting at +*> position 2 in row k, and so on. The top left k by k triangle +*> of the array A is not referenced. +*> The following program segment will transfer an upper +*> triangular band matrix from conventional full matrix storage +*> to band storage: +*> +*> DO 20, J = 1, N +*> M = K + 1 - J +*> DO 10, I = MAX( 1, J - K ), J +*> A( M + I, J ) = matrix( I, J ) +*> 10 CONTINUE +*> 20 CONTINUE +*> +*> Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) +*> by n part of the array A must contain the lower triangular +*> band part of the matrix of coefficients, supplied column by +*> column, with the leading diagonal of the matrix in row 1 of +*> the array, the first sub-diagonal starting at position 1 in +*> row 2, and so on. The bottom right k by k triangle of the +*> array A is not referenced. +*> The following program segment will transfer a lower +*> triangular band matrix from conventional full matrix storage +*> to band storage: +*> +*> DO 20, J = 1, N +*> M = 1 - J +*> DO 10, I = J, MIN( N, J + K ) +*> A( M + I, J ) = matrix( I, J ) +*> 10 CONTINUE +*> 20 CONTINUE +*> +*> Note that when DIAG = 'U' or 'u' the elements of the array A +*> corresponding to the diagonal elements of the matrix are not +*> referenced, but are assumed to be unity. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> ( k + 1 ). +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is COMPLEX*16 array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element vector x. On exit, X is overwritten with the +*> transformed vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup tbmv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> The vector and matrix arguments are not referenced when N = 0, or M = 0 +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZTBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,K,LDA,N + CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,IX,J,JX,KPLUS1,KX,L + LOGICAL NOCONJ,NOUNIT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG,MAX,MIN +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (.NOT.LSAME(TRANS,'N') .AND. + + .NOT.LSAME(TRANS,'T') .AND. + + .NOT.LSAME(TRANS,'C')) THEN + INFO = 2 + ELSE IF (.NOT.LSAME(DIAG,'U') .AND. + + .NOT.LSAME(DIAG,'N')) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (K.LT.0) THEN + INFO = 5 + ELSE IF (LDA.LT. (K+1)) THEN + INFO = 7 + ELSE IF (INCX.EQ.0) THEN + INFO = 9 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('ZTBMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (N.EQ.0) RETURN +* + NOCONJ = LSAME(TRANS,'T') + NOUNIT = LSAME(DIAG,'N') +* +* Set up the start point in X if the increment is not unity. This +* will be ( N - 1 )*INCX too small for descending loops. +* + IF (INCX.LE.0) THEN + KX = 1 - (N-1)*INCX + ELSE IF (INCX.NE.1) THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* + IF (LSAME(TRANS,'N')) THEN +* +* Form x := A*x. +* + IF (LSAME(UPLO,'U')) THEN + KPLUS1 = K + 1 + IF (INCX.EQ.1) THEN + DO 20 J = 1,N + IF (X(J).NE.ZERO) THEN + TEMP = X(J) + L = KPLUS1 - J + DO 10 I = MAX(1,J-K),J - 1 + X(I) = X(I) + TEMP*A(L+I,J) + 10 CONTINUE + IF (NOUNIT) X(J) = X(J)*A(KPLUS1,J) + END IF + 20 CONTINUE + ELSE + JX = KX + DO 40 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = X(JX) + IX = KX + L = KPLUS1 - J + DO 30 I = MAX(1,J-K),J - 1 + X(IX) = X(IX) + TEMP*A(L+I,J) + IX = IX + INCX + 30 CONTINUE + IF (NOUNIT) X(JX) = X(JX)*A(KPLUS1,J) + END IF + JX = JX + INCX + IF (J.GT.K) KX = KX + INCX + 40 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 60 J = N,1,-1 + IF (X(J).NE.ZERO) THEN + TEMP = X(J) + L = 1 - J + DO 50 I = MIN(N,J+K),J + 1,-1 + X(I) = X(I) + TEMP*A(L+I,J) + 50 CONTINUE + IF (NOUNIT) X(J) = X(J)*A(1,J) + END IF + 60 CONTINUE + ELSE + KX = KX + (N-1)*INCX + JX = KX + DO 80 J = N,1,-1 + IF (X(JX).NE.ZERO) THEN + TEMP = X(JX) + IX = KX + L = 1 - J + DO 70 I = MIN(N,J+K),J + 1,-1 + X(IX) = X(IX) + TEMP*A(L+I,J) + IX = IX - INCX + 70 CONTINUE + IF (NOUNIT) X(JX) = X(JX)*A(1,J) + END IF + JX = JX - INCX + IF ((N-J).GE.K) KX = KX - INCX + 80 CONTINUE + END IF + END IF + ELSE +* +* Form x := A**T*x or x := A**H*x. +* + IF (LSAME(UPLO,'U')) THEN + KPLUS1 = K + 1 + IF (INCX.EQ.1) THEN + DO 110 J = N,1,-1 + TEMP = X(J) + L = KPLUS1 - J + IF (NOCONJ) THEN + IF (NOUNIT) TEMP = TEMP*A(KPLUS1,J) + DO 90 I = J - 1,MAX(1,J-K),-1 + TEMP = TEMP + A(L+I,J)*X(I) + 90 CONTINUE + ELSE + IF (NOUNIT) TEMP = TEMP*DCONJG(A(KPLUS1,J)) + DO 100 I = J - 1,MAX(1,J-K),-1 + TEMP = TEMP + DCONJG(A(L+I,J))*X(I) + 100 CONTINUE + END IF + X(J) = TEMP + 110 CONTINUE + ELSE + KX = KX + (N-1)*INCX + JX = KX + DO 140 J = N,1,-1 + TEMP = X(JX) + KX = KX - INCX + IX = KX + L = KPLUS1 - J + IF (NOCONJ) THEN + IF (NOUNIT) TEMP = TEMP*A(KPLUS1,J) + DO 120 I = J - 1,MAX(1,J-K),-1 + TEMP = TEMP + A(L+I,J)*X(IX) + IX = IX - INCX + 120 CONTINUE + ELSE + IF (NOUNIT) TEMP = TEMP*DCONJG(A(KPLUS1,J)) + DO 130 I = J - 1,MAX(1,J-K),-1 + TEMP = TEMP + DCONJG(A(L+I,J))*X(IX) + IX = IX - INCX + 130 CONTINUE + END IF + X(JX) = TEMP + JX = JX - INCX + 140 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 170 J = 1,N + TEMP = X(J) + L = 1 - J + IF (NOCONJ) THEN + IF (NOUNIT) TEMP = TEMP*A(1,J) + DO 150 I = J + 1,MIN(N,J+K) + TEMP = TEMP + A(L+I,J)*X(I) + 150 CONTINUE + ELSE + IF (NOUNIT) TEMP = TEMP*DCONJG(A(1,J)) + DO 160 I = J + 1,MIN(N,J+K) + TEMP = TEMP + DCONJG(A(L+I,J))*X(I) + 160 CONTINUE + END IF + X(J) = TEMP + 170 CONTINUE + ELSE + JX = KX + DO 200 J = 1,N + TEMP = X(JX) + KX = KX + INCX + IX = KX + L = 1 - J + IF (NOCONJ) THEN + IF (NOUNIT) TEMP = TEMP*A(1,J) + DO 180 I = J + 1,MIN(N,J+K) + TEMP = TEMP + A(L+I,J)*X(IX) + IX = IX + INCX + 180 CONTINUE + ELSE + IF (NOUNIT) TEMP = TEMP*DCONJG(A(1,J)) + DO 190 I = J + 1,MIN(N,J+K) + TEMP = TEMP + DCONJG(A(L+I,J))*X(IX) + IX = IX + INCX + 190 CONTINUE + END IF + X(JX) = TEMP + JX = JX + INCX + 200 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of ZTBMV +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/ztbsv.f b/fortran_implementation/external_libraries/BLAS/SRC/ztbsv.f new file mode 100644 index 0000000..b3042ac --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/ztbsv.f @@ -0,0 +1,431 @@ +*> \brief \b ZTBSV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZTBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,K,LDA,N +* CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZTBSV solves one of the systems of equations +*> +*> A*x = b, or A**T*x = b, or A**H*x = b, +*> +*> where b and x are n element vectors and A is an n by n unit, or +*> non-unit, upper or lower triangular band matrix, with ( k + 1 ) +*> diagonals. +*> +*> No test for singularity or near-singularity is included in this +*> routine. Such tests must be performed before calling this routine. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the matrix is an upper or +*> lower triangular matrix as follows: +*> +*> UPLO = 'U' or 'u' A is an upper triangular matrix. +*> +*> UPLO = 'L' or 'l' A is a lower triangular matrix. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the equations to be solved as +*> follows: +*> +*> TRANS = 'N' or 'n' A*x = b. +*> +*> TRANS = 'T' or 't' A**T*x = b. +*> +*> TRANS = 'C' or 'c' A**H*x = b. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> On entry, DIAG specifies whether or not A is unit +*> triangular as follows: +*> +*> DIAG = 'U' or 'u' A is assumed to be unit triangular. +*> +*> DIAG = 'N' or 'n' A is not assumed to be unit +*> triangular. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry with UPLO = 'U' or 'u', K specifies the number of +*> super-diagonals of the matrix A. +*> On entry with UPLO = 'L' or 'l', K specifies the number of +*> sub-diagonals of the matrix A. +*> K must satisfy 0 .le. K. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension ( LDA, N ) +*> Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) +*> by n part of the array A must contain the upper triangular +*> band part of the matrix of coefficients, supplied column by +*> column, with the leading diagonal of the matrix in row +*> ( k + 1 ) of the array, the first super-diagonal starting at +*> position 2 in row k, and so on. The top left k by k triangle +*> of the array A is not referenced. +*> The following program segment will transfer an upper +*> triangular band matrix from conventional full matrix storage +*> to band storage: +*> +*> DO 20, J = 1, N +*> M = K + 1 - J +*> DO 10, I = MAX( 1, J - K ), J +*> A( M + I, J ) = matrix( I, J ) +*> 10 CONTINUE +*> 20 CONTINUE +*> +*> Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) +*> by n part of the array A must contain the lower triangular +*> band part of the matrix of coefficients, supplied column by +*> column, with the leading diagonal of the matrix in row 1 of +*> the array, the first sub-diagonal starting at position 1 in +*> row 2, and so on. The bottom right k by k triangle of the +*> array A is not referenced. +*> The following program segment will transfer a lower +*> triangular band matrix from conventional full matrix storage +*> to band storage: +*> +*> DO 20, J = 1, N +*> M = 1 - J +*> DO 10, I = J, MIN( N, J + K ) +*> A( M + I, J ) = matrix( I, J ) +*> 10 CONTINUE +*> 20 CONTINUE +*> +*> Note that when DIAG = 'U' or 'u' the elements of the array A +*> corresponding to the diagonal elements of the matrix are not +*> referenced, but are assumed to be unity. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> ( k + 1 ). +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is COMPLEX*16 array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element right-hand side vector b. On exit, X is overwritten +*> with the solution vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup tbsv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZTBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,K,LDA,N + CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,IX,J,JX,KPLUS1,KX,L + LOGICAL NOCONJ,NOUNIT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG,MAX,MIN +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (.NOT.LSAME(TRANS,'N') .AND. + + .NOT.LSAME(TRANS,'T') .AND. + + .NOT.LSAME(TRANS,'C')) THEN + INFO = 2 + ELSE IF (.NOT.LSAME(DIAG,'U') .AND. + + .NOT.LSAME(DIAG,'N')) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (K.LT.0) THEN + INFO = 5 + ELSE IF (LDA.LT. (K+1)) THEN + INFO = 7 + ELSE IF (INCX.EQ.0) THEN + INFO = 9 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('ZTBSV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (N.EQ.0) RETURN +* + NOCONJ = LSAME(TRANS,'T') + NOUNIT = LSAME(DIAG,'N') +* +* Set up the start point in X if the increment is not unity. This +* will be ( N - 1 )*INCX too small for descending loops. +* + IF (INCX.LE.0) THEN + KX = 1 - (N-1)*INCX + ELSE IF (INCX.NE.1) THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of A are +* accessed by sequentially with one pass through A. +* + IF (LSAME(TRANS,'N')) THEN +* +* Form x := inv( A )*x. +* + IF (LSAME(UPLO,'U')) THEN + KPLUS1 = K + 1 + IF (INCX.EQ.1) THEN + DO 20 J = N,1,-1 + IF (X(J).NE.ZERO) THEN + L = KPLUS1 - J + IF (NOUNIT) X(J) = X(J)/A(KPLUS1,J) + TEMP = X(J) + DO 10 I = J - 1,MAX(1,J-K),-1 + X(I) = X(I) - TEMP*A(L+I,J) + 10 CONTINUE + END IF + 20 CONTINUE + ELSE + KX = KX + (N-1)*INCX + JX = KX + DO 40 J = N,1,-1 + KX = KX - INCX + IF (X(JX).NE.ZERO) THEN + IX = KX + L = KPLUS1 - J + IF (NOUNIT) X(JX) = X(JX)/A(KPLUS1,J) + TEMP = X(JX) + DO 30 I = J - 1,MAX(1,J-K),-1 + X(IX) = X(IX) - TEMP*A(L+I,J) + IX = IX - INCX + 30 CONTINUE + END IF + JX = JX - INCX + 40 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 60 J = 1,N + IF (X(J).NE.ZERO) THEN + L = 1 - J + IF (NOUNIT) X(J) = X(J)/A(1,J) + TEMP = X(J) + DO 50 I = J + 1,MIN(N,J+K) + X(I) = X(I) - TEMP*A(L+I,J) + 50 CONTINUE + END IF + 60 CONTINUE + ELSE + JX = KX + DO 80 J = 1,N + KX = KX + INCX + IF (X(JX).NE.ZERO) THEN + IX = KX + L = 1 - J + IF (NOUNIT) X(JX) = X(JX)/A(1,J) + TEMP = X(JX) + DO 70 I = J + 1,MIN(N,J+K) + X(IX) = X(IX) - TEMP*A(L+I,J) + IX = IX + INCX + 70 CONTINUE + END IF + JX = JX + INCX + 80 CONTINUE + END IF + END IF + ELSE +* +* Form x := inv( A**T )*x or x := inv( A**H )*x. +* + IF (LSAME(UPLO,'U')) THEN + KPLUS1 = K + 1 + IF (INCX.EQ.1) THEN + DO 110 J = 1,N + TEMP = X(J) + L = KPLUS1 - J + IF (NOCONJ) THEN + DO 90 I = MAX(1,J-K),J - 1 + TEMP = TEMP - A(L+I,J)*X(I) + 90 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(KPLUS1,J) + ELSE + DO 100 I = MAX(1,J-K),J - 1 + TEMP = TEMP - DCONJG(A(L+I,J))*X(I) + 100 CONTINUE + IF (NOUNIT) TEMP = TEMP/DCONJG(A(KPLUS1,J)) + END IF + X(J) = TEMP + 110 CONTINUE + ELSE + JX = KX + DO 140 J = 1,N + TEMP = X(JX) + IX = KX + L = KPLUS1 - J + IF (NOCONJ) THEN + DO 120 I = MAX(1,J-K),J - 1 + TEMP = TEMP - A(L+I,J)*X(IX) + IX = IX + INCX + 120 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(KPLUS1,J) + ELSE + DO 130 I = MAX(1,J-K),J - 1 + TEMP = TEMP - DCONJG(A(L+I,J))*X(IX) + IX = IX + INCX + 130 CONTINUE + IF (NOUNIT) TEMP = TEMP/DCONJG(A(KPLUS1,J)) + END IF + X(JX) = TEMP + JX = JX + INCX + IF (J.GT.K) KX = KX + INCX + 140 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 170 J = N,1,-1 + TEMP = X(J) + L = 1 - J + IF (NOCONJ) THEN + DO 150 I = MIN(N,J+K),J + 1,-1 + TEMP = TEMP - A(L+I,J)*X(I) + 150 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(1,J) + ELSE + DO 160 I = MIN(N,J+K),J + 1,-1 + TEMP = TEMP - DCONJG(A(L+I,J))*X(I) + 160 CONTINUE + IF (NOUNIT) TEMP = TEMP/DCONJG(A(1,J)) + END IF + X(J) = TEMP + 170 CONTINUE + ELSE + KX = KX + (N-1)*INCX + JX = KX + DO 200 J = N,1,-1 + TEMP = X(JX) + IX = KX + L = 1 - J + IF (NOCONJ) THEN + DO 180 I = MIN(N,J+K),J + 1,-1 + TEMP = TEMP - A(L+I,J)*X(IX) + IX = IX - INCX + 180 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(1,J) + ELSE + DO 190 I = MIN(N,J+K),J + 1,-1 + TEMP = TEMP - DCONJG(A(L+I,J))*X(IX) + IX = IX - INCX + 190 CONTINUE + IF (NOUNIT) TEMP = TEMP/DCONJG(A(1,J)) + END IF + X(JX) = TEMP + JX = JX - INCX + IF ((N-J).GE.K) KX = KX - INCX + 200 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of ZTBSV +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/ztpmv.f b/fortran_implementation/external_libraries/BLAS/SRC/ztpmv.f new file mode 100644 index 0000000..be20048 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/ztpmv.f @@ -0,0 +1,387 @@ +*> \brief \b ZTPMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZTPMV(UPLO,TRANS,DIAG,N,AP,X,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,N +* CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 AP(*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZTPMV performs one of the matrix-vector operations +*> +*> x := A*x, or x := A**T*x, or x := A**H*x, +*> +*> where x is an n element vector and A is an n by n unit, or non-unit, +*> upper or lower triangular matrix, supplied in packed form. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the matrix is an upper or +*> lower triangular matrix as follows: +*> +*> UPLO = 'U' or 'u' A is an upper triangular matrix. +*> +*> UPLO = 'L' or 'l' A is a lower triangular matrix. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the operation to be performed as +*> follows: +*> +*> TRANS = 'N' or 'n' x := A*x. +*> +*> TRANS = 'T' or 't' x := A**T*x. +*> +*> TRANS = 'C' or 'c' x := A**H*x. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> On entry, DIAG specifies whether or not A is unit +*> triangular as follows: +*> +*> DIAG = 'U' or 'u' A is assumed to be unit triangular. +*> +*> DIAG = 'N' or 'n' A is not assumed to be unit +*> triangular. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] AP +*> \verbatim +*> AP is COMPLEX*16 array, dimension at least +*> ( ( n*( n + 1 ) )/2 ). +*> Before entry with UPLO = 'U' or 'u', the array AP must +*> contain the upper triangular matrix packed sequentially, +*> column by column, so that AP( 1 ) contains a( 1, 1 ), +*> AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) +*> respectively, and so on. +*> Before entry with UPLO = 'L' or 'l', the array AP must +*> contain the lower triangular matrix packed sequentially, +*> column by column, so that AP( 1 ) contains a( 1, 1 ), +*> AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) +*> respectively, and so on. +*> Note that when DIAG = 'U' or 'u', the diagonal elements of +*> A are not referenced, but are assumed to be unity. +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is COMPLEX*16 array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element vector x. On exit, X is overwritten with the +*> transformed vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup tpmv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> The vector and matrix arguments are not referenced when N = 0, or M = 0 +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZTPMV(UPLO,TRANS,DIAG,N,AP,X,INCX) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,N + CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 AP(*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,IX,J,JX,K,KK,KX + LOGICAL NOCONJ,NOUNIT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (.NOT.LSAME(TRANS,'N') .AND. + + .NOT.LSAME(TRANS,'T') .AND. + + .NOT.LSAME(TRANS,'C')) THEN + INFO = 2 + ELSE IF (.NOT.LSAME(DIAG,'U') .AND. + + .NOT.LSAME(DIAG,'N')) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (INCX.EQ.0) THEN + INFO = 7 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('ZTPMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (N.EQ.0) RETURN +* + NOCONJ = LSAME(TRANS,'T') + NOUNIT = LSAME(DIAG,'N') +* +* Set up the start point in X if the increment is not unity. This +* will be ( N - 1 )*INCX too small for descending loops. +* + IF (INCX.LE.0) THEN + KX = 1 - (N-1)*INCX + ELSE IF (INCX.NE.1) THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of AP are +* accessed sequentially with one pass through AP. +* + IF (LSAME(TRANS,'N')) THEN +* +* Form x:= A*x. +* + IF (LSAME(UPLO,'U')) THEN + KK = 1 + IF (INCX.EQ.1) THEN + DO 20 J = 1,N + IF (X(J).NE.ZERO) THEN + TEMP = X(J) + K = KK + DO 10 I = 1,J - 1 + X(I) = X(I) + TEMP*AP(K) + K = K + 1 + 10 CONTINUE + IF (NOUNIT) X(J) = X(J)*AP(KK+J-1) + END IF + KK = KK + J + 20 CONTINUE + ELSE + JX = KX + DO 40 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = X(JX) + IX = KX + DO 30 K = KK,KK + J - 2 + X(IX) = X(IX) + TEMP*AP(K) + IX = IX + INCX + 30 CONTINUE + IF (NOUNIT) X(JX) = X(JX)*AP(KK+J-1) + END IF + JX = JX + INCX + KK = KK + J + 40 CONTINUE + END IF + ELSE + KK = (N* (N+1))/2 + IF (INCX.EQ.1) THEN + DO 60 J = N,1,-1 + IF (X(J).NE.ZERO) THEN + TEMP = X(J) + K = KK + DO 50 I = N,J + 1,-1 + X(I) = X(I) + TEMP*AP(K) + K = K - 1 + 50 CONTINUE + IF (NOUNIT) X(J) = X(J)*AP(KK-N+J) + END IF + KK = KK - (N-J+1) + 60 CONTINUE + ELSE + KX = KX + (N-1)*INCX + JX = KX + DO 80 J = N,1,-1 + IF (X(JX).NE.ZERO) THEN + TEMP = X(JX) + IX = KX + DO 70 K = KK,KK - (N- (J+1)),-1 + X(IX) = X(IX) + TEMP*AP(K) + IX = IX - INCX + 70 CONTINUE + IF (NOUNIT) X(JX) = X(JX)*AP(KK-N+J) + END IF + JX = JX - INCX + KK = KK - (N-J+1) + 80 CONTINUE + END IF + END IF + ELSE +* +* Form x := A**T*x or x := A**H*x. +* + IF (LSAME(UPLO,'U')) THEN + KK = (N* (N+1))/2 + IF (INCX.EQ.1) THEN + DO 110 J = N,1,-1 + TEMP = X(J) + K = KK - 1 + IF (NOCONJ) THEN + IF (NOUNIT) TEMP = TEMP*AP(KK) + DO 90 I = J - 1,1,-1 + TEMP = TEMP + AP(K)*X(I) + K = K - 1 + 90 CONTINUE + ELSE + IF (NOUNIT) TEMP = TEMP*DCONJG(AP(KK)) + DO 100 I = J - 1,1,-1 + TEMP = TEMP + DCONJG(AP(K))*X(I) + K = K - 1 + 100 CONTINUE + END IF + X(J) = TEMP + KK = KK - J + 110 CONTINUE + ELSE + JX = KX + (N-1)*INCX + DO 140 J = N,1,-1 + TEMP = X(JX) + IX = JX + IF (NOCONJ) THEN + IF (NOUNIT) TEMP = TEMP*AP(KK) + DO 120 K = KK - 1,KK - J + 1,-1 + IX = IX - INCX + TEMP = TEMP + AP(K)*X(IX) + 120 CONTINUE + ELSE + IF (NOUNIT) TEMP = TEMP*DCONJG(AP(KK)) + DO 130 K = KK - 1,KK - J + 1,-1 + IX = IX - INCX + TEMP = TEMP + DCONJG(AP(K))*X(IX) + 130 CONTINUE + END IF + X(JX) = TEMP + JX = JX - INCX + KK = KK - J + 140 CONTINUE + END IF + ELSE + KK = 1 + IF (INCX.EQ.1) THEN + DO 170 J = 1,N + TEMP = X(J) + K = KK + 1 + IF (NOCONJ) THEN + IF (NOUNIT) TEMP = TEMP*AP(KK) + DO 150 I = J + 1,N + TEMP = TEMP + AP(K)*X(I) + K = K + 1 + 150 CONTINUE + ELSE + IF (NOUNIT) TEMP = TEMP*DCONJG(AP(KK)) + DO 160 I = J + 1,N + TEMP = TEMP + DCONJG(AP(K))*X(I) + K = K + 1 + 160 CONTINUE + END IF + X(J) = TEMP + KK = KK + (N-J+1) + 170 CONTINUE + ELSE + JX = KX + DO 200 J = 1,N + TEMP = X(JX) + IX = JX + IF (NOCONJ) THEN + IF (NOUNIT) TEMP = TEMP*AP(KK) + DO 180 K = KK + 1,KK + N - J + IX = IX + INCX + TEMP = TEMP + AP(K)*X(IX) + 180 CONTINUE + ELSE + IF (NOUNIT) TEMP = TEMP*DCONJG(AP(KK)) + DO 190 K = KK + 1,KK + N - J + IX = IX + INCX + TEMP = TEMP + DCONJG(AP(K))*X(IX) + 190 CONTINUE + END IF + X(JX) = TEMP + JX = JX + INCX + KK = KK + (N-J+1) + 200 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of ZTPMV +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/ztpsv.f b/fortran_implementation/external_libraries/BLAS/SRC/ztpsv.f new file mode 100644 index 0000000..436fb07 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/ztpsv.f @@ -0,0 +1,389 @@ +*> \brief \b ZTPSV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZTPSV(UPLO,TRANS,DIAG,N,AP,X,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,N +* CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 AP(*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZTPSV solves one of the systems of equations +*> +*> A*x = b, or A**T*x = b, or A**H*x = b, +*> +*> where b and x are n element vectors and A is an n by n unit, or +*> non-unit, upper or lower triangular matrix, supplied in packed form. +*> +*> No test for singularity or near-singularity is included in this +*> routine. Such tests must be performed before calling this routine. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the matrix is an upper or +*> lower triangular matrix as follows: +*> +*> UPLO = 'U' or 'u' A is an upper triangular matrix. +*> +*> UPLO = 'L' or 'l' A is a lower triangular matrix. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the equations to be solved as +*> follows: +*> +*> TRANS = 'N' or 'n' A*x = b. +*> +*> TRANS = 'T' or 't' A**T*x = b. +*> +*> TRANS = 'C' or 'c' A**H*x = b. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> On entry, DIAG specifies whether or not A is unit +*> triangular as follows: +*> +*> DIAG = 'U' or 'u' A is assumed to be unit triangular. +*> +*> DIAG = 'N' or 'n' A is not assumed to be unit +*> triangular. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] AP +*> \verbatim +*> AP is COMPLEX*16 array, dimension at least +*> ( ( n*( n + 1 ) )/2 ). +*> Before entry with UPLO = 'U' or 'u', the array AP must +*> contain the upper triangular matrix packed sequentially, +*> column by column, so that AP( 1 ) contains a( 1, 1 ), +*> AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) +*> respectively, and so on. +*> Before entry with UPLO = 'L' or 'l', the array AP must +*> contain the lower triangular matrix packed sequentially, +*> column by column, so that AP( 1 ) contains a( 1, 1 ), +*> AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) +*> respectively, and so on. +*> Note that when DIAG = 'U' or 'u', the diagonal elements of +*> A are not referenced, but are assumed to be unity. +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is COMPLEX*16 array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element right-hand side vector b. On exit, X is overwritten +*> with the solution vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup tpsv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZTPSV(UPLO,TRANS,DIAG,N,AP,X,INCX) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,N + CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 AP(*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,IX,J,JX,K,KK,KX + LOGICAL NOCONJ,NOUNIT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (.NOT.LSAME(TRANS,'N') .AND. + + .NOT.LSAME(TRANS,'T') .AND. + + .NOT.LSAME(TRANS,'C')) THEN + INFO = 2 + ELSE IF (.NOT.LSAME(DIAG,'U') .AND. + + .NOT.LSAME(DIAG,'N')) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (INCX.EQ.0) THEN + INFO = 7 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('ZTPSV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (N.EQ.0) RETURN +* + NOCONJ = LSAME(TRANS,'T') + NOUNIT = LSAME(DIAG,'N') +* +* Set up the start point in X if the increment is not unity. This +* will be ( N - 1 )*INCX too small for descending loops. +* + IF (INCX.LE.0) THEN + KX = 1 - (N-1)*INCX + ELSE IF (INCX.NE.1) THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of AP are +* accessed sequentially with one pass through AP. +* + IF (LSAME(TRANS,'N')) THEN +* +* Form x := inv( A )*x. +* + IF (LSAME(UPLO,'U')) THEN + KK = (N* (N+1))/2 + IF (INCX.EQ.1) THEN + DO 20 J = N,1,-1 + IF (X(J).NE.ZERO) THEN + IF (NOUNIT) X(J) = X(J)/AP(KK) + TEMP = X(J) + K = KK - 1 + DO 10 I = J - 1,1,-1 + X(I) = X(I) - TEMP*AP(K) + K = K - 1 + 10 CONTINUE + END IF + KK = KK - J + 20 CONTINUE + ELSE + JX = KX + (N-1)*INCX + DO 40 J = N,1,-1 + IF (X(JX).NE.ZERO) THEN + IF (NOUNIT) X(JX) = X(JX)/AP(KK) + TEMP = X(JX) + IX = JX + DO 30 K = KK - 1,KK - J + 1,-1 + IX = IX - INCX + X(IX) = X(IX) - TEMP*AP(K) + 30 CONTINUE + END IF + JX = JX - INCX + KK = KK - J + 40 CONTINUE + END IF + ELSE + KK = 1 + IF (INCX.EQ.1) THEN + DO 60 J = 1,N + IF (X(J).NE.ZERO) THEN + IF (NOUNIT) X(J) = X(J)/AP(KK) + TEMP = X(J) + K = KK + 1 + DO 50 I = J + 1,N + X(I) = X(I) - TEMP*AP(K) + K = K + 1 + 50 CONTINUE + END IF + KK = KK + (N-J+1) + 60 CONTINUE + ELSE + JX = KX + DO 80 J = 1,N + IF (X(JX).NE.ZERO) THEN + IF (NOUNIT) X(JX) = X(JX)/AP(KK) + TEMP = X(JX) + IX = JX + DO 70 K = KK + 1,KK + N - J + IX = IX + INCX + X(IX) = X(IX) - TEMP*AP(K) + 70 CONTINUE + END IF + JX = JX + INCX + KK = KK + (N-J+1) + 80 CONTINUE + END IF + END IF + ELSE +* +* Form x := inv( A**T )*x or x := inv( A**H )*x. +* + IF (LSAME(UPLO,'U')) THEN + KK = 1 + IF (INCX.EQ.1) THEN + DO 110 J = 1,N + TEMP = X(J) + K = KK + IF (NOCONJ) THEN + DO 90 I = 1,J - 1 + TEMP = TEMP - AP(K)*X(I) + K = K + 1 + 90 CONTINUE + IF (NOUNIT) TEMP = TEMP/AP(KK+J-1) + ELSE + DO 100 I = 1,J - 1 + TEMP = TEMP - DCONJG(AP(K))*X(I) + K = K + 1 + 100 CONTINUE + IF (NOUNIT) TEMP = TEMP/DCONJG(AP(KK+J-1)) + END IF + X(J) = TEMP + KK = KK + J + 110 CONTINUE + ELSE + JX = KX + DO 140 J = 1,N + TEMP = X(JX) + IX = KX + IF (NOCONJ) THEN + DO 120 K = KK,KK + J - 2 + TEMP = TEMP - AP(K)*X(IX) + IX = IX + INCX + 120 CONTINUE + IF (NOUNIT) TEMP = TEMP/AP(KK+J-1) + ELSE + DO 130 K = KK,KK + J - 2 + TEMP = TEMP - DCONJG(AP(K))*X(IX) + IX = IX + INCX + 130 CONTINUE + IF (NOUNIT) TEMP = TEMP/DCONJG(AP(KK+J-1)) + END IF + X(JX) = TEMP + JX = JX + INCX + KK = KK + J + 140 CONTINUE + END IF + ELSE + KK = (N* (N+1))/2 + IF (INCX.EQ.1) THEN + DO 170 J = N,1,-1 + TEMP = X(J) + K = KK + IF (NOCONJ) THEN + DO 150 I = N,J + 1,-1 + TEMP = TEMP - AP(K)*X(I) + K = K - 1 + 150 CONTINUE + IF (NOUNIT) TEMP = TEMP/AP(KK-N+J) + ELSE + DO 160 I = N,J + 1,-1 + TEMP = TEMP - DCONJG(AP(K))*X(I) + K = K - 1 + 160 CONTINUE + IF (NOUNIT) TEMP = TEMP/DCONJG(AP(KK-N+J)) + END IF + X(J) = TEMP + KK = KK - (N-J+1) + 170 CONTINUE + ELSE + KX = KX + (N-1)*INCX + JX = KX + DO 200 J = N,1,-1 + TEMP = X(JX) + IX = KX + IF (NOCONJ) THEN + DO 180 K = KK,KK - (N- (J+1)),-1 + TEMP = TEMP - AP(K)*X(IX) + IX = IX - INCX + 180 CONTINUE + IF (NOUNIT) TEMP = TEMP/AP(KK-N+J) + ELSE + DO 190 K = KK,KK - (N- (J+1)),-1 + TEMP = TEMP - DCONJG(AP(K))*X(IX) + IX = IX - INCX + 190 CONTINUE + IF (NOUNIT) TEMP = TEMP/DCONJG(AP(KK-N+J)) + END IF + X(JX) = TEMP + JX = JX - INCX + KK = KK - (N-J+1) + 200 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of ZTPSV +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/ztrmm.f b/fortran_implementation/external_libraries/BLAS/SRC/ztrmm.f new file mode 100644 index 0000000..e11313d --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/ztrmm.f @@ -0,0 +1,450 @@ +*> \brief \b ZTRMM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA +* INTEGER LDA,LDB,M,N +* CHARACTER DIAG,SIDE,TRANSA,UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),B(LDB,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZTRMM performs one of the matrix-matrix operations +*> +*> B := alpha*op( A )*B, or B := alpha*B*op( A ) +*> +*> where alpha is a scalar, B is an m by n matrix, A is a unit, or +*> non-unit, upper or lower triangular matrix and op( A ) is one of +*> +*> op( A ) = A or op( A ) = A**T or op( A ) = A**H. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> On entry, SIDE specifies whether op( A ) multiplies B from +*> the left or right as follows: +*> +*> SIDE = 'L' or 'l' B := alpha*op( A )*B. +*> +*> SIDE = 'R' or 'r' B := alpha*B*op( A ). +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the matrix A is an upper or +*> lower triangular matrix as follows: +*> +*> UPLO = 'U' or 'u' A is an upper triangular matrix. +*> +*> UPLO = 'L' or 'l' A is a lower triangular matrix. +*> \endverbatim +*> +*> \param[in] TRANSA +*> \verbatim +*> TRANSA is CHARACTER*1 +*> On entry, TRANSA specifies the form of op( A ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSA = 'N' or 'n' op( A ) = A. +*> +*> TRANSA = 'T' or 't' op( A ) = A**T. +*> +*> TRANSA = 'C' or 'c' op( A ) = A**H. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> On entry, DIAG specifies whether or not A is unit triangular +*> as follows: +*> +*> DIAG = 'U' or 'u' A is assumed to be unit triangular. +*> +*> DIAG = 'N' or 'n' A is not assumed to be unit +*> triangular. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of B. M must be at +*> least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of B. N must be +*> at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX*16 +*> On entry, ALPHA specifies the scalar alpha. When alpha is +*> zero then A is not referenced and B need not be set before +*> entry. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension ( LDA, k ), where k is m +*> when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. +*> Before entry with UPLO = 'U' or 'u', the leading k by k +*> upper triangular part of the array A must contain the upper +*> triangular matrix and the strictly lower triangular part of +*> A is not referenced. +*> Before entry with UPLO = 'L' or 'l', the leading k by k +*> lower triangular part of the array A must contain the lower +*> triangular matrix and the strictly upper triangular part of +*> A is not referenced. +*> Note that when DIAG = 'U' or 'u', the diagonal elements of +*> A are not referenced either, but are assumed to be unity. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When SIDE = 'L' or 'l' then +*> LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' +*> then LDA must be at least max( 1, n ). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX*16 array, dimension ( LDB, N ). +*> Before entry, the leading m by n part of the array B must +*> contain the matrix B, and on exit is overwritten by the +*> transformed matrix. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. LDB must be at least +*> max( 1, m ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup trmm +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> -- Written on 8-February-1989. +*> Jack Dongarra, Argonne National Laboratory. +*> Iain Duff, AERE Harwell. +*> Jeremy Du Croz, Numerical Algorithms Group Ltd. +*> Sven Hammarling, Numerical Algorithms Group Ltd. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +* +* -- Reference BLAS level3 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX*16 ALPHA + INTEGER LDA,LDB,M,N + CHARACTER DIAG,SIDE,TRANSA,UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),B(LDB,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG,MAX +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,J,K,NROWA + LOGICAL LSIDE,NOCONJ,NOUNIT,UPPER +* .. +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER (ONE= (1.0D+0,0.0D+0)) + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* +* Test the input parameters. +* + LSIDE = LSAME(SIDE,'L') + IF (LSIDE) THEN + NROWA = M + ELSE + NROWA = N + END IF + NOCONJ = LSAME(TRANSA,'T') + NOUNIT = LSAME(DIAG,'N') + UPPER = LSAME(UPLO,'U') +* + INFO = 0 + IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN + INFO = 1 + ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN + INFO = 2 + ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND. + + (.NOT.LSAME(TRANSA,'T')) .AND. + + (.NOT.LSAME(TRANSA,'C'))) THEN + INFO = 3 + ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. + + (.NOT.LSAME(DIAG,'N'))) THEN + INFO = 4 + ELSE IF (M.LT.0) THEN + INFO = 5 + ELSE IF (N.LT.0) THEN + INFO = 6 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 9 + ELSE IF (LDB.LT.MAX(1,M)) THEN + INFO = 11 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('ZTRMM ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (M.EQ.0 .OR. N.EQ.0) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,M + B(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + RETURN + END IF +* +* Start the operations. +* + IF (LSIDE) THEN + IF (LSAME(TRANSA,'N')) THEN +* +* Form B := alpha*A*B. +* + IF (UPPER) THEN + DO 50 J = 1,N + DO 40 K = 1,M + IF (B(K,J).NE.ZERO) THEN + TEMP = ALPHA*B(K,J) + DO 30 I = 1,K - 1 + B(I,J) = B(I,J) + TEMP*A(I,K) + 30 CONTINUE + IF (NOUNIT) TEMP = TEMP*A(K,K) + B(K,J) = TEMP + END IF + 40 CONTINUE + 50 CONTINUE + ELSE + DO 80 J = 1,N + DO 70 K = M,1,-1 + IF (B(K,J).NE.ZERO) THEN + TEMP = ALPHA*B(K,J) + B(K,J) = TEMP + IF (NOUNIT) B(K,J) = B(K,J)*A(K,K) + DO 60 I = K + 1,M + B(I,J) = B(I,J) + TEMP*A(I,K) + 60 CONTINUE + END IF + 70 CONTINUE + 80 CONTINUE + END IF + ELSE +* +* Form B := alpha*A**T*B or B := alpha*A**H*B. +* + IF (UPPER) THEN + DO 120 J = 1,N + DO 110 I = M,1,-1 + TEMP = B(I,J) + IF (NOCONJ) THEN + IF (NOUNIT) TEMP = TEMP*A(I,I) + DO 90 K = 1,I - 1 + TEMP = TEMP + A(K,I)*B(K,J) + 90 CONTINUE + ELSE + IF (NOUNIT) TEMP = TEMP*DCONJG(A(I,I)) + DO 100 K = 1,I - 1 + TEMP = TEMP + DCONJG(A(K,I))*B(K,J) + 100 CONTINUE + END IF + B(I,J) = ALPHA*TEMP + 110 CONTINUE + 120 CONTINUE + ELSE + DO 160 J = 1,N + DO 150 I = 1,M + TEMP = B(I,J) + IF (NOCONJ) THEN + IF (NOUNIT) TEMP = TEMP*A(I,I) + DO 130 K = I + 1,M + TEMP = TEMP + A(K,I)*B(K,J) + 130 CONTINUE + ELSE + IF (NOUNIT) TEMP = TEMP*DCONJG(A(I,I)) + DO 140 K = I + 1,M + TEMP = TEMP + DCONJG(A(K,I))*B(K,J) + 140 CONTINUE + END IF + B(I,J) = ALPHA*TEMP + 150 CONTINUE + 160 CONTINUE + END IF + END IF + ELSE + IF (LSAME(TRANSA,'N')) THEN +* +* Form B := alpha*B*A. +* + IF (UPPER) THEN + DO 200 J = N,1,-1 + TEMP = ALPHA + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 170 I = 1,M + B(I,J) = TEMP*B(I,J) + 170 CONTINUE + DO 190 K = 1,J - 1 + IF (A(K,J).NE.ZERO) THEN + TEMP = ALPHA*A(K,J) + DO 180 I = 1,M + B(I,J) = B(I,J) + TEMP*B(I,K) + 180 CONTINUE + END IF + 190 CONTINUE + 200 CONTINUE + ELSE + DO 240 J = 1,N + TEMP = ALPHA + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 210 I = 1,M + B(I,J) = TEMP*B(I,J) + 210 CONTINUE + DO 230 K = J + 1,N + IF (A(K,J).NE.ZERO) THEN + TEMP = ALPHA*A(K,J) + DO 220 I = 1,M + B(I,J) = B(I,J) + TEMP*B(I,K) + 220 CONTINUE + END IF + 230 CONTINUE + 240 CONTINUE + END IF + ELSE +* +* Form B := alpha*B*A**T or B := alpha*B*A**H. +* + IF (UPPER) THEN + DO 280 K = 1,N + DO 260 J = 1,K - 1 + IF (A(J,K).NE.ZERO) THEN + IF (NOCONJ) THEN + TEMP = ALPHA*A(J,K) + ELSE + TEMP = ALPHA*DCONJG(A(J,K)) + END IF + DO 250 I = 1,M + B(I,J) = B(I,J) + TEMP*B(I,K) + 250 CONTINUE + END IF + 260 CONTINUE + TEMP = ALPHA + IF (NOUNIT) THEN + IF (NOCONJ) THEN + TEMP = TEMP*A(K,K) + ELSE + TEMP = TEMP*DCONJG(A(K,K)) + END IF + END IF + IF (TEMP.NE.ONE) THEN + DO 270 I = 1,M + B(I,K) = TEMP*B(I,K) + 270 CONTINUE + END IF + 280 CONTINUE + ELSE + DO 320 K = N,1,-1 + DO 300 J = K + 1,N + IF (A(J,K).NE.ZERO) THEN + IF (NOCONJ) THEN + TEMP = ALPHA*A(J,K) + ELSE + TEMP = ALPHA*DCONJG(A(J,K)) + END IF + DO 290 I = 1,M + B(I,J) = B(I,J) + TEMP*B(I,K) + 290 CONTINUE + END IF + 300 CONTINUE + TEMP = ALPHA + IF (NOUNIT) THEN + IF (NOCONJ) THEN + TEMP = TEMP*A(K,K) + ELSE + TEMP = TEMP*DCONJG(A(K,K)) + END IF + END IF + IF (TEMP.NE.ONE) THEN + DO 310 I = 1,M + B(I,K) = TEMP*B(I,K) + 310 CONTINUE + END IF + 320 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of ZTRMM +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/ztrmv.f b/fortran_implementation/external_libraries/BLAS/SRC/ztrmv.f new file mode 100644 index 0000000..f72def8 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/ztrmv.f @@ -0,0 +1,372 @@ +*> \brief \b ZTRMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,LDA,N +* CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZTRMV performs one of the matrix-vector operations +*> +*> x := A*x, or x := A**T*x, or x := A**H*x, +*> +*> where x is an n element vector and A is an n by n unit, or non-unit, +*> upper or lower triangular matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the matrix is an upper or +*> lower triangular matrix as follows: +*> +*> UPLO = 'U' or 'u' A is an upper triangular matrix. +*> +*> UPLO = 'L' or 'l' A is a lower triangular matrix. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the operation to be performed as +*> follows: +*> +*> TRANS = 'N' or 'n' x := A*x. +*> +*> TRANS = 'T' or 't' x := A**T*x. +*> +*> TRANS = 'C' or 'c' x := A**H*x. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> On entry, DIAG specifies whether or not A is unit +*> triangular as follows: +*> +*> DIAG = 'U' or 'u' A is assumed to be unit triangular. +*> +*> DIAG = 'N' or 'n' A is not assumed to be unit +*> triangular. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension ( LDA, N ). +*> Before entry with UPLO = 'U' or 'u', the leading n by n +*> upper triangular part of the array A must contain the upper +*> triangular matrix and the strictly lower triangular part of +*> A is not referenced. +*> Before entry with UPLO = 'L' or 'l', the leading n by n +*> lower triangular part of the array A must contain the lower +*> triangular matrix and the strictly upper triangular part of +*> A is not referenced. +*> Note that when DIAG = 'U' or 'u', the diagonal elements of +*> A are not referenced either, but are assumed to be unity. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> max( 1, n ). +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is COMPLEX*16 array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element vector x. On exit, X is overwritten with the +*> transformed vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup trmv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> The vector and matrix arguments are not referenced when N = 0, or M = 0 +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,LDA,N + CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,IX,J,JX,KX + LOGICAL NOCONJ,NOUNIT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG,MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (.NOT.LSAME(TRANS,'N') .AND. + + .NOT.LSAME(TRANS,'T') .AND. + + .NOT.LSAME(TRANS,'C')) THEN + INFO = 2 + ELSE IF (.NOT.LSAME(DIAG,'U') .AND. + + .NOT.LSAME(DIAG,'N')) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (LDA.LT.MAX(1,N)) THEN + INFO = 6 + ELSE IF (INCX.EQ.0) THEN + INFO = 8 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('ZTRMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (N.EQ.0) RETURN +* + NOCONJ = LSAME(TRANS,'T') + NOUNIT = LSAME(DIAG,'N') +* +* Set up the start point in X if the increment is not unity. This +* will be ( N - 1 )*INCX too small for descending loops. +* + IF (INCX.LE.0) THEN + KX = 1 - (N-1)*INCX + ELSE IF (INCX.NE.1) THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* + IF (LSAME(TRANS,'N')) THEN +* +* Form x := A*x. +* + IF (LSAME(UPLO,'U')) THEN + IF (INCX.EQ.1) THEN + DO 20 J = 1,N + IF (X(J).NE.ZERO) THEN + TEMP = X(J) + DO 10 I = 1,J - 1 + X(I) = X(I) + TEMP*A(I,J) + 10 CONTINUE + IF (NOUNIT) X(J) = X(J)*A(J,J) + END IF + 20 CONTINUE + ELSE + JX = KX + DO 40 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = X(JX) + IX = KX + DO 30 I = 1,J - 1 + X(IX) = X(IX) + TEMP*A(I,J) + IX = IX + INCX + 30 CONTINUE + IF (NOUNIT) X(JX) = X(JX)*A(J,J) + END IF + JX = JX + INCX + 40 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 60 J = N,1,-1 + IF (X(J).NE.ZERO) THEN + TEMP = X(J) + DO 50 I = N,J + 1,-1 + X(I) = X(I) + TEMP*A(I,J) + 50 CONTINUE + IF (NOUNIT) X(J) = X(J)*A(J,J) + END IF + 60 CONTINUE + ELSE + KX = KX + (N-1)*INCX + JX = KX + DO 80 J = N,1,-1 + IF (X(JX).NE.ZERO) THEN + TEMP = X(JX) + IX = KX + DO 70 I = N,J + 1,-1 + X(IX) = X(IX) + TEMP*A(I,J) + IX = IX - INCX + 70 CONTINUE + IF (NOUNIT) X(JX) = X(JX)*A(J,J) + END IF + JX = JX - INCX + 80 CONTINUE + END IF + END IF + ELSE +* +* Form x := A**T*x or x := A**H*x. +* + IF (LSAME(UPLO,'U')) THEN + IF (INCX.EQ.1) THEN + DO 110 J = N,1,-1 + TEMP = X(J) + IF (NOCONJ) THEN + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 90 I = J - 1,1,-1 + TEMP = TEMP + A(I,J)*X(I) + 90 CONTINUE + ELSE + IF (NOUNIT) TEMP = TEMP*DCONJG(A(J,J)) + DO 100 I = J - 1,1,-1 + TEMP = TEMP + DCONJG(A(I,J))*X(I) + 100 CONTINUE + END IF + X(J) = TEMP + 110 CONTINUE + ELSE + JX = KX + (N-1)*INCX + DO 140 J = N,1,-1 + TEMP = X(JX) + IX = JX + IF (NOCONJ) THEN + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 120 I = J - 1,1,-1 + IX = IX - INCX + TEMP = TEMP + A(I,J)*X(IX) + 120 CONTINUE + ELSE + IF (NOUNIT) TEMP = TEMP*DCONJG(A(J,J)) + DO 130 I = J - 1,1,-1 + IX = IX - INCX + TEMP = TEMP + DCONJG(A(I,J))*X(IX) + 130 CONTINUE + END IF + X(JX) = TEMP + JX = JX - INCX + 140 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 170 J = 1,N + TEMP = X(J) + IF (NOCONJ) THEN + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 150 I = J + 1,N + TEMP = TEMP + A(I,J)*X(I) + 150 CONTINUE + ELSE + IF (NOUNIT) TEMP = TEMP*DCONJG(A(J,J)) + DO 160 I = J + 1,N + TEMP = TEMP + DCONJG(A(I,J))*X(I) + 160 CONTINUE + END IF + X(J) = TEMP + 170 CONTINUE + ELSE + JX = KX + DO 200 J = 1,N + TEMP = X(JX) + IX = JX + IF (NOCONJ) THEN + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 180 I = J + 1,N + IX = IX + INCX + TEMP = TEMP + A(I,J)*X(IX) + 180 CONTINUE + ELSE + IF (NOUNIT) TEMP = TEMP*DCONJG(A(J,J)) + DO 190 I = J + 1,N + IX = IX + INCX + TEMP = TEMP + DCONJG(A(I,J))*X(IX) + 190 CONTINUE + END IF + X(JX) = TEMP + JX = JX + INCX + 200 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of ZTRMV +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/ztrsm.f b/fortran_implementation/external_libraries/BLAS/SRC/ztrsm.f new file mode 100644 index 0000000..8479bf7 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/ztrsm.f @@ -0,0 +1,475 @@ +*> \brief \b ZTRSM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA +* INTEGER LDA,LDB,M,N +* CHARACTER DIAG,SIDE,TRANSA,UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),B(LDB,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZTRSM solves one of the matrix equations +*> +*> op( A )*X = alpha*B, or X*op( A ) = alpha*B, +*> +*> where alpha is a scalar, X and B are m by n matrices, A is a unit, or +*> non-unit, upper or lower triangular matrix and op( A ) is one of +*> +*> op( A ) = A or op( A ) = A**T or op( A ) = A**H. +*> +*> The matrix X is overwritten on B. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> On entry, SIDE specifies whether op( A ) appears on the left +*> or right of X as follows: +*> +*> SIDE = 'L' or 'l' op( A )*X = alpha*B. +*> +*> SIDE = 'R' or 'r' X*op( A ) = alpha*B. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the matrix A is an upper or +*> lower triangular matrix as follows: +*> +*> UPLO = 'U' or 'u' A is an upper triangular matrix. +*> +*> UPLO = 'L' or 'l' A is a lower triangular matrix. +*> \endverbatim +*> +*> \param[in] TRANSA +*> \verbatim +*> TRANSA is CHARACTER*1 +*> On entry, TRANSA specifies the form of op( A ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSA = 'N' or 'n' op( A ) = A. +*> +*> TRANSA = 'T' or 't' op( A ) = A**T. +*> +*> TRANSA = 'C' or 'c' op( A ) = A**H. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> On entry, DIAG specifies whether or not A is unit triangular +*> as follows: +*> +*> DIAG = 'U' or 'u' A is assumed to be unit triangular. +*> +*> DIAG = 'N' or 'n' A is not assumed to be unit +*> triangular. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of B. M must be at +*> least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of B. N must be +*> at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX*16 +*> On entry, ALPHA specifies the scalar alpha. When alpha is +*> zero then A is not referenced and B need not be set before +*> entry. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension ( LDA, k ), +*> where k is m when SIDE = 'L' or 'l' +*> and k is n when SIDE = 'R' or 'r'. +*> Before entry with UPLO = 'U' or 'u', the leading k by k +*> upper triangular part of the array A must contain the upper +*> triangular matrix and the strictly lower triangular part of +*> A is not referenced. +*> Before entry with UPLO = 'L' or 'l', the leading k by k +*> lower triangular part of the array A must contain the lower +*> triangular matrix and the strictly upper triangular part of +*> A is not referenced. +*> Note that when DIAG = 'U' or 'u', the diagonal elements of +*> A are not referenced either, but are assumed to be unity. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When SIDE = 'L' or 'l' then +*> LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' +*> then LDA must be at least max( 1, n ). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX*16 array, dimension ( LDB, N ) +*> Before entry, the leading m by n part of the array B must +*> contain the right-hand side matrix B, and on exit is +*> overwritten by the solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. LDB must be at least +*> max( 1, m ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup trsm +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> -- Written on 8-February-1989. +*> Jack Dongarra, Argonne National Laboratory. +*> Iain Duff, AERE Harwell. +*> Jeremy Du Croz, Numerical Algorithms Group Ltd. +*> Sven Hammarling, Numerical Algorithms Group Ltd. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +* +* -- Reference BLAS level3 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX*16 ALPHA + INTEGER LDA,LDB,M,N + CHARACTER DIAG,SIDE,TRANSA,UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),B(LDB,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG,MAX +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,J,K,NROWA + LOGICAL LSIDE,NOCONJ,NOUNIT,UPPER +* .. +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER (ONE= (1.0D+0,0.0D+0)) + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* +* Test the input parameters. +* + LSIDE = LSAME(SIDE,'L') + IF (LSIDE) THEN + NROWA = M + ELSE + NROWA = N + END IF + NOCONJ = LSAME(TRANSA,'T') + NOUNIT = LSAME(DIAG,'N') + UPPER = LSAME(UPLO,'U') +* + INFO = 0 + IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN + INFO = 1 + ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN + INFO = 2 + ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND. + + (.NOT.LSAME(TRANSA,'T')) .AND. + + (.NOT.LSAME(TRANSA,'C'))) THEN + INFO = 3 + ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. + + (.NOT.LSAME(DIAG,'N'))) THEN + INFO = 4 + ELSE IF (M.LT.0) THEN + INFO = 5 + ELSE IF (N.LT.0) THEN + INFO = 6 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 9 + ELSE IF (LDB.LT.MAX(1,M)) THEN + INFO = 11 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('ZTRSM ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (M.EQ.0 .OR. N.EQ.0) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,M + B(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + RETURN + END IF +* +* Start the operations. +* + IF (LSIDE) THEN + IF (LSAME(TRANSA,'N')) THEN +* +* Form B := alpha*inv( A )*B. +* + IF (UPPER) THEN + DO 60 J = 1,N + IF (ALPHA.NE.ONE) THEN + DO 30 I = 1,M + B(I,J) = ALPHA*B(I,J) + 30 CONTINUE + END IF + DO 50 K = M,1,-1 + IF (B(K,J).NE.ZERO) THEN + IF (NOUNIT) B(K,J) = B(K,J)/A(K,K) + DO 40 I = 1,K - 1 + B(I,J) = B(I,J) - B(K,J)*A(I,K) + 40 CONTINUE + END IF + 50 CONTINUE + 60 CONTINUE + ELSE + DO 100 J = 1,N + IF (ALPHA.NE.ONE) THEN + DO 70 I = 1,M + B(I,J) = ALPHA*B(I,J) + 70 CONTINUE + END IF + DO 90 K = 1,M + IF (B(K,J).NE.ZERO) THEN + IF (NOUNIT) B(K,J) = B(K,J)/A(K,K) + DO 80 I = K + 1,M + B(I,J) = B(I,J) - B(K,J)*A(I,K) + 80 CONTINUE + END IF + 90 CONTINUE + 100 CONTINUE + END IF + ELSE +* +* Form B := alpha*inv( A**T )*B +* or B := alpha*inv( A**H )*B. +* + IF (UPPER) THEN + DO 140 J = 1,N + DO 130 I = 1,M + TEMP = ALPHA*B(I,J) + IF (NOCONJ) THEN + DO 110 K = 1,I - 1 + TEMP = TEMP - A(K,I)*B(K,J) + 110 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(I,I) + ELSE + DO 120 K = 1,I - 1 + TEMP = TEMP - DCONJG(A(K,I))*B(K,J) + 120 CONTINUE + IF (NOUNIT) TEMP = TEMP/DCONJG(A(I,I)) + END IF + B(I,J) = TEMP + 130 CONTINUE + 140 CONTINUE + ELSE + DO 180 J = 1,N + DO 170 I = M,1,-1 + TEMP = ALPHA*B(I,J) + IF (NOCONJ) THEN + DO 150 K = I + 1,M + TEMP = TEMP - A(K,I)*B(K,J) + 150 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(I,I) + ELSE + DO 160 K = I + 1,M + TEMP = TEMP - DCONJG(A(K,I))*B(K,J) + 160 CONTINUE + IF (NOUNIT) TEMP = TEMP/DCONJG(A(I,I)) + END IF + B(I,J) = TEMP + 170 CONTINUE + 180 CONTINUE + END IF + END IF + ELSE + IF (LSAME(TRANSA,'N')) THEN +* +* Form B := alpha*B*inv( A ). +* + IF (UPPER) THEN + DO 230 J = 1,N + IF (ALPHA.NE.ONE) THEN + DO 190 I = 1,M + B(I,J) = ALPHA*B(I,J) + 190 CONTINUE + END IF + DO 210 K = 1,J - 1 + IF (A(K,J).NE.ZERO) THEN + DO 200 I = 1,M + B(I,J) = B(I,J) - A(K,J)*B(I,K) + 200 CONTINUE + END IF + 210 CONTINUE + IF (NOUNIT) THEN + TEMP = ONE/A(J,J) + DO 220 I = 1,M + B(I,J) = TEMP*B(I,J) + 220 CONTINUE + END IF + 230 CONTINUE + ELSE + DO 280 J = N,1,-1 + IF (ALPHA.NE.ONE) THEN + DO 240 I = 1,M + B(I,J) = ALPHA*B(I,J) + 240 CONTINUE + END IF + DO 260 K = J + 1,N + IF (A(K,J).NE.ZERO) THEN + DO 250 I = 1,M + B(I,J) = B(I,J) - A(K,J)*B(I,K) + 250 CONTINUE + END IF + 260 CONTINUE + IF (NOUNIT) THEN + TEMP = ONE/A(J,J) + DO 270 I = 1,M + B(I,J) = TEMP*B(I,J) + 270 CONTINUE + END IF + 280 CONTINUE + END IF + ELSE +* +* Form B := alpha*B*inv( A**T ) +* or B := alpha*B*inv( A**H ). +* + IF (UPPER) THEN + DO 330 K = N,1,-1 + IF (NOUNIT) THEN + IF (NOCONJ) THEN + TEMP = ONE/A(K,K) + ELSE + TEMP = ONE/DCONJG(A(K,K)) + END IF + DO 290 I = 1,M + B(I,K) = TEMP*B(I,K) + 290 CONTINUE + END IF + DO 310 J = 1,K - 1 + IF (A(J,K).NE.ZERO) THEN + IF (NOCONJ) THEN + TEMP = A(J,K) + ELSE + TEMP = DCONJG(A(J,K)) + END IF + DO 300 I = 1,M + B(I,J) = B(I,J) - TEMP*B(I,K) + 300 CONTINUE + END IF + 310 CONTINUE + IF (ALPHA.NE.ONE) THEN + DO 320 I = 1,M + B(I,K) = ALPHA*B(I,K) + 320 CONTINUE + END IF + 330 CONTINUE + ELSE + DO 380 K = 1,N + IF (NOUNIT) THEN + IF (NOCONJ) THEN + TEMP = ONE/A(K,K) + ELSE + TEMP = ONE/DCONJG(A(K,K)) + END IF + DO 340 I = 1,M + B(I,K) = TEMP*B(I,K) + 340 CONTINUE + END IF + DO 360 J = K + 1,N + IF (A(J,K).NE.ZERO) THEN + IF (NOCONJ) THEN + TEMP = A(J,K) + ELSE + TEMP = DCONJG(A(J,K)) + END IF + DO 350 I = 1,M + B(I,J) = B(I,J) - TEMP*B(I,K) + 350 CONTINUE + END IF + 360 CONTINUE + IF (ALPHA.NE.ONE) THEN + DO 370 I = 1,M + B(I,K) = ALPHA*B(I,K) + 370 CONTINUE + END IF + 380 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of ZTRSM +* + END diff --git a/fortran_implementation/external_libraries/BLAS/SRC/ztrsv.f b/fortran_implementation/external_libraries/BLAS/SRC/ztrsv.f new file mode 100644 index 0000000..6587355 --- /dev/null +++ b/fortran_implementation/external_libraries/BLAS/SRC/ztrsv.f @@ -0,0 +1,374 @@ +*> \brief \b ZTRSV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,LDA,N +* CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZTRSV solves one of the systems of equations +*> +*> A*x = b, or A**T*x = b, or A**H*x = b, +*> +*> where b and x are n element vectors and A is an n by n unit, or +*> non-unit, upper or lower triangular matrix. +*> +*> No test for singularity or near-singularity is included in this +*> routine. Such tests must be performed before calling this routine. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the matrix is an upper or +*> lower triangular matrix as follows: +*> +*> UPLO = 'U' or 'u' A is an upper triangular matrix. +*> +*> UPLO = 'L' or 'l' A is a lower triangular matrix. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the equations to be solved as +*> follows: +*> +*> TRANS = 'N' or 'n' A*x = b. +*> +*> TRANS = 'T' or 't' A**T*x = b. +*> +*> TRANS = 'C' or 'c' A**H*x = b. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> On entry, DIAG specifies whether or not A is unit +*> triangular as follows: +*> +*> DIAG = 'U' or 'u' A is assumed to be unit triangular. +*> +*> DIAG = 'N' or 'n' A is not assumed to be unit +*> triangular. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension ( LDA, N ) +*> Before entry with UPLO = 'U' or 'u', the leading n by n +*> upper triangular part of the array A must contain the upper +*> triangular matrix and the strictly lower triangular part of +*> A is not referenced. +*> Before entry with UPLO = 'L' or 'l', the leading n by n +*> lower triangular part of the array A must contain the lower +*> triangular matrix and the strictly upper triangular part of +*> A is not referenced. +*> Note that when DIAG = 'U' or 'u', the diagonal elements of +*> A are not referenced either, but are assumed to be unity. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> max( 1, n ). +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is COMPLEX*16 array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element right-hand side vector b. On exit, X is overwritten +*> with the solution vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup trsv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,LDA,N + CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,IX,J,JX,KX + LOGICAL NOCONJ,NOUNIT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG,MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (.NOT.LSAME(TRANS,'N') .AND. + + .NOT.LSAME(TRANS,'T') .AND. + + .NOT.LSAME(TRANS,'C')) THEN + INFO = 2 + ELSE IF (.NOT.LSAME(DIAG,'U') .AND. + + .NOT.LSAME(DIAG,'N')) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (LDA.LT.MAX(1,N)) THEN + INFO = 6 + ELSE IF (INCX.EQ.0) THEN + INFO = 8 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('ZTRSV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (N.EQ.0) RETURN +* + NOCONJ = LSAME(TRANS,'T') + NOUNIT = LSAME(DIAG,'N') +* +* Set up the start point in X if the increment is not unity. This +* will be ( N - 1 )*INCX too small for descending loops. +* + IF (INCX.LE.0) THEN + KX = 1 - (N-1)*INCX + ELSE IF (INCX.NE.1) THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* + IF (LSAME(TRANS,'N')) THEN +* +* Form x := inv( A )*x. +* + IF (LSAME(UPLO,'U')) THEN + IF (INCX.EQ.1) THEN + DO 20 J = N,1,-1 + IF (X(J).NE.ZERO) THEN + IF (NOUNIT) X(J) = X(J)/A(J,J) + TEMP = X(J) + DO 10 I = J - 1,1,-1 + X(I) = X(I) - TEMP*A(I,J) + 10 CONTINUE + END IF + 20 CONTINUE + ELSE + JX = KX + (N-1)*INCX + DO 40 J = N,1,-1 + IF (X(JX).NE.ZERO) THEN + IF (NOUNIT) X(JX) = X(JX)/A(J,J) + TEMP = X(JX) + IX = JX + DO 30 I = J - 1,1,-1 + IX = IX - INCX + X(IX) = X(IX) - TEMP*A(I,J) + 30 CONTINUE + END IF + JX = JX - INCX + 40 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 60 J = 1,N + IF (X(J).NE.ZERO) THEN + IF (NOUNIT) X(J) = X(J)/A(J,J) + TEMP = X(J) + DO 50 I = J + 1,N + X(I) = X(I) - TEMP*A(I,J) + 50 CONTINUE + END IF + 60 CONTINUE + ELSE + JX = KX + DO 80 J = 1,N + IF (X(JX).NE.ZERO) THEN + IF (NOUNIT) X(JX) = X(JX)/A(J,J) + TEMP = X(JX) + IX = JX + DO 70 I = J + 1,N + IX = IX + INCX + X(IX) = X(IX) - TEMP*A(I,J) + 70 CONTINUE + END IF + JX = JX + INCX + 80 CONTINUE + END IF + END IF + ELSE +* +* Form x := inv( A**T )*x or x := inv( A**H )*x. +* + IF (LSAME(UPLO,'U')) THEN + IF (INCX.EQ.1) THEN + DO 110 J = 1,N + TEMP = X(J) + IF (NOCONJ) THEN + DO 90 I = 1,J - 1 + TEMP = TEMP - A(I,J)*X(I) + 90 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(J,J) + ELSE + DO 100 I = 1,J - 1 + TEMP = TEMP - DCONJG(A(I,J))*X(I) + 100 CONTINUE + IF (NOUNIT) TEMP = TEMP/DCONJG(A(J,J)) + END IF + X(J) = TEMP + 110 CONTINUE + ELSE + JX = KX + DO 140 J = 1,N + IX = KX + TEMP = X(JX) + IF (NOCONJ) THEN + DO 120 I = 1,J - 1 + TEMP = TEMP - A(I,J)*X(IX) + IX = IX + INCX + 120 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(J,J) + ELSE + DO 130 I = 1,J - 1 + TEMP = TEMP - DCONJG(A(I,J))*X(IX) + IX = IX + INCX + 130 CONTINUE + IF (NOUNIT) TEMP = TEMP/DCONJG(A(J,J)) + END IF + X(JX) = TEMP + JX = JX + INCX + 140 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 170 J = N,1,-1 + TEMP = X(J) + IF (NOCONJ) THEN + DO 150 I = N,J + 1,-1 + TEMP = TEMP - A(I,J)*X(I) + 150 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(J,J) + ELSE + DO 160 I = N,J + 1,-1 + TEMP = TEMP - DCONJG(A(I,J))*X(I) + 160 CONTINUE + IF (NOUNIT) TEMP = TEMP/DCONJG(A(J,J)) + END IF + X(J) = TEMP + 170 CONTINUE + ELSE + KX = KX + (N-1)*INCX + JX = KX + DO 200 J = N,1,-1 + IX = KX + TEMP = X(JX) + IF (NOCONJ) THEN + DO 180 I = N,J + 1,-1 + TEMP = TEMP - A(I,J)*X(IX) + IX = IX - INCX + 180 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(J,J) + ELSE + DO 190 I = N,J + 1,-1 + TEMP = TEMP - DCONJG(A(I,J))*X(IX) + IX = IX - INCX + 190 CONTINUE + IF (NOUNIT) TEMP = TEMP/DCONJG(A(J,J)) + END IF + X(JX) = TEMP + JX = JX - INCX + 200 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of ZTRSV +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/complex16/zgebak.f b/fortran_implementation/external_libraries/lapack_routines/complex16/zgebak.f new file mode 100644 index 0000000..f2553e7 --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/complex16/zgebak.f @@ -0,0 +1,190 @@ + SUBROUTINE ZGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, + $ INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER JOB, SIDE + INTEGER IHI, ILO, INFO, LDV, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION SCALE( * ) + COMPLEX*16 V( LDV, * ) +* .. +* +* Purpose +* ======= +* +* ZGEBAK forms the right or left eigenvectors of a complex general +* matrix by backward transformation on the computed eigenvectors of the +* balanced matrix output by ZGEBAL. +* +* Arguments +* ========= +* +* JOB (input) CHARACTER*1 +* Specifies the type of backward transformation required: +* = 'N', do nothing, return immediately; +* = 'P', do backward transformation for permutation only; +* = 'S', do backward transformation for scaling only; +* = 'B', do backward transformations for both permutation and +* scaling. +* JOB must be the same as the argument JOB supplied to ZGEBAL. +* +* SIDE (input) CHARACTER*1 +* = 'R': V contains right eigenvectors; +* = 'L': V contains left eigenvectors. +* +* N (input) INTEGER +* The number of rows of the matrix V. N >= 0. +* +* ILO (input) INTEGER +* IHI (input) INTEGER +* The integers ILO and IHI determined by ZGEBAL. +* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. +* +* SCALE (input) DOUBLE PRECISION array, dimension (N) +* Details of the permutation and scaling factors, as returned +* by ZGEBAL. +* +* M (input) INTEGER +* The number of columns of the matrix V. M >= 0. +* +* V (input/output) COMPLEX*16 array, dimension (LDV,M) +* On entry, the matrix of right or left eigenvectors to be +* transformed, as returned by ZHSEIN or ZTREVC. +* On exit, V is overwritten by the transformed eigenvectors. +* +* LDV (input) INTEGER +* The leading dimension of the array V. LDV >= max(1,N). +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LEFTV, RIGHTV + INTEGER I, II, K + DOUBLE PRECISION S +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZDSCAL, ZSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Decode and Test the input parameters +* + RIGHTV = LSAME( SIDE, 'R' ) + LEFTV = LSAME( SIDE, 'L' ) +* + INFO = 0 + IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. + $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN + INFO = -1 + ELSE IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -7 + ELSE IF( LDV.LT.MAX( 1, N ) ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGEBAK', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN + IF( M.EQ.0 ) + $ RETURN + IF( LSAME( JOB, 'N' ) ) + $ RETURN +* + IF( ILO.EQ.IHI ) + $ GO TO 30 +* +* Backward balance +* + IF( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) ) THEN +* + IF( RIGHTV ) THEN + DO 10 I = ILO, IHI + S = SCALE( I ) + CALL ZDSCAL( M, S, V( I, 1 ), LDV ) + 10 CONTINUE + END IF +* + IF( LEFTV ) THEN + DO 20 I = ILO, IHI + S = ONE / SCALE( I ) + CALL ZDSCAL( M, S, V( I, 1 ), LDV ) + 20 CONTINUE + END IF +* + END IF +* +* Backward permutation +* +* For I = ILO-1 step -1 until 1, +* IHI+1 step 1 until N do -- +* + 30 CONTINUE + IF( LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) ) THEN + IF( RIGHTV ) THEN + DO 40 II = 1, N + I = II + IF( I.GE.ILO .AND. I.LE.IHI ) + $ GO TO 40 + IF( I.LT.ILO ) + $ I = ILO - II + K = SCALE( I ) + IF( K.EQ.I ) + $ GO TO 40 + CALL ZSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) + 40 CONTINUE + END IF +* + IF( LEFTV ) THEN + DO 50 II = 1, N + I = II + IF( I.GE.ILO .AND. I.LE.IHI ) + $ GO TO 50 + IF( I.LT.ILO ) + $ I = ILO - II + K = SCALE( I ) + IF( K.EQ.I ) + $ GO TO 50 + CALL ZSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) + 50 CONTINUE + END IF + END IF +* + RETURN +* +* End of ZGEBAK +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/complex16/zgebal.f b/fortran_implementation/external_libraries/lapack_routines/complex16/zgebal.f new file mode 100644 index 0000000..137f228 --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/complex16/zgebal.f @@ -0,0 +1,339 @@ + SUBROUTINE ZGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) +* +* -- LAPACK routine (version 3.2.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2010 +* +* .. Scalar Arguments .. + CHARACTER JOB + INTEGER IHI, ILO, INFO, LDA, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION SCALE( * ) + COMPLEX*16 A( LDA, * ) +* .. +* +* Purpose +* ======= +* +* ZGEBAL balances a general complex matrix A. This involves, first, +* permuting A by a similarity transformation to isolate eigenvalues +* in the first 1 to ILO-1 and last IHI+1 to N elements on the +* diagonal; and second, applying a diagonal similarity transformation +* to rows and columns ILO to IHI to make the rows and columns as +* close in norm as possible. Both steps are optional. +* +* Balancing may reduce the 1-norm of the matrix, and improve the +* accuracy of the computed eigenvalues and/or eigenvectors. +* +* Arguments +* ========= +* +* JOB (input) CHARACTER*1 +* Specifies the operations to be performed on A: +* = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0 +* for i = 1,...,N; +* = 'P': permute only; +* = 'S': scale only; +* = 'B': both permute and scale. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* A (input/output) COMPLEX*16 array, dimension (LDA,N) +* On entry, the input matrix A. +* On exit, A is overwritten by the balanced matrix. +* If JOB = 'N', A is not referenced. +* See Further Details. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* ILO (output) INTEGER +* IHI (output) INTEGER +* ILO and IHI are set to integers such that on exit +* A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N. +* If JOB = 'N' or 'S', ILO = 1 and IHI = N. +* +* SCALE (output) DOUBLE PRECISION array, dimension (N) +* Details of the permutations and scaling factors applied to +* A. If P(j) is the index of the row and column interchanged +* with row and column j and D(j) is the scaling factor +* applied to row and column j, then +* SCALE(j) = P(j) for j = 1,...,ILO-1 +* = D(j) for j = ILO,...,IHI +* = P(j) for j = IHI+1,...,N. +* The order in which the interchanges are made is N to IHI+1, +* then 1 to ILO-1. +* +* INFO (output) INTEGER +* = 0: successful exit. +* < 0: if INFO = -i, the i-th argument had an illegal value. +* +* Further Details +* =============== +* +* The permutations consist of row and column interchanges which put +* the matrix in the form +* +* ( T1 X Y ) +* P A P = ( 0 B Z ) +* ( 0 0 T2 ) +* +* where T1 and T2 are upper triangular matrices whose eigenvalues lie +* along the diagonal. The column indices ILO and IHI mark the starting +* and ending columns of the submatrix B. Balancing consists of applying +* a diagonal similarity transformation inv(D) * B * D to make the +* 1-norms of each row of B and its corresponding column nearly equal. +* The output matrix is +* +* ( T1 X*D Y ) +* ( 0 inv(D)*B*D inv(D)*Z ). +* ( 0 0 T2 ) +* +* Information about the permutations P and the diagonal matrix D is +* returned in the vector SCALE. +* +* This subroutine is based on the EISPACK routine CBAL. +* +* Modified by Tzu-Yi Chen, Computer Science Division, University of +* California at Berkeley, USA +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION SCLFAC + PARAMETER ( SCLFAC = 2.0D+0 ) + DOUBLE PRECISION FACTOR + PARAMETER ( FACTOR = 0.95D+0 ) +* .. +* .. Local Scalars .. + LOGICAL NOCONV + INTEGER I, ICA, IEXC, IRA, J, K, L, M + DOUBLE PRECISION C, CA, F, G, R, RA, S, SFMAX1, SFMAX2, SFMIN1, + $ SFMIN2 + COMPLEX*16 CDUM +* .. +* .. External Functions .. + LOGICAL DISNAN, LSAME + INTEGER IZAMAX + DOUBLE PRECISION DLAMCH + EXTERNAL DISNAN, LSAME, IZAMAX, DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZDSCAL, ZSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DIMAG, MAX, MIN +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INFO = 0 + IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. + $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGEBAL', -INFO ) + RETURN + END IF +* + K = 1 + L = N +* + IF( N.EQ.0 ) + $ GO TO 210 +* + IF( LSAME( JOB, 'N' ) ) THEN + DO 10 I = 1, N + SCALE( I ) = ONE + 10 CONTINUE + GO TO 210 + END IF +* + IF( LSAME( JOB, 'S' ) ) + $ GO TO 120 +* +* Permutation to isolate eigenvalues if possible +* + GO TO 50 +* +* Row and column exchange. +* + 20 CONTINUE + SCALE( M ) = J + IF( J.EQ.M ) + $ GO TO 30 +* + CALL ZSWAP( L, A( 1, J ), 1, A( 1, M ), 1 ) + CALL ZSWAP( N-K+1, A( J, K ), LDA, A( M, K ), LDA ) +* + 30 CONTINUE + GO TO ( 40, 80 )IEXC +* +* Search for rows isolating an eigenvalue and push them down. +* + 40 CONTINUE + IF( L.EQ.1 ) + $ GO TO 210 + L = L - 1 +* + 50 CONTINUE + DO 70 J = L, 1, -1 +* + DO 60 I = 1, L + IF( I.EQ.J ) + $ GO TO 60 + IF( DBLE( A( J, I ) ).NE.ZERO .OR. DIMAG( A( J, I ) ).NE. + $ ZERO )GO TO 70 + 60 CONTINUE +* + M = L + IEXC = 1 + GO TO 20 + 70 CONTINUE +* + GO TO 90 +* +* Search for columns isolating an eigenvalue and push them left. +* + 80 CONTINUE + K = K + 1 +* + 90 CONTINUE + DO 110 J = K, L +* + DO 100 I = K, L + IF( I.EQ.J ) + $ GO TO 100 + IF( DBLE( A( I, J ) ).NE.ZERO .OR. DIMAG( A( I, J ) ).NE. + $ ZERO )GO TO 110 + 100 CONTINUE +* + M = K + IEXC = 2 + GO TO 20 + 110 CONTINUE +* + 120 CONTINUE + DO 130 I = K, L + SCALE( I ) = ONE + 130 CONTINUE +* + IF( LSAME( JOB, 'P' ) ) + $ GO TO 210 +* +* Balance the submatrix in rows K to L. +* +* Iterative loop for norm reduction +* + SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' ) + SFMAX1 = ONE / SFMIN1 + SFMIN2 = SFMIN1*SCLFAC + SFMAX2 = ONE / SFMIN2 + 140 CONTINUE + NOCONV = .FALSE. +* + DO 200 I = K, L + C = ZERO + R = ZERO +* + DO 150 J = K, L + IF( J.EQ.I ) + $ GO TO 150 + C = C + CABS1( A( J, I ) ) + R = R + CABS1( A( I, J ) ) + 150 CONTINUE + ICA = IZAMAX( L, A( 1, I ), 1 ) + CA = ABS( A( ICA, I ) ) + IRA = IZAMAX( N-K+1, A( I, K ), LDA ) + RA = ABS( A( I, IRA+K-1 ) ) +* +* Guard against zero C or R due to underflow. +* + IF( C.EQ.ZERO .OR. R.EQ.ZERO ) + $ GO TO 200 + G = R / SCLFAC + F = ONE + S = C + R + 160 CONTINUE + IF( C.GE.G .OR. MAX( F, C, CA ).GE.SFMAX2 .OR. + $ MIN( R, G, RA ).LE.SFMIN2 )GO TO 170 + IF( DISNAN( C+F+CA+R+G+RA ) ) THEN +* +* Exit if NaN to avoid infinite loop +* + INFO = -3 + CALL XERBLA( 'ZGEBAL', -INFO ) + RETURN + END IF + F = F*SCLFAC + C = C*SCLFAC + CA = CA*SCLFAC + R = R / SCLFAC + G = G / SCLFAC + RA = RA / SCLFAC + GO TO 160 +* + 170 CONTINUE + G = C / SCLFAC + 180 CONTINUE + IF( G.LT.R .OR. MAX( R, RA ).GE.SFMAX2 .OR. + $ MIN( F, C, G, CA ).LE.SFMIN2 )GO TO 190 + F = F / SCLFAC + C = C / SCLFAC + G = G / SCLFAC + CA = CA / SCLFAC + R = R*SCLFAC + RA = RA*SCLFAC + GO TO 180 +* +* Now balance. +* + 190 CONTINUE + IF( ( C+R ).GE.FACTOR*S ) + $ GO TO 200 + IF( F.LT.ONE .AND. SCALE( I ).LT.ONE ) THEN + IF( F*SCALE( I ).LE.SFMIN1 ) + $ GO TO 200 + END IF + IF( F.GT.ONE .AND. SCALE( I ).GT.ONE ) THEN + IF( SCALE( I ).GE.SFMAX1 / F ) + $ GO TO 200 + END IF + G = ONE / F + SCALE( I ) = SCALE( I )*F + NOCONV = .TRUE. +* + CALL ZDSCAL( N-K+1, G, A( I, K ), LDA ) + CALL ZDSCAL( L, F, A( 1, I ), 1 ) +* + 200 CONTINUE +* + IF( NOCONV ) + $ GO TO 140 +* + 210 CONTINUE + ILO = K + IHI = L +* + RETURN +* +* End of ZGEBAL +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/complex16/zgeev.f b/fortran_implementation/external_libraries/lapack_routines/complex16/zgeev.f new file mode 100644 index 0000000..3047e32 --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/complex16/zgeev.f @@ -0,0 +1,397 @@ + SUBROUTINE ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, + $ WORK, LWORK, RWORK, INFO ) +* +* -- LAPACK driver routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER JOBVL, JOBVR + INTEGER INFO, LDA, LDVL, LDVR, LWORK, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ), + $ W( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* ZGEEV computes for an N-by-N complex nonsymmetric matrix A, the +* eigenvalues and, optionally, the left and/or right eigenvectors. +* +* The right eigenvector v(j) of A satisfies +* A * v(j) = lambda(j) * v(j) +* where lambda(j) is its eigenvalue. +* The left eigenvector u(j) of A satisfies +* u(j)**H * A = lambda(j) * u(j)**H +* where u(j)**H denotes the conjugate transpose of u(j). +* +* The computed eigenvectors are normalized to have Euclidean norm +* equal to 1 and largest component real. +* +* Arguments +* ========= +* +* JOBVL (input) CHARACTER*1 +* = 'N': left eigenvectors of A are not computed; +* = 'V': left eigenvectors of are computed. +* +* JOBVR (input) CHARACTER*1 +* = 'N': right eigenvectors of A are not computed; +* = 'V': right eigenvectors of A are computed. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* A (input/output) COMPLEX*16 array, dimension (LDA,N) +* On entry, the N-by-N matrix A. +* On exit, A has been overwritten. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* W (output) COMPLEX*16 array, dimension (N) +* W contains the computed eigenvalues. +* +* VL (output) COMPLEX*16 array, dimension (LDVL,N) +* If JOBVL = 'V', the left eigenvectors u(j) are stored one +* after another in the columns of VL, in the same order +* as their eigenvalues. +* If JOBVL = 'N', VL is not referenced. +* u(j) = VL(:,j), the j-th column of VL. +* +* LDVL (input) INTEGER +* The leading dimension of the array VL. LDVL >= 1; if +* JOBVL = 'V', LDVL >= N. +* +* VR (output) COMPLEX*16 array, dimension (LDVR,N) +* If JOBVR = 'V', the right eigenvectors v(j) are stored one +* after another in the columns of VR, in the same order +* as their eigenvalues. +* If JOBVR = 'N', VR is not referenced. +* v(j) = VR(:,j), the j-th column of VR. +* +* LDVR (input) INTEGER +* The leading dimension of the array VR. LDVR >= 1; if +* JOBVR = 'V', LDVR >= N. +* +* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) +* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +* +* LWORK (input) INTEGER +* The dimension of the array WORK. LWORK >= max(1,2*N). +* For good performance, LWORK must generally be larger. +* +* If LWORK = -1, then a workspace query is assumed; the routine +* only calculates the optimal size of the WORK array, returns +* this value as the first entry of the WORK array, and no error +* message related to LWORK is issued by XERBLA. +* +* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N) +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value. +* > 0: if INFO = i, the QR algorithm failed to compute all the +* eigenvalues, and no eigenvectors have been computed; +* elements and i+1:N of W contain eigenvalues which have +* converged. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, SCALEA, WANTVL, WANTVR + CHARACTER SIDE + INTEGER HSWORK, I, IBAL, IERR, IHI, ILO, IRWORK, ITAU, + $ IWRK, K, MAXWRK, MINWRK, NOUT + DOUBLE PRECISION ANRM, BIGNUM, CSCALE, EPS, SCL, SMLNUM + COMPLEX*16 TMP +* .. +* .. Local Arrays .. + LOGICAL SELECT( 1 ) + DOUBLE PRECISION DUM( 1 ) +* .. +* .. External Subroutines .. + EXTERNAL DLABAD, XERBLA, ZDSCAL, ZGEBAK, ZGEBAL, ZGEHRD, + $ ZHSEQR, ZLACPY, ZLASCL, ZSCAL, ZTREVC, ZUNGHR +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX, ILAENV + DOUBLE PRECISION DLAMCH, DZNRM2, ZLANGE + EXTERNAL LSAME, IDAMAX, ILAENV, DLAMCH, DZNRM2, ZLANGE +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, DCMPLX, DCONJG, DIMAG, MAX, SQRT +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + WANTVL = LSAME( JOBVL, 'V' ) + WANTVR = LSAME( JOBVR, 'V' ) + IF( ( .NOT.WANTVL ) .AND. ( .NOT.LSAME( JOBVL, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( ( .NOT.WANTVR ) .AND. ( .NOT.LSAME( JOBVR, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDVL.LT.1 .OR. ( WANTVL .AND. LDVL.LT.N ) ) THEN + INFO = -8 + ELSE IF( LDVR.LT.1 .OR. ( WANTVR .AND. LDVR.LT.N ) ) THEN + INFO = -10 + END IF +* +* Compute workspace +* (Note: Comments in the code beginning "Workspace:" describe the +* minimal amount of workspace needed at that point in the code, +* as well as the preferred amount for good performance. +* CWorkspace refers to complex workspace, and RWorkspace to real +* workspace. NB refers to the optimal block size for the +* immediately following subroutine, as returned by ILAENV. +* HSWORK refers to the workspace preferred by ZHSEQR, as +* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, +* the worst case.) +* + IF( INFO.EQ.0 ) THEN + IF( N.EQ.0 ) THEN + MINWRK = 1 + MAXWRK = 1 + ELSE + MAXWRK = N + N*ILAENV( 1, 'ZGEHRD', ' ', N, 1, N, 0 ) + MINWRK = 2*N + IF( WANTVL ) THEN + MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'ZUNGHR', + $ ' ', N, 1, N, -1 ) ) + CALL ZHSEQR( 'S', 'V', N, 1, N, A, LDA, W, VL, LDVL, + $ WORK, -1, INFO ) + ELSE IF( WANTVR ) THEN + MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'ZUNGHR', + $ ' ', N, 1, N, -1 ) ) + CALL ZHSEQR( 'S', 'V', N, 1, N, A, LDA, W, VR, LDVR, + $ WORK, -1, INFO ) + ELSE + CALL ZHSEQR( 'E', 'N', N, 1, N, A, LDA, W, VR, LDVR, + $ WORK, -1, INFO ) + END IF + HSWORK = WORK( 1 ) + MAXWRK = MAX( MAXWRK, HSWORK, MINWRK ) + END IF + WORK( 1 ) = MAXWRK +* + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN + INFO = -12 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGEEV ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Get machine constants +* + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) + SMLNUM = SQRT( SMLNUM ) / EPS + BIGNUM = ONE / SMLNUM +* +* Scale A if max element outside range [SMLNUM,BIGNUM] +* + ANRM = ZLANGE( 'M', N, N, A, LDA, DUM ) + SCALEA = .FALSE. + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN + SCALEA = .TRUE. + CSCALE = SMLNUM + ELSE IF( ANRM.GT.BIGNUM ) THEN + SCALEA = .TRUE. + CSCALE = BIGNUM + END IF + IF( SCALEA ) + $ CALL ZLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR ) +* +* Balance the matrix +* (CWorkspace: none) +* (RWorkspace: need N) +* + IBAL = 1 + CALL ZGEBAL( 'B', N, A, LDA, ILO, IHI, RWORK( IBAL ), IERR ) +* +* Reduce to upper Hessenberg form +* (CWorkspace: need 2*N, prefer N+N*NB) +* (RWorkspace: none) +* + ITAU = 1 + IWRK = ITAU + N + CALL ZGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ), + $ LWORK-IWRK+1, IERR ) +* + IF( WANTVL ) THEN +* +* Want left eigenvectors +* Copy Householder vectors to VL +* + SIDE = 'L' + CALL ZLACPY( 'L', N, N, A, LDA, VL, LDVL ) +* +* Generate unitary matrix in VL +* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) +* (RWorkspace: none) +* + CALL ZUNGHR( N, ILO, IHI, VL, LDVL, WORK( ITAU ), WORK( IWRK ), + $ LWORK-IWRK+1, IERR ) +* +* Perform QR iteration, accumulating Schur vectors in VL +* (CWorkspace: need 1, prefer HSWORK (see comments) ) +* (RWorkspace: none) +* + IWRK = ITAU + CALL ZHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, W, VL, LDVL, + $ WORK( IWRK ), LWORK-IWRK+1, INFO ) +* + IF( WANTVR ) THEN +* +* Want left and right eigenvectors +* Copy Schur vectors to VR +* + SIDE = 'B' + CALL ZLACPY( 'F', N, N, VL, LDVL, VR, LDVR ) + END IF +* + ELSE IF( WANTVR ) THEN +* +* Want right eigenvectors +* Copy Householder vectors to VR +* + SIDE = 'R' + CALL ZLACPY( 'L', N, N, A, LDA, VR, LDVR ) +* +* Generate unitary matrix in VR +* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) +* (RWorkspace: none) +* + CALL ZUNGHR( N, ILO, IHI, VR, LDVR, WORK( ITAU ), WORK( IWRK ), + $ LWORK-IWRK+1, IERR ) +* +* Perform QR iteration, accumulating Schur vectors in VR +* (CWorkspace: need 1, prefer HSWORK (see comments) ) +* (RWorkspace: none) +* + IWRK = ITAU + CALL ZHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, W, VR, LDVR, + $ WORK( IWRK ), LWORK-IWRK+1, INFO ) +* + ELSE +* +* Compute eigenvalues only +* (CWorkspace: need 1, prefer HSWORK (see comments) ) +* (RWorkspace: none) +* + IWRK = ITAU + CALL ZHSEQR( 'E', 'N', N, ILO, IHI, A, LDA, W, VR, LDVR, + $ WORK( IWRK ), LWORK-IWRK+1, INFO ) + END IF +* +* If INFO > 0 from ZHSEQR, then quit +* + IF( INFO.GT.0 ) + $ GO TO 50 +* + IF( WANTVL .OR. WANTVR ) THEN +* +* Compute left and/or right eigenvectors +* (CWorkspace: need 2*N) +* (RWorkspace: need 2*N) +* + IRWORK = IBAL + N + CALL ZTREVC( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR, + $ N, NOUT, WORK( IWRK ), RWORK( IRWORK ), IERR ) + END IF +* + IF( WANTVL ) THEN +* +* Undo balancing of left eigenvectors +* (CWorkspace: none) +* (RWorkspace: need N) +* + CALL ZGEBAK( 'B', 'L', N, ILO, IHI, RWORK( IBAL ), N, VL, LDVL, + $ IERR ) +* +* Normalize left eigenvectors and make largest component real +* + DO 20 I = 1, N + SCL = ONE / DZNRM2( N, VL( 1, I ), 1 ) + CALL ZDSCAL( N, SCL, VL( 1, I ), 1 ) + DO 10 K = 1, N + RWORK( IRWORK+K-1 ) = DBLE( VL( K, I ) )**2 + + $ DIMAG( VL( K, I ) )**2 + 10 CONTINUE + K = IDAMAX( N, RWORK( IRWORK ), 1 ) + TMP = DCONJG( VL( K, I ) ) / SQRT( RWORK( IRWORK+K-1 ) ) + CALL ZSCAL( N, TMP, VL( 1, I ), 1 ) + VL( K, I ) = DCMPLX( DBLE( VL( K, I ) ), ZERO ) + 20 CONTINUE + END IF +* + IF( WANTVR ) THEN +* +* Undo balancing of right eigenvectors +* (CWorkspace: none) +* (RWorkspace: need N) +* + CALL ZGEBAK( 'B', 'R', N, ILO, IHI, RWORK( IBAL ), N, VR, LDVR, + $ IERR ) +* +* Normalize right eigenvectors and make largest component real +* + DO 40 I = 1, N + SCL = ONE / DZNRM2( N, VR( 1, I ), 1 ) + CALL ZDSCAL( N, SCL, VR( 1, I ), 1 ) + DO 30 K = 1, N + RWORK( IRWORK+K-1 ) = DBLE( VR( K, I ) )**2 + + $ DIMAG( VR( K, I ) )**2 + 30 CONTINUE + K = IDAMAX( N, RWORK( IRWORK ), 1 ) + TMP = DCONJG( VR( K, I ) ) / SQRT( RWORK( IRWORK+K-1 ) ) + CALL ZSCAL( N, TMP, VR( 1, I ), 1 ) + VR( K, I ) = DCMPLX( DBLE( VR( K, I ) ), ZERO ) + 40 CONTINUE + END IF +* +* Undo scaling if necessary +* + 50 CONTINUE + IF( SCALEA ) THEN + CALL ZLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, W( INFO+1 ), + $ MAX( N-INFO, 1 ), IERR ) + IF( INFO.GT.0 ) THEN + CALL ZLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, W, N, IERR ) + END IF + END IF +* + WORK( 1 ) = MAXWRK + RETURN +* +* End of ZGEEV +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/complex16/zgehd2.f b/fortran_implementation/external_libraries/lapack_routines/complex16/zgehd2.f new file mode 100644 index 0000000..0c67e65 --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/complex16/zgehd2.f @@ -0,0 +1,149 @@ + SUBROUTINE ZGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) +* +* -- LAPACK routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + INTEGER IHI, ILO, INFO, LDA, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* ZGEHD2 reduces a complex general matrix A to upper Hessenberg form H +* by a unitary similarity transformation: Q**H * A * Q = H . +* +* Arguments +* ========= +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* ILO (input) INTEGER +* IHI (input) INTEGER +* It is assumed that A is already upper triangular in rows +* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally +* set by a previous call to ZGEBAL; otherwise they should be +* set to 1 and N respectively. See Further Details. +* 1 <= ILO <= IHI <= max(1,N). +* +* A (input/output) COMPLEX*16 array, dimension (LDA,N) +* On entry, the n by n general matrix to be reduced. +* On exit, the upper triangle and the first subdiagonal of A +* are overwritten with the upper Hessenberg matrix H, and the +* elements below the first subdiagonal, with the array TAU, +* represent the unitary matrix Q as a product of elementary +* reflectors. See Further Details. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* TAU (output) COMPLEX*16 array, dimension (N-1) +* The scalar factors of the elementary reflectors (see Further +* Details). +* +* WORK (workspace) COMPLEX*16 array, dimension (N) +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value. +* +* Further Details +* =============== +* +* The matrix Q is represented as a product of (ihi-ilo) elementary +* reflectors +* +* Q = H(ilo) H(ilo+1) . . . H(ihi-1). +* +* Each H(i) has the form +* +* H(i) = I - tau * v * v**H +* +* where tau is a complex scalar, and v is a complex vector with +* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on +* exit in A(i+2:ihi,i), and tau in TAU(i). +* +* The contents of A are illustrated by the following example, with +* n = 7, ilo = 2 and ihi = 6: +* +* on entry, on exit, +* +* ( a a a a a a a ) ( a a h h h h a ) +* ( a a a a a a ) ( a h h h h a ) +* ( a a a a a a ) ( h h h h h h ) +* ( a a a a a a ) ( v2 h h h h h ) +* ( a a a a a a ) ( v2 v3 h h h h ) +* ( a a a a a a ) ( v2 v3 v4 h h h ) +* ( a ) ( a ) +* +* where a denotes an element of the original matrix A, h denotes a +* modified element of the upper Hessenberg matrix H, and vi denotes an +* element of the vector defining H(i). +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I + COMPLEX*16 ALPHA +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLARF, ZLARFG +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN + INFO = -2 + ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGEHD2', -INFO ) + RETURN + END IF +* + DO 10 I = ILO, IHI - 1 +* +* Compute elementary reflector H(i) to annihilate A(i+2:ihi,i) +* + ALPHA = A( I+1, I ) + CALL ZLARFG( IHI-I, ALPHA, A( MIN( I+2, N ), I ), 1, TAU( I ) ) + A( I+1, I ) = ONE +* +* Apply H(i) to A(1:ihi,i+1:ihi) from the right +* + CALL ZLARF( 'Right', IHI, IHI-I, A( I+1, I ), 1, TAU( I ), + $ A( 1, I+1 ), LDA, WORK ) +* +* Apply H(i)**H to A(i+1:ihi,i+1:n) from the left +* + CALL ZLARF( 'Left', IHI-I, N-I, A( I+1, I ), 1, + $ DCONJG( TAU( I ) ), A( I+1, I+1 ), LDA, WORK ) +* + A( I+1, I ) = ALPHA + 10 CONTINUE +* + RETURN +* +* End of ZGEHD2 +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/complex16/zgehrd.f b/fortran_implementation/external_libraries/lapack_routines/complex16/zgehrd.f new file mode 100644 index 0000000..dd329a3 --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/complex16/zgehrd.f @@ -0,0 +1,274 @@ + SUBROUTINE ZGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* -- April 2009 -- +* +* .. Scalar Arguments .. + INTEGER IHI, ILO, INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* ZGEHRD reduces a complex general matrix A to upper Hessenberg form H by +* an unitary similarity transformation: Q**H * A * Q = H . +* +* Arguments +* ========= +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* ILO (input) INTEGER +* IHI (input) INTEGER +* It is assumed that A is already upper triangular in rows +* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally +* set by a previous call to ZGEBAL; otherwise they should be +* set to 1 and N respectively. See Further Details. +* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. +* +* A (input/output) COMPLEX*16 array, dimension (LDA,N) +* On entry, the N-by-N general matrix to be reduced. +* On exit, the upper triangle and the first subdiagonal of A +* are overwritten with the upper Hessenberg matrix H, and the +* elements below the first subdiagonal, with the array TAU, +* represent the unitary matrix Q as a product of elementary +* reflectors. See Further Details. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* TAU (output) COMPLEX*16 array, dimension (N-1) +* The scalar factors of the elementary reflectors (see Further +* Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to +* zero. +* +* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) +* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +* +* LWORK (input) INTEGER +* The length of the array WORK. LWORK >= max(1,N). +* For optimum performance LWORK >= N*NB, where NB is the +* optimal blocksize. +* +* If LWORK = -1, then a workspace query is assumed; the routine +* only calculates the optimal size of the WORK array, returns +* this value as the first entry of the WORK array, and no error +* message related to LWORK is issued by XERBLA. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value. +* +* Further Details +* =============== +* +* The matrix Q is represented as a product of (ihi-ilo) elementary +* reflectors +* +* Q = H(ilo) H(ilo+1) . . . H(ihi-1). +* +* Each H(i) has the form +* +* H(i) = I - tau * v * v**H +* +* where tau is a complex scalar, and v is a complex vector with +* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on +* exit in A(i+2:ihi,i), and tau in TAU(i). +* +* The contents of A are illustrated by the following example, with +* n = 7, ilo = 2 and ihi = 6: +* +* on entry, on exit, +* +* ( a a a a a a a ) ( a a h h h h a ) +* ( a a a a a a ) ( a h h h h a ) +* ( a a a a a a ) ( h h h h h h ) +* ( a a a a a a ) ( v2 h h h h h ) +* ( a a a a a a ) ( v2 v3 h h h h ) +* ( a a a a a a ) ( v2 v3 v4 h h h ) +* ( a ) ( a ) +* +* where a denotes an element of the original matrix A, h denotes a +* modified element of the upper Hessenberg matrix H, and vi denotes an +* element of the vector defining H(i). +* +* This file is a slight modification of LAPACK-3.0's DGEHRD +* subroutine incorporating improvements proposed by Quintana-Orti and +* Van de Geijn (2006). (See DLAHR2.) +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NBMAX, LDT + PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), + $ ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, IB, IINFO, IWS, J, LDWORK, LWKOPT, NB, + $ NBMIN, NH, NX + COMPLEX*16 EI +* .. +* .. Local Arrays .. + COMPLEX*16 T( LDT, NBMAX ) +* .. +* .. External Subroutines .. + EXTERNAL ZAXPY, ZGEHD2, ZGEMM, ZLAHR2, ZLARFB, ZTRMM, + $ XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INFO = 0 + NB = MIN( NBMAX, ILAENV( 1, 'ZGEHRD', ' ', N, ILO, IHI, -1 ) ) + LWKOPT = N*NB + WORK( 1 ) = LWKOPT + LQUERY = ( LWORK.EQ.-1 ) + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN + INFO = -2 + ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGEHRD', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Set elements 1:ILO-1 and IHI:N-1 of TAU to zero +* + DO 10 I = 1, ILO - 1 + TAU( I ) = ZERO + 10 CONTINUE + DO 20 I = MAX( 1, IHI ), N - 1 + TAU( I ) = ZERO + 20 CONTINUE +* +* Quick return if possible +* + NH = IHI - ILO + 1 + IF( NH.LE.1 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* +* Determine the block size +* + NB = MIN( NBMAX, ILAENV( 1, 'ZGEHRD', ' ', N, ILO, IHI, -1 ) ) + NBMIN = 2 + IWS = 1 + IF( NB.GT.1 .AND. NB.LT.NH ) THEN +* +* Determine when to cross over from blocked to unblocked code +* (last block is always handled by unblocked code) +* + NX = MAX( NB, ILAENV( 3, 'ZGEHRD', ' ', N, ILO, IHI, -1 ) ) + IF( NX.LT.NH ) THEN +* +* Determine if workspace is large enough for blocked code +* + IWS = N*NB + IF( LWORK.LT.IWS ) THEN +* +* Not enough workspace to use optimal NB: determine the +* minimum value of NB, and reduce NB or force use of +* unblocked code +* + NBMIN = MAX( 2, ILAENV( 2, 'ZGEHRD', ' ', N, ILO, IHI, + $ -1 ) ) + IF( LWORK.GE.N*NBMIN ) THEN + NB = LWORK / N + ELSE + NB = 1 + END IF + END IF + END IF + END IF + LDWORK = N +* + IF( NB.LT.NBMIN .OR. NB.GE.NH ) THEN +* +* Use unblocked code below +* + I = ILO +* + ELSE +* +* Use blocked code +* + DO 40 I = ILO, IHI - 1 - NX, NB + IB = MIN( NB, IHI-I ) +* +* Reduce columns i:i+ib-1 to Hessenberg form, returning the +* matrices V and T of the block reflector H = I - V*T*V**H +* which performs the reduction, and also the matrix Y = A*V*T +* + CALL ZLAHR2( IHI, I, IB, A( 1, I ), LDA, TAU( I ), T, LDT, + $ WORK, LDWORK ) +* +* Apply the block reflector H to A(1:ihi,i+ib:ihi) from the +* right, computing A := A - Y * V**H. V(i+ib,ib-1) must be set +* to 1 +* + EI = A( I+IB, I+IB-1 ) + A( I+IB, I+IB-1 ) = ONE + CALL ZGEMM( 'No transpose', 'Conjugate transpose', + $ IHI, IHI-I-IB+1, + $ IB, -ONE, WORK, LDWORK, A( I+IB, I ), LDA, ONE, + $ A( 1, I+IB ), LDA ) + A( I+IB, I+IB-1 ) = EI +* +* Apply the block reflector H to A(1:i,i+1:i+ib-1) from the +* right +* + CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', + $ 'Unit', I, IB-1, + $ ONE, A( I+1, I ), LDA, WORK, LDWORK ) + DO 30 J = 0, IB-2 + CALL ZAXPY( I, -ONE, WORK( LDWORK*J+1 ), 1, + $ A( 1, I+J+1 ), 1 ) + 30 CONTINUE +* +* Apply the block reflector H to A(i+1:ihi,i+ib:n) from the +* left +* + CALL ZLARFB( 'Left', 'Conjugate transpose', 'Forward', + $ 'Columnwise', + $ IHI-I, N-I-IB+1, IB, A( I+1, I ), LDA, T, LDT, + $ A( I+1, I+IB ), LDA, WORK, LDWORK ) + 40 CONTINUE + END IF +* +* Use unblocked code to reduce the rest of the matrix +* + CALL ZGEHD2( N, I, IHI, A, LDA, TAU, WORK, IINFO ) + WORK( 1 ) = IWS +* + RETURN +* +* End of ZGEHRD +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/complex16/zhseqr.f b/fortran_implementation/external_libraries/lapack_routines/complex16/zhseqr.f new file mode 100644 index 0000000..d3aae7a --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/complex16/zhseqr.f @@ -0,0 +1,400 @@ + SUBROUTINE ZHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ, + $ WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.2.2) -- +* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. +* June 2010 +* +* .. Scalar Arguments .. + INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N + CHARACTER COMPZ, JOB +* .. +* .. Array Arguments .. + COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* Purpose +* ======= +* +* ZHSEQR computes the eigenvalues of a Hessenberg matrix H +* and, optionally, the matrices T and Z from the Schur decomposition +* H = Z T Z**H, where T is an upper triangular matrix (the +* Schur form), and Z is the unitary matrix of Schur vectors. +* +* Optionally Z may be postmultiplied into an input unitary +* matrix Q so that this routine can give the Schur factorization +* of a matrix A which has been reduced to the Hessenberg form H +* by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H. +* +* Arguments +* ========= +* +* JOB (input) CHARACTER*1 +* = 'E': compute eigenvalues only; +* = 'S': compute eigenvalues and the Schur form T. +* +* COMPZ (input) CHARACTER*1 +* = 'N': no Schur vectors are computed; +* = 'I': Z is initialized to the unit matrix and the matrix Z +* of Schur vectors of H is returned; +* = 'V': Z must contain an unitary matrix Q on entry, and +* the product Q*Z is returned. +* +* N (input) INTEGER +* The order of the matrix H. N .GE. 0. +* +* ILO (input) INTEGER +* IHI (input) INTEGER +* It is assumed that H is already upper triangular in rows +* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally +* set by a previous call to ZGEBAL, and then passed to ZGEHRD +* when the matrix output by ZGEBAL is reduced to Hessenberg +* form. Otherwise ILO and IHI should be set to 1 and N +* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. +* If N = 0, then ILO = 1 and IHI = 0. +* +* H (input/output) COMPLEX*16 array, dimension (LDH,N) +* On entry, the upper Hessenberg matrix H. +* On exit, if INFO = 0 and JOB = 'S', H contains the upper +* triangular matrix T from the Schur decomposition (the +* Schur form). If INFO = 0 and JOB = 'E', the contents of +* H are unspecified on exit. (The output value of H when +* INFO.GT.0 is given under the description of INFO below.) +* +* Unlike earlier versions of ZHSEQR, this subroutine may +* explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1 +* or j = IHI+1, IHI+2, ... N. +* +* LDH (input) INTEGER +* The leading dimension of the array H. LDH .GE. max(1,N). +* +* W (output) COMPLEX*16 array, dimension (N) +* The computed eigenvalues. If JOB = 'S', the eigenvalues are +* stored in the same order as on the diagonal of the Schur +* form returned in H, with W(i) = H(i,i). +* +* Z (input/output) COMPLEX*16 array, dimension (LDZ,N) +* If COMPZ = 'N', Z is not referenced. +* If COMPZ = 'I', on entry Z need not be set and on exit, +* if INFO = 0, Z contains the unitary matrix Z of the Schur +* vectors of H. If COMPZ = 'V', on entry Z must contain an +* N-by-N matrix Q, which is assumed to be equal to the unit +* matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit, +* if INFO = 0, Z contains Q*Z. +* Normally Q is the unitary matrix generated by ZUNGHR +* after the call to ZGEHRD which formed the Hessenberg matrix +* H. (The output value of Z when INFO.GT.0 is given under +* the description of INFO below.) +* +* LDZ (input) INTEGER +* The leading dimension of the array Z. if COMPZ = 'I' or +* COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1. +* +* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) +* On exit, if INFO = 0, WORK(1) returns an estimate of +* the optimal value for LWORK. +* +* LWORK (input) INTEGER +* The dimension of the array WORK. LWORK .GE. max(1,N) +* is sufficient and delivers very good and sometimes +* optimal performance. However, LWORK as large as 11*N +* may be required for optimal performance. A workspace +* query is recommended to determine the optimal workspace +* size. +* +* If LWORK = -1, then ZHSEQR does a workspace query. +* In this case, ZHSEQR checks the input parameters and +* estimates the optimal workspace size for the given +* values of N, ILO and IHI. The estimate is returned +* in WORK(1). No error message related to LWORK is +* issued by XERBLA. Neither H nor Z are accessed. +* +* +* INFO (output) INTEGER +* = 0: successful exit +* .LT. 0: if INFO = -i, the i-th argument had an illegal +* value +* .GT. 0: if INFO = i, ZHSEQR failed to compute all of +* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR +* and WI contain those eigenvalues which have been +* successfully computed. (Failures are rare.) +* +* If INFO .GT. 0 and JOB = 'E', then on exit, the +* remaining unconverged eigenvalues are the eigen- +* values of the upper Hessenberg matrix rows and +* columns ILO through INFO of the final, output +* value of H. +* +* If INFO .GT. 0 and JOB = 'S', then on exit +* +* (*) (initial value of H)*U = U*(final value of H) +* +* where U is a unitary matrix. The final +* value of H is upper Hessenberg and triangular in +* rows and columns INFO+1 through IHI. +* +* If INFO .GT. 0 and COMPZ = 'V', then on exit +* +* (final value of Z) = (initial value of Z)*U +* +* where U is the unitary matrix in (*) (regard- +* less of the value of JOB.) +* +* If INFO .GT. 0 and COMPZ = 'I', then on exit +* (final value of Z) = U +* where U is the unitary matrix in (*) (regard- +* less of the value of JOB.) +* +* If INFO .GT. 0 and COMPZ = 'N', then Z is not +* accessed. +* +* ================================================================ +* Default values supplied by +* ILAENV(ISPEC,'ZHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK). +* It is suggested that these defaults be adjusted in order +* to attain best performance in each particular +* computational environment. +* +* ISPEC=12: The ZLAHQR vs ZLAQR0 crossover point. +* Default: 75. (Must be at least 11.) +* +* ISPEC=13: Recommended deflation window size. +* This depends on ILO, IHI and NS. NS is the +* number of simultaneous shifts returned +* by ILAENV(ISPEC=15). (See ISPEC=15 below.) +* The default for (IHI-ILO+1).LE.500 is NS. +* The default for (IHI-ILO+1).GT.500 is 3*NS/2. +* +* ISPEC=14: Nibble crossover point. (See IPARMQ for +* details.) Default: 14% of deflation window +* size. +* +* ISPEC=15: Number of simultaneous shifts in a multishift +* QR iteration. +* +* If IHI-ILO+1 is ... +* +* greater than ...but less ... the +* or equal to ... than default is +* +* 1 30 NS = 2(+) +* 30 60 NS = 4(+) +* 60 150 NS = 10(+) +* 150 590 NS = ** +* 590 3000 NS = 64 +* 3000 6000 NS = 128 +* 6000 infinity NS = 256 +* +* (+) By default some or all matrices of this order +* are passed to the implicit double shift routine +* ZLAHQR and this parameter is ignored. See +* ISPEC=12 above and comments in IPARMQ for +* details. +* +* (**) The asterisks (**) indicate an ad-hoc +* function of N increasing from 10 to 64. +* +* ISPEC=16: Select structured matrix multiply. +* If the number of simultaneous shifts (specified +* by ISPEC=15) is less than 14, then the default +* for ISPEC=16 is 0. Otherwise the default for +* ISPEC=16 is 2. +* +* ================================================================ +* Based on contributions by +* Karen Braman and Ralph Byers, Department of Mathematics, +* University of Kansas, USA +* +* ================================================================ +* References: +* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR +* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 +* Performance, SIAM Journal of Matrix Analysis, volume 23, pages +* 929--947, 2002. +* +* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR +* Algorithm Part II: Aggressive Early Deflation, SIAM Journal +* of Matrix Analysis, volume 23, pages 948--973, 2002. +* +* ================================================================ +* .. Parameters .. +* +* ==== Matrices of order NTINY or smaller must be processed by +* . ZLAHQR because of insufficient subdiagonal scratch space. +* . (This is a hard limit.) ==== + INTEGER NTINY + PARAMETER ( NTINY = 11 ) +* +* ==== NL allocates some local workspace to help small matrices +* . through a rare ZLAHQR failure. NL .GT. NTINY = 11 is +* . required and NL .LE. NMIN = ILAENV(ISPEC=12,...) is recom- +* . mended. (The default value of NMIN is 75.) Using NL = 49 +* . allows up to six simultaneous shifts and a 16-by-16 +* . deflation window. ==== + INTEGER NL + PARAMETER ( NL = 49 ) + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), + $ ONE = ( 1.0d0, 0.0d0 ) ) + DOUBLE PRECISION RZERO + PARAMETER ( RZERO = 0.0d0 ) +* .. +* .. Local Arrays .. + COMPLEX*16 HL( NL, NL ), WORKL( NL ) +* .. +* .. Local Scalars .. + INTEGER KBOT, NMIN + LOGICAL INITZ, LQUERY, WANTT, WANTZ +* .. +* .. External Functions .. + INTEGER ILAENV + LOGICAL LSAME + EXTERNAL ILAENV, LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZCOPY, ZLACPY, ZLAHQR, ZLAQR0, ZLASET +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, DCMPLX, MAX, MIN +* .. +* .. Executable Statements .. +* +* ==== Decode and check the input parameters. ==== +* + WANTT = LSAME( JOB, 'S' ) + INITZ = LSAME( COMPZ, 'I' ) + WANTZ = INITZ .OR. LSAME( COMPZ, 'V' ) + WORK( 1 ) = DCMPLX( DBLE( MAX( 1, N ) ), RZERO ) + LQUERY = LWORK.EQ.-1 +* + INFO = 0 + IF( .NOT.LSAME( JOB, 'E' ) .AND. .NOT.WANTT ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME( COMPZ, 'N' ) .AND. .NOT.WANTZ ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN + INFO = -5 + ELSE IF( LDH.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.MAX( 1, N ) ) ) THEN + INFO = -10 + ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN + INFO = -12 + END IF +* + IF( INFO.NE.0 ) THEN +* +* ==== Quick return in case of invalid argument. ==== +* + CALL XERBLA( 'ZHSEQR', -INFO ) + RETURN +* + ELSE IF( N.EQ.0 ) THEN +* +* ==== Quick return in case N = 0; nothing to do. ==== +* + RETURN +* + ELSE IF( LQUERY ) THEN +* +* ==== Quick return in case of a workspace query ==== +* + CALL ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI, Z, + $ LDZ, WORK, LWORK, INFO ) +* ==== Ensure reported workspace size is backward-compatible with +* . previous LAPACK versions. ==== + WORK( 1 ) = DCMPLX( MAX( DBLE( WORK( 1 ) ), DBLE( MAX( 1, + $ N ) ) ), RZERO ) + RETURN +* + ELSE +* +* ==== copy eigenvalues isolated by ZGEBAL ==== +* + IF( ILO.GT.1 ) + $ CALL ZCOPY( ILO-1, H, LDH+1, W, 1 ) + IF( IHI.LT.N ) + $ CALL ZCOPY( N-IHI, H( IHI+1, IHI+1 ), LDH+1, W( IHI+1 ), 1 ) +* +* ==== Initialize Z, if requested ==== +* + IF( INITZ ) + $ CALL ZLASET( 'A', N, N, ZERO, ONE, Z, LDZ ) +* +* ==== Quick return if possible ==== +* + IF( ILO.EQ.IHI ) THEN + W( ILO ) = H( ILO, ILO ) + RETURN + END IF +* +* ==== ZLAHQR/ZLAQR0 crossover point ==== +* + NMIN = ILAENV( 12, 'ZHSEQR', JOB( : 1 ) // COMPZ( : 1 ), N, + $ ILO, IHI, LWORK ) + NMIN = MAX( NTINY, NMIN ) +* +* ==== ZLAQR0 for big matrices; ZLAHQR for small ones ==== +* + IF( N.GT.NMIN ) THEN + CALL ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI, + $ Z, LDZ, WORK, LWORK, INFO ) + ELSE +* +* ==== Small matrix ==== +* + CALL ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI, + $ Z, LDZ, INFO ) +* + IF( INFO.GT.0 ) THEN +* +* ==== A rare ZLAHQR failure! ZLAQR0 sometimes succeeds +* . when ZLAHQR fails. ==== +* + KBOT = INFO +* + IF( N.GE.NL ) THEN +* +* ==== Larger matrices have enough subdiagonal scratch +* . space to call ZLAQR0 directly. ==== +* + CALL ZLAQR0( WANTT, WANTZ, N, ILO, KBOT, H, LDH, W, + $ ILO, IHI, Z, LDZ, WORK, LWORK, INFO ) +* + ELSE +* +* ==== Tiny matrices don't have enough subdiagonal +* . scratch space to benefit from ZLAQR0. Hence, +* . tiny matrices must be copied into a larger +* . array before calling ZLAQR0. ==== +* + CALL ZLACPY( 'A', N, N, H, LDH, HL, NL ) + HL( N+1, N ) = ZERO + CALL ZLASET( 'A', NL, NL-N, ZERO, ZERO, HL( 1, N+1 ), + $ NL ) + CALL ZLAQR0( WANTT, WANTZ, NL, ILO, KBOT, HL, NL, W, + $ ILO, IHI, Z, LDZ, WORKL, NL, INFO ) + IF( WANTT .OR. INFO.NE.0 ) + $ CALL ZLACPY( 'A', N, N, HL, NL, H, LDH ) + END IF + END IF + END IF +* +* ==== Clear out the trash, if necessary. ==== +* + IF( ( WANTT .OR. INFO.NE.0 ) .AND. N.GT.2 ) + $ CALL ZLASET( 'L', N-2, N-2, ZERO, ZERO, H( 3, 1 ), LDH ) +* +* ==== Ensure reported workspace size is backward-compatible with +* . previous LAPACK versions. ==== +* + WORK( 1 ) = DCMPLX( MAX( DBLE( MAX( 1, N ) ), + $ DBLE( WORK( 1 ) ) ), RZERO ) + END IF +* +* ==== End of ZHSEQR ==== +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/complex16/zlacgv.f b/fortran_implementation/external_libraries/lapack_routines/complex16/zlacgv.f new file mode 100644 index 0000000..18eb0a6 --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/complex16/zlacgv.f @@ -0,0 +1,61 @@ + SUBROUTINE ZLACGV( N, X, INCX ) +* +* -- LAPACK auxiliary routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INCX, N +* .. +* .. Array Arguments .. + COMPLEX*16 X( * ) +* .. +* +* Purpose +* ======= +* +* ZLACGV conjugates a complex vector of length N. +* +* Arguments +* ========= +* +* N (input) INTEGER +* The length of the vector X. N >= 0. +* +* X (input/output) COMPLEX*16 array, dimension +* (1+(N-1)*abs(INCX)) +* On entry, the vector of length N to be conjugated. +* On exit, X is overwritten with conjg(X). +* +* INCX (input) INTEGER +* The spacing between successive elements of X. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, IOFF +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG +* .. +* .. Executable Statements .. +* + IF( INCX.EQ.1 ) THEN + DO 10 I = 1, N + X( I ) = DCONJG( X( I ) ) + 10 CONTINUE + ELSE + IOFF = 1 + IF( INCX.LT.0 ) + $ IOFF = 1 - ( N-1 )*INCX + DO 20 I = 1, N + X( IOFF ) = DCONJG( X( IOFF ) ) + IOFF = IOFF + INCX + 20 CONTINUE + END IF + RETURN +* +* End of ZLACGV +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/complex16/zlacpy.f b/fortran_implementation/external_libraries/lapack_routines/complex16/zlacpy.f new file mode 100644 index 0000000..9cb25d8 --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/complex16/zlacpy.f @@ -0,0 +1,91 @@ + SUBROUTINE ZLACPY( UPLO, M, N, A, LDA, B, LDB ) +* +* -- LAPACK auxiliary routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, LDB, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), B( LDB, * ) +* .. +* +* Purpose +* ======= +* +* ZLACPY copies all or part of a two-dimensional matrix A to another +* matrix B. +* +* Arguments +* ========= +* +* UPLO (input) CHARACTER*1 +* Specifies the part of the matrix A to be copied to B. +* = 'U': Upper triangular part +* = 'L': Lower triangular part +* Otherwise: All of the matrix A +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* A (input) COMPLEX*16 array, dimension (LDA,N) +* The m by n matrix A. If UPLO = 'U', only the upper trapezium +* is accessed; if UPLO = 'L', only the lower trapezium is +* accessed. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,M). +* +* B (output) COMPLEX*16 array, dimension (LDB,N) +* On exit, B = A in the locations specified by UPLO. +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,M). +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, J +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN +* .. +* .. Executable Statements .. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 20 J = 1, N + DO 10 I = 1, MIN( J, M ) + B( I, J ) = A( I, J ) + 10 CONTINUE + 20 CONTINUE +* + ELSE IF( LSAME( UPLO, 'L' ) ) THEN + DO 40 J = 1, N + DO 30 I = J, M + B( I, J ) = A( I, J ) + 30 CONTINUE + 40 CONTINUE +* + ELSE + DO 60 J = 1, N + DO 50 I = 1, M + B( I, J ) = A( I, J ) + 50 CONTINUE + 60 CONTINUE + END IF +* + RETURN +* +* End of ZLACPY +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/complex16/zladiv.f b/fortran_implementation/external_libraries/lapack_routines/complex16/zladiv.f new file mode 100644 index 0000000..1e68c36 --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/complex16/zladiv.f @@ -0,0 +1,47 @@ + COMPLEX*16 FUNCTION ZLADIV( X, Y ) +* +* -- LAPACK auxiliary routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + COMPLEX*16 X, Y +* .. +* +* Purpose +* ======= +* +* ZLADIV := X / Y, where X and Y are complex. The computation of X / Y +* will not overflow on an intermediary step unless the results +* overflows. +* +* Arguments +* ========= +* +* X (input) COMPLEX*16 +* Y (input) COMPLEX*16 +* The complex scalars X and Y. +* +* ===================================================================== +* +* .. Local Scalars .. + DOUBLE PRECISION ZI, ZR +* .. +* .. External Subroutines .. + EXTERNAL DLADIV +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, DCMPLX, DIMAG +* .. +* .. Executable Statements .. +* + CALL DLADIV( DBLE( X ), DIMAG( X ), DBLE( Y ), DIMAG( Y ), ZR, + $ ZI ) + ZLADIV = DCMPLX( ZR, ZI ) +* + RETURN +* +* End of ZLADIV +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/complex16/zlahqr.f b/fortran_implementation/external_libraries/lapack_routines/complex16/zlahqr.f new file mode 100644 index 0000000..d6216d9 --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/complex16/zlahqr.f @@ -0,0 +1,475 @@ + SUBROUTINE ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, + $ IHIZ, Z, LDZ, INFO ) +* +* -- LAPACK auxiliary routine (version 3.2) -- +* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + COMPLEX*16 H( LDH, * ), W( * ), Z( LDZ, * ) +* .. +* +* Purpose +* ======= +* +* ZLAHQR is an auxiliary routine called by CHSEQR to update the +* eigenvalues and Schur decomposition already computed by CHSEQR, by +* dealing with the Hessenberg submatrix in rows and columns ILO to +* IHI. +* +* Arguments +* ========= +* +* WANTT (input) LOGICAL +* = .TRUE. : the full Schur form T is required; +* = .FALSE.: only eigenvalues are required. +* +* WANTZ (input) LOGICAL +* = .TRUE. : the matrix of Schur vectors Z is required; +* = .FALSE.: Schur vectors are not required. +* +* N (input) INTEGER +* The order of the matrix H. N >= 0. +* +* ILO (input) INTEGER +* IHI (input) INTEGER +* It is assumed that H is already upper triangular in rows and +* columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless ILO = 1). +* ZLAHQR works primarily with the Hessenberg submatrix in rows +* and columns ILO to IHI, but applies transformations to all of +* H if WANTT is .TRUE.. +* 1 <= ILO <= max(1,IHI); IHI <= N. +* +* H (input/output) COMPLEX*16 array, dimension (LDH,N) +* On entry, the upper Hessenberg matrix H. +* On exit, if INFO is zero and if WANTT is .TRUE., then H +* is upper triangular in rows and columns ILO:IHI. If INFO +* is zero and if WANTT is .FALSE., then the contents of H +* are unspecified on exit. The output state of H in case +* INF is positive is below under the description of INFO. +* +* LDH (input) INTEGER +* The leading dimension of the array H. LDH >= max(1,N). +* +* W (output) COMPLEX*16 array, dimension (N) +* The computed eigenvalues ILO to IHI are stored in the +* corresponding elements of W. If WANTT is .TRUE., the +* eigenvalues are stored in the same order as on the diagonal +* of the Schur form returned in H, with W(i) = H(i,i). +* +* ILOZ (input) INTEGER +* IHIZ (input) INTEGER +* Specify the rows of Z to which transformations must be +* applied if WANTZ is .TRUE.. +* 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. +* +* Z (input/output) COMPLEX*16 array, dimension (LDZ,N) +* If WANTZ is .TRUE., on entry Z must contain the current +* matrix Z of transformations accumulated by CHSEQR, and on +* exit Z has been updated; transformations are applied only to +* the submatrix Z(ILOZ:IHIZ,ILO:IHI). +* If WANTZ is .FALSE., Z is not referenced. +* +* LDZ (input) INTEGER +* The leading dimension of the array Z. LDZ >= max(1,N). +* +* INFO (output) INTEGER +* = 0: successful exit +* .GT. 0: if INFO = i, ZLAHQR failed to compute all the +* eigenvalues ILO to IHI in a total of 30 iterations +* per eigenvalue; elements i+1:ihi of W contain +* those eigenvalues which have been successfully +* computed. +* +* If INFO .GT. 0 and WANTT is .FALSE., then on exit, +* the remaining unconverged eigenvalues are the +* eigenvalues of the upper Hessenberg matrix +* rows and columns ILO thorugh INFO of the final, +* output value of H. +* +* If INFO .GT. 0 and WANTT is .TRUE., then on exit +* (*) (initial value of H)*U = U*(final value of H) +* where U is an orthognal matrix. The final +* value of H is upper Hessenberg and triangular in +* rows and columns INFO+1 through IHI. +* +* If INFO .GT. 0 and WANTZ is .TRUE., then on exit +* (final value of Z) = (initial value of Z)*U +* where U is the orthogonal matrix in (*) +* (regardless of the value of WANTT.) +* +* Further Details +* =============== +* +* 02-96 Based on modifications by +* David Day, Sandia National Laboratory, USA +* +* 12-04 Further modifications by +* Ralph Byers, University of Kansas, USA +* This is a modified version of ZLAHQR from LAPACK version 3.0. +* It is (1) more robust against overflow and underflow and +* (2) adopts the more conservative Ahues & Tisseur stopping +* criterion (LAWN 122, 1997). +* +* ========================================================= +* +* .. Parameters .. + INTEGER ITMAX + PARAMETER ( ITMAX = 30 ) + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), + $ ONE = ( 1.0d0, 0.0d0 ) ) + DOUBLE PRECISION RZERO, RONE, HALF + PARAMETER ( RZERO = 0.0d0, RONE = 1.0d0, HALF = 0.5d0 ) + DOUBLE PRECISION DAT1 + PARAMETER ( DAT1 = 3.0d0 / 4.0d0 ) +* .. +* .. Local Scalars .. + COMPLEX*16 CDUM, H11, H11S, H22, SC, SUM, T, T1, TEMP, U, + $ V2, X, Y + DOUBLE PRECISION AA, AB, BA, BB, H10, H21, RTEMP, S, SAFMAX, + $ SAFMIN, SMLNUM, SX, T2, TST, ULP + INTEGER I, I1, I2, ITS, J, JHI, JLO, K, L, M, NH, NZ +* .. +* .. Local Arrays .. + COMPLEX*16 V( 2 ) +* .. +* .. External Functions .. + COMPLEX*16 ZLADIV + DOUBLE PRECISION DLAMCH + EXTERNAL ZLADIV, DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DLABAD, ZCOPY, ZLARFG, ZSCAL +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, SQRT +* .. +* .. Statement Function definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) +* .. +* .. Executable Statements .. +* + INFO = 0 +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN + IF( ILO.EQ.IHI ) THEN + W( ILO ) = H( ILO, ILO ) + RETURN + END IF +* +* ==== clear out the trash ==== + DO 10 J = ILO, IHI - 3 + H( J+2, J ) = ZERO + H( J+3, J ) = ZERO + 10 CONTINUE + IF( ILO.LE.IHI-2 ) + $ H( IHI, IHI-2 ) = ZERO +* ==== ensure that subdiagonal entries are real ==== + IF( WANTT ) THEN + JLO = 1 + JHI = N + ELSE + JLO = ILO + JHI = IHI + END IF + DO 20 I = ILO + 1, IHI + IF( DIMAG( H( I, I-1 ) ).NE.RZERO ) THEN +* ==== The following redundant normalization +* . avoids problems with both gradual and +* . sudden underflow in ABS(H(I,I-1)) ==== + SC = H( I, I-1 ) / CABS1( H( I, I-1 ) ) + SC = DCONJG( SC ) / ABS( SC ) + H( I, I-1 ) = ABS( H( I, I-1 ) ) + CALL ZSCAL( JHI-I+1, SC, H( I, I ), LDH ) + CALL ZSCAL( MIN( JHI, I+1 )-JLO+1, DCONJG( SC ), + $ H( JLO, I ), 1 ) + IF( WANTZ ) + $ CALL ZSCAL( IHIZ-ILOZ+1, DCONJG( SC ), Z( ILOZ, I ), 1 ) + END IF + 20 CONTINUE +* + NH = IHI - ILO + 1 + NZ = IHIZ - ILOZ + 1 +* +* Set machine-dependent constants for the stopping criterion. +* + SAFMIN = DLAMCH( 'SAFE MINIMUM' ) + SAFMAX = RONE / SAFMIN + CALL DLABAD( SAFMIN, SAFMAX ) + ULP = DLAMCH( 'PRECISION' ) + SMLNUM = SAFMIN*( DBLE( NH ) / ULP ) +* +* I1 and I2 are the indices of the first row and last column of H +* to which transformations must be applied. If eigenvalues only are +* being computed, I1 and I2 are set inside the main loop. +* + IF( WANTT ) THEN + I1 = 1 + I2 = N + END IF +* +* The main loop begins here. I is the loop index and decreases from +* IHI to ILO in steps of 1. Each iteration of the loop works +* with the active submatrix in rows and columns L to I. +* Eigenvalues I+1 to IHI have already converged. Either L = ILO, or +* H(L,L-1) is negligible so that the matrix splits. +* + I = IHI + 30 CONTINUE + IF( I.LT.ILO ) + $ GO TO 150 +* +* Perform QR iterations on rows and columns ILO to I until a +* submatrix of order 1 splits off at the bottom because a +* subdiagonal element has become negligible. +* + L = ILO + DO 130 ITS = 0, ITMAX +* +* Look for a single small subdiagonal element. +* + DO 40 K = I, L + 1, -1 + IF( CABS1( H( K, K-1 ) ).LE.SMLNUM ) + $ GO TO 50 + TST = CABS1( H( K-1, K-1 ) ) + CABS1( H( K, K ) ) + IF( TST.EQ.ZERO ) THEN + IF( K-2.GE.ILO ) + $ TST = TST + ABS( DBLE( H( K-1, K-2 ) ) ) + IF( K+1.LE.IHI ) + $ TST = TST + ABS( DBLE( H( K+1, K ) ) ) + END IF +* ==== The following is a conservative small subdiagonal +* . deflation criterion due to Ahues & Tisseur (LAWN 122, +* . 1997). It has better mathematical foundation and +* . improves accuracy in some examples. ==== + IF( ABS( DBLE( H( K, K-1 ) ) ).LE.ULP*TST ) THEN + AB = MAX( CABS1( H( K, K-1 ) ), CABS1( H( K-1, K ) ) ) + BA = MIN( CABS1( H( K, K-1 ) ), CABS1( H( K-1, K ) ) ) + AA = MAX( CABS1( H( K, K ) ), + $ CABS1( H( K-1, K-1 )-H( K, K ) ) ) + BB = MIN( CABS1( H( K, K ) ), + $ CABS1( H( K-1, K-1 )-H( K, K ) ) ) + S = AA + AB + IF( BA*( AB / S ).LE.MAX( SMLNUM, + $ ULP*( BB*( AA / S ) ) ) )GO TO 50 + END IF + 40 CONTINUE + 50 CONTINUE + L = K + IF( L.GT.ILO ) THEN +* +* H(L,L-1) is negligible +* + H( L, L-1 ) = ZERO + END IF +* +* Exit from loop if a submatrix of order 1 has split off. +* + IF( L.GE.I ) + $ GO TO 140 +* +* Now the active submatrix is in rows and columns L to I. If +* eigenvalues only are being computed, only the active submatrix +* need be transformed. +* + IF( .NOT.WANTT ) THEN + I1 = L + I2 = I + END IF +* + IF( ITS.EQ.10 ) THEN +* +* Exceptional shift. +* + S = DAT1*ABS( DBLE( H( L+1, L ) ) ) + T = S + H( L, L ) + ELSE IF( ITS.EQ.20 ) THEN +* +* Exceptional shift. +* + S = DAT1*ABS( DBLE( H( I, I-1 ) ) ) + T = S + H( I, I ) + ELSE +* +* Wilkinson's shift. +* + T = H( I, I ) + U = SQRT( H( I-1, I ) )*SQRT( H( I, I-1 ) ) + S = CABS1( U ) + IF( S.NE.RZERO ) THEN + X = HALF*( H( I-1, I-1 )-T ) + SX = CABS1( X ) + S = MAX( S, CABS1( X ) ) + Y = S*SQRT( ( X / S )**2+( U / S )**2 ) + IF( SX.GT.RZERO ) THEN + IF( DBLE( X / SX )*DBLE( Y )+DIMAG( X / SX )* + $ DIMAG( Y ).LT.RZERO )Y = -Y + END IF + T = T - U*ZLADIV( U, ( X+Y ) ) + END IF + END IF +* +* Look for two consecutive small subdiagonal elements. +* + DO 60 M = I - 1, L + 1, -1 +* +* Determine the effect of starting the single-shift QR +* iteration at row M, and see if this would make H(M,M-1) +* negligible. +* + H11 = H( M, M ) + H22 = H( M+1, M+1 ) + H11S = H11 - T + H21 = DBLE( H( M+1, M ) ) + S = CABS1( H11S ) + ABS( H21 ) + H11S = H11S / S + H21 = H21 / S + V( 1 ) = H11S + V( 2 ) = H21 + H10 = DBLE( H( M, M-1 ) ) + IF( ABS( H10 )*ABS( H21 ).LE.ULP* + $ ( CABS1( H11S )*( CABS1( H11 )+CABS1( H22 ) ) ) ) + $ GO TO 70 + 60 CONTINUE + H11 = H( L, L ) + H22 = H( L+1, L+1 ) + H11S = H11 - T + H21 = DBLE( H( L+1, L ) ) + S = CABS1( H11S ) + ABS( H21 ) + H11S = H11S / S + H21 = H21 / S + V( 1 ) = H11S + V( 2 ) = H21 + 70 CONTINUE +* +* Single-shift QR step +* + DO 120 K = M, I - 1 +* +* The first iteration of this loop determines a reflection G +* from the vector V and applies it from left and right to H, +* thus creating a nonzero bulge below the subdiagonal. +* +* Each subsequent iteration determines a reflection G to +* restore the Hessenberg form in the (K-1)th column, and thus +* chases the bulge one step toward the bottom of the active +* submatrix. +* +* V(2) is always real before the call to ZLARFG, and hence +* after the call T2 ( = T1*V(2) ) is also real. +* + IF( K.GT.M ) + $ CALL ZCOPY( 2, H( K, K-1 ), 1, V, 1 ) + CALL ZLARFG( 2, V( 1 ), V( 2 ), 1, T1 ) + IF( K.GT.M ) THEN + H( K, K-1 ) = V( 1 ) + H( K+1, K-1 ) = ZERO + END IF + V2 = V( 2 ) + T2 = DBLE( T1*V2 ) +* +* Apply G from the left to transform the rows of the matrix +* in columns K to I2. +* + DO 80 J = K, I2 + SUM = DCONJG( T1 )*H( K, J ) + T2*H( K+1, J ) + H( K, J ) = H( K, J ) - SUM + H( K+1, J ) = H( K+1, J ) - SUM*V2 + 80 CONTINUE +* +* Apply G from the right to transform the columns of the +* matrix in rows I1 to min(K+2,I). +* + DO 90 J = I1, MIN( K+2, I ) + SUM = T1*H( J, K ) + T2*H( J, K+1 ) + H( J, K ) = H( J, K ) - SUM + H( J, K+1 ) = H( J, K+1 ) - SUM*DCONJG( V2 ) + 90 CONTINUE +* + IF( WANTZ ) THEN +* +* Accumulate transformations in the matrix Z +* + DO 100 J = ILOZ, IHIZ + SUM = T1*Z( J, K ) + T2*Z( J, K+1 ) + Z( J, K ) = Z( J, K ) - SUM + Z( J, K+1 ) = Z( J, K+1 ) - SUM*DCONJG( V2 ) + 100 CONTINUE + END IF +* + IF( K.EQ.M .AND. M.GT.L ) THEN +* +* If the QR step was started at row M > L because two +* consecutive small subdiagonals were found, then extra +* scaling must be performed to ensure that H(M,M-1) remains +* real. +* + TEMP = ONE - T1 + TEMP = TEMP / ABS( TEMP ) + H( M+1, M ) = H( M+1, M )*DCONJG( TEMP ) + IF( M+2.LE.I ) + $ H( M+2, M+1 ) = H( M+2, M+1 )*TEMP + DO 110 J = M, I + IF( J.NE.M+1 ) THEN + IF( I2.GT.J ) + $ CALL ZSCAL( I2-J, TEMP, H( J, J+1 ), LDH ) + CALL ZSCAL( J-I1, DCONJG( TEMP ), H( I1, J ), 1 ) + IF( WANTZ ) THEN + CALL ZSCAL( NZ, DCONJG( TEMP ), Z( ILOZ, J ), + $ 1 ) + END IF + END IF + 110 CONTINUE + END IF + 120 CONTINUE +* +* Ensure that H(I,I-1) is real. +* + TEMP = H( I, I-1 ) + IF( DIMAG( TEMP ).NE.RZERO ) THEN + RTEMP = ABS( TEMP ) + H( I, I-1 ) = RTEMP + TEMP = TEMP / RTEMP + IF( I2.GT.I ) + $ CALL ZSCAL( I2-I, DCONJG( TEMP ), H( I, I+1 ), LDH ) + CALL ZSCAL( I-I1, TEMP, H( I1, I ), 1 ) + IF( WANTZ ) THEN + CALL ZSCAL( NZ, TEMP, Z( ILOZ, I ), 1 ) + END IF + END IF +* + 130 CONTINUE +* +* Failure to converge in remaining number of iterations +* + INFO = I + RETURN +* + 140 CONTINUE +* +* H(I,I-1) is negligible: one eigenvalue has converged. +* + W( I ) = H( I, I ) +* +* return to start of the main loop with new value of I. +* + I = L - 1 + GO TO 30 +* + 150 CONTINUE + RETURN +* +* End of ZLAHQR +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/complex16/zlahr2.f b/fortran_implementation/external_libraries/lapack_routines/complex16/zlahr2.f new file mode 100644 index 0000000..a497be1 --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/complex16/zlahr2.f @@ -0,0 +1,248 @@ + SUBROUTINE ZLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) +* +* -- LAPACK auxiliary routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* -- April 2009 -- +* +* .. Scalar Arguments .. + INTEGER K, LDA, LDT, LDY, N, NB +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), T( LDT, NB ), TAU( NB ), + $ Y( LDY, NB ) +* .. +* +* Purpose +* ======= +* +* ZLAHR2 reduces the first NB columns of A complex general n-BY-(n-k+1) +* matrix A so that elements below the k-th subdiagonal are zero. The +* reduction is performed by an unitary similarity transformation +* Q**H * A * Q. The routine returns the matrices V and T which determine +* Q as a block reflector I - V*T*V**H, and also the matrix Y = A * V * T. +* +* This is an auxiliary routine called by ZGEHRD. +* +* Arguments +* ========= +* +* N (input) INTEGER +* The order of the matrix A. +* +* K (input) INTEGER +* The offset for the reduction. Elements below the k-th +* subdiagonal in the first NB columns are reduced to zero. +* K < N. +* +* NB (input) INTEGER +* The number of columns to be reduced. +* +* A (input/output) COMPLEX*16 array, dimension (LDA,N-K+1) +* On entry, the n-by-(n-k+1) general matrix A. +* On exit, the elements on and above the k-th subdiagonal in +* the first NB columns are overwritten with the corresponding +* elements of the reduced matrix; the elements below the k-th +* subdiagonal, with the array TAU, represent the matrix Q as a +* product of elementary reflectors. The other columns of A are +* unchanged. See Further Details. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* TAU (output) COMPLEX*16 array, dimension (NB) +* The scalar factors of the elementary reflectors. See Further +* Details. +* +* T (output) COMPLEX*16 array, dimension (LDT,NB) +* The upper triangular matrix T. +* +* LDT (input) INTEGER +* The leading dimension of the array T. LDT >= NB. +* +* Y (output) COMPLEX*16 array, dimension (LDY,NB) +* The n-by-nb matrix Y. +* +* LDY (input) INTEGER +* The leading dimension of the array Y. LDY >= N. +* +* Further Details +* =============== +* +* The matrix Q is represented as a product of nb elementary reflectors +* +* Q = H(1) H(2) . . . H(nb). +* +* Each H(i) has the form +* +* H(i) = I - tau * v * v**H +* +* where tau is a complex scalar, and v is a complex vector with +* v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in +* A(i+k+1:n,i), and tau in TAU(i). +* +* The elements of the vectors v together form the (n-k+1)-by-nb matrix +* V which is needed, with T and Y, to apply the transformation to the +* unreduced part of the matrix, using an update of the form: +* A := (I - V*T*V**H) * (A - Y*V**H). +* +* The contents of A on exit are illustrated by the following example +* with n = 7, k = 3 and nb = 2: +* +* ( a a a a a ) +* ( a a a a a ) +* ( a a a a a ) +* ( h h a a a ) +* ( v1 h a a a ) +* ( v1 v2 a a a ) +* ( v1 v2 a a a ) +* +* where a denotes an element of the original matrix A, h denotes a +* modified element of the upper Hessenberg matrix H, and vi denotes an +* element of the vector defining H(i). +* +* This subroutine is a slight modification of LAPACK-3.0's DLAHRD +* incorporating improvements proposed by Quintana-Orti and Van de +* Gejin. Note that the entries of A(1:K,2:NB) differ from those +* returned by the original LAPACK-3.0's DLAHRD routine. (This +* subroutine is not backward compatible with LAPACK-3.0's DLAHRD.) +* +* References +* ========== +* +* Gregorio Quintana-Orti and Robert van de Geijn, "Improving the +* performance of reduction to Hessenberg form," ACM Transactions on +* Mathematical Software, 32(2):180-194, June 2006. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), + $ ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I + COMPLEX*16 EI +* .. +* .. External Subroutines .. + EXTERNAL ZAXPY, ZCOPY, ZGEMM, ZGEMV, ZLACPY, + $ ZLARFG, ZSCAL, ZTRMM, ZTRMV, ZLACGV +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( N.LE.1 ) + $ RETURN +* + DO 10 I = 1, NB + IF( I.GT.1 ) THEN +* +* Update A(K+1:N,I) +* +* Update I-th column of A - Y * V**H +* + CALL ZLACGV( I-1, A( K+I-1, 1 ), LDA ) + CALL ZGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, Y(K+1,1), LDY, + $ A( K+I-1, 1 ), LDA, ONE, A( K+1, I ), 1 ) + CALL ZLACGV( I-1, A( K+I-1, 1 ), LDA ) +* +* Apply I - V * T**H * V**H to this column (call it b) from the +* left, using the last column of T as workspace +* +* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows) +* ( V2 ) ( b2 ) +* +* where V1 is unit lower triangular +* +* w := V1**H * b1 +* + CALL ZCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 ) + CALL ZTRMV( 'Lower', 'Conjugate transpose', 'UNIT', + $ I-1, A( K+1, 1 ), + $ LDA, T( 1, NB ), 1 ) +* +* w := w + V2**H * b2 +* + CALL ZGEMV( 'Conjugate transpose', N-K-I+1, I-1, + $ ONE, A( K+I, 1 ), + $ LDA, A( K+I, I ), 1, ONE, T( 1, NB ), 1 ) +* +* w := T**H * w +* + CALL ZTRMV( 'Upper', 'Conjugate transpose', 'NON-UNIT', + $ I-1, T, LDT, + $ T( 1, NB ), 1 ) +* +* b2 := b2 - V2*w +* + CALL ZGEMV( 'NO TRANSPOSE', N-K-I+1, I-1, -ONE, + $ A( K+I, 1 ), + $ LDA, T( 1, NB ), 1, ONE, A( K+I, I ), 1 ) +* +* b1 := b1 - V1*w +* + CALL ZTRMV( 'Lower', 'NO TRANSPOSE', + $ 'UNIT', I-1, + $ A( K+1, 1 ), LDA, T( 1, NB ), 1 ) + CALL ZAXPY( I-1, -ONE, T( 1, NB ), 1, A( K+1, I ), 1 ) +* + A( K+I-1, I-1 ) = EI + END IF +* +* Generate the elementary reflector H(I) to annihilate +* A(K+I+1:N,I) +* + CALL ZLARFG( N-K-I+1, A( K+I, I ), A( MIN( K+I+1, N ), I ), 1, + $ TAU( I ) ) + EI = A( K+I, I ) + A( K+I, I ) = ONE +* +* Compute Y(K+1:N,I) +* + CALL ZGEMV( 'NO TRANSPOSE', N-K, N-K-I+1, + $ ONE, A( K+1, I+1 ), + $ LDA, A( K+I, I ), 1, ZERO, Y( K+1, I ), 1 ) + CALL ZGEMV( 'Conjugate transpose', N-K-I+1, I-1, + $ ONE, A( K+I, 1 ), LDA, + $ A( K+I, I ), 1, ZERO, T( 1, I ), 1 ) + CALL ZGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, + $ Y( K+1, 1 ), LDY, + $ T( 1, I ), 1, ONE, Y( K+1, I ), 1 ) + CALL ZSCAL( N-K, TAU( I ), Y( K+1, I ), 1 ) +* +* Compute T(1:I,I) +* + CALL ZSCAL( I-1, -TAU( I ), T( 1, I ), 1 ) + CALL ZTRMV( 'Upper', 'No Transpose', 'NON-UNIT', + $ I-1, T, LDT, + $ T( 1, I ), 1 ) + T( I, I ) = TAU( I ) +* + 10 CONTINUE + A( K+NB, NB ) = EI +* +* Compute Y(1:K,1:NB) +* + CALL ZLACPY( 'ALL', K, NB, A( 1, 2 ), LDA, Y, LDY ) + CALL ZTRMM( 'RIGHT', 'Lower', 'NO TRANSPOSE', + $ 'UNIT', K, NB, + $ ONE, A( K+1, 1 ), LDA, Y, LDY ) + IF( N.GT.K+NB ) + $ CALL ZGEMM( 'NO TRANSPOSE', 'NO TRANSPOSE', K, + $ NB, N-K-NB, ONE, + $ A( 1, 2+NB ), LDA, A( K+1+NB, 1 ), LDA, ONE, Y, + $ LDY ) + CALL ZTRMM( 'RIGHT', 'Upper', 'NO TRANSPOSE', + $ 'NON-UNIT', K, NB, + $ ONE, T, LDT, Y, LDY ) +* + RETURN +* +* End of ZLAHR2 +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/complex16/zlange.f b/fortran_implementation/external_libraries/lapack_routines/complex16/zlange.f new file mode 100644 index 0000000..56aa3ec --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/complex16/zlange.f @@ -0,0 +1,146 @@ + DOUBLE PRECISION FUNCTION ZLANGE( NORM, M, N, A, LDA, WORK ) +* +* -- LAPACK auxiliary routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER NORM + INTEGER LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION WORK( * ) + COMPLEX*16 A( LDA, * ) +* .. +* +* Purpose +* ======= +* +* ZLANGE returns the value of the one norm, or the Frobenius norm, or +* the infinity norm, or the element of largest absolute value of a +* complex matrix A. +* +* Description +* =========== +* +* ZLANGE returns the value +* +* ZLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm' +* ( +* ( norm1(A), NORM = '1', 'O' or 'o' +* ( +* ( normI(A), NORM = 'I' or 'i' +* ( +* ( normF(A), NORM = 'F', 'f', 'E' or 'e' +* +* where norm1 denotes the one norm of a matrix (maximum column sum), +* normI denotes the infinity norm of a matrix (maximum row sum) and +* normF denotes the Frobenius norm of a matrix (square root of sum of +* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. +* +* Arguments +* ========= +* +* NORM (input) CHARACTER*1 +* Specifies the value to be returned in ZLANGE as described +* above. +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. When M = 0, +* ZLANGE is set to zero. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. When N = 0, +* ZLANGE is set to zero. +* +* A (input) COMPLEX*16 array, dimension (LDA,N) +* The m by n matrix A. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(M,1). +* +* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), +* where LWORK >= M when NORM = 'I'; otherwise, WORK is not +* referenced. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION SCALE, SUM, VALUE +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL ZLASSQ +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* + IF( MIN( M, N ).EQ.0 ) THEN + VALUE = ZERO + ELSE IF( LSAME( NORM, 'M' ) ) THEN +* +* Find max(abs(A(i,j))). +* + VALUE = ZERO + DO 20 J = 1, N + DO 10 I = 1, M + VALUE = MAX( VALUE, ABS( A( I, J ) ) ) + 10 CONTINUE + 20 CONTINUE + ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN +* +* Find norm1(A). +* + VALUE = ZERO + DO 40 J = 1, N + SUM = ZERO + DO 30 I = 1, M + SUM = SUM + ABS( A( I, J ) ) + 30 CONTINUE + VALUE = MAX( VALUE, SUM ) + 40 CONTINUE + ELSE IF( LSAME( NORM, 'I' ) ) THEN +* +* Find normI(A). +* + DO 50 I = 1, M + WORK( I ) = ZERO + 50 CONTINUE + DO 70 J = 1, N + DO 60 I = 1, M + WORK( I ) = WORK( I ) + ABS( A( I, J ) ) + 60 CONTINUE + 70 CONTINUE + VALUE = ZERO + DO 80 I = 1, M + VALUE = MAX( VALUE, WORK( I ) ) + 80 CONTINUE + ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN +* +* Find normF(A). +* + SCALE = ZERO + SUM = ONE + DO 90 J = 1, N + CALL ZLASSQ( M, A( 1, J ), 1, SCALE, SUM ) + 90 CONTINUE + VALUE = SCALE*SQRT( SUM ) + END IF +* + ZLANGE = VALUE + RETURN +* +* End of ZLANGE +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/complex16/zlaqr0.f b/fortran_implementation/external_libraries/lapack_routines/complex16/zlaqr0.f new file mode 100644 index 0000000..464d40f --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/complex16/zlaqr0.f @@ -0,0 +1,598 @@ + SUBROUTINE ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, + $ IHIZ, Z, LDZ, WORK, LWORK, INFO ) +* +* -- LAPACK auxiliary routine (version 3.2) -- +* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* Purpose +* ======= +* +* ZLAQR0 computes the eigenvalues of a Hessenberg matrix H +* and, optionally, the matrices T and Z from the Schur decomposition +* H = Z T Z**H, where T is an upper triangular matrix (the +* Schur form), and Z is the unitary matrix of Schur vectors. +* +* Optionally Z may be postmultiplied into an input unitary +* matrix Q so that this routine can give the Schur factorization +* of a matrix A which has been reduced to the Hessenberg form H +* by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H. +* +* Arguments +* ========= +* +* WANTT (input) LOGICAL +* = .TRUE. : the full Schur form T is required; +* = .FALSE.: only eigenvalues are required. +* +* WANTZ (input) LOGICAL +* = .TRUE. : the matrix of Schur vectors Z is required; +* = .FALSE.: Schur vectors are not required. +* +* N (input) INTEGER +* The order of the matrix H. N .GE. 0. +* +* ILO (input) INTEGER +* IHI (input) INTEGER +* It is assumed that H is already upper triangular in rows +* and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1, +* H(ILO,ILO-1) is zero. ILO and IHI are normally set by a +* previous call to ZGEBAL, and then passed to ZGEHRD when the +* matrix output by ZGEBAL is reduced to Hessenberg form. +* Otherwise, ILO and IHI should be set to 1 and N, +* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. +* If N = 0, then ILO = 1 and IHI = 0. +* +* H (input/output) COMPLEX*16 array, dimension (LDH,N) +* On entry, the upper Hessenberg matrix H. +* On exit, if INFO = 0 and WANTT is .TRUE., then H +* contains the upper triangular matrix T from the Schur +* decomposition (the Schur form). If INFO = 0 and WANT is +* .FALSE., then the contents of H are unspecified on exit. +* (The output value of H when INFO.GT.0 is given under the +* description of INFO below.) +* +* This subroutine may explicitly set H(i,j) = 0 for i.GT.j and +* j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. +* +* LDH (input) INTEGER +* The leading dimension of the array H. LDH .GE. max(1,N). +* +* W (output) COMPLEX*16 array, dimension (N) +* The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored +* in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are +* stored in the same order as on the diagonal of the Schur +* form returned in H, with W(i) = H(i,i). +* +* Z (input/output) COMPLEX*16 array, dimension (LDZ,IHI) +* If WANTZ is .FALSE., then Z is not referenced. +* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is +* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the +* orthogonal Schur factor of H(ILO:IHI,ILO:IHI). +* (The output value of Z when INFO.GT.0 is given under +* the description of INFO below.) +* +* LDZ (input) INTEGER +* The leading dimension of the array Z. if WANTZ is .TRUE. +* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. +* +* WORK (workspace/output) COMPLEX*16 array, dimension LWORK +* On exit, if LWORK = -1, WORK(1) returns an estimate of +* the optimal value for LWORK. +* +* LWORK (input) INTEGER +* The dimension of the array WORK. LWORK .GE. max(1,N) +* is sufficient, but LWORK typically as large as 6*N may +* be required for optimal performance. A workspace query +* to determine the optimal workspace size is recommended. +* +* If LWORK = -1, then ZLAQR0 does a workspace query. +* In this case, ZLAQR0 checks the input parameters and +* estimates the optimal workspace size for the given +* values of N, ILO and IHI. The estimate is returned +* in WORK(1). No error message related to LWORK is +* issued by XERBLA. Neither H nor Z are accessed. +* +* +* INFO (output) INTEGER +* = 0: successful exit +* .GT. 0: if INFO = i, ZLAQR0 failed to compute all of +* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR +* and WI contain those eigenvalues which have been +* successfully computed. (Failures are rare.) +* +* If INFO .GT. 0 and WANT is .FALSE., then on exit, +* the remaining unconverged eigenvalues are the eigen- +* values of the upper Hessenberg matrix rows and +* columns ILO through INFO of the final, output +* value of H. +* +* If INFO .GT. 0 and WANTT is .TRUE., then on exit +* +* (*) (initial value of H)*U = U*(final value of H) +* +* where U is a unitary matrix. The final +* value of H is upper Hessenberg and triangular in +* rows and columns INFO+1 through IHI. +* +* If INFO .GT. 0 and WANTZ is .TRUE., then on exit +* +* (final value of Z(ILO:IHI,ILOZ:IHIZ) +* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U +* +* where U is the unitary matrix in (*) (regard- +* less of the value of WANTT.) +* +* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not +* accessed. +* +* ================================================================ +* Based on contributions by +* Karen Braman and Ralph Byers, Department of Mathematics, +* University of Kansas, USA +* +* ================================================================ +* References: +* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR +* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 +* Performance, SIAM Journal of Matrix Analysis, volume 23, pages +* 929--947, 2002. +* +* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR +* Algorithm Part II: Aggressive Early Deflation, SIAM Journal +* of Matrix Analysis, volume 23, pages 948--973, 2002. +* +* ================================================================ +* .. Parameters .. +* +* ==== Matrices of order NTINY or smaller must be processed by +* . ZLAHQR because of insufficient subdiagonal scratch space. +* . (This is a hard limit.) ==== + INTEGER NTINY + PARAMETER ( NTINY = 11 ) +* +* ==== Exceptional deflation windows: try to cure rare +* . slow convergence by varying the size of the +* . deflation window after KEXNW iterations. ==== + INTEGER KEXNW + PARAMETER ( KEXNW = 5 ) +* +* ==== Exceptional shifts: try to cure rare slow convergence +* . with ad-hoc exceptional shifts every KEXSH iterations. +* . ==== + INTEGER KEXSH + PARAMETER ( KEXSH = 6 ) +* +* ==== The constant WILK1 is used to form the exceptional +* . shifts. ==== + DOUBLE PRECISION WILK1 + PARAMETER ( WILK1 = 0.75d0 ) + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), + $ ONE = ( 1.0d0, 0.0d0 ) ) + DOUBLE PRECISION TWO + PARAMETER ( TWO = 2.0d0 ) +* .. +* .. Local Scalars .. + COMPLEX*16 AA, BB, CC, CDUM, DD, DET, RTDISC, SWAP, TR2 + DOUBLE PRECISION S + INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS, + $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS, + $ LWKOPT, NDEC, NDFL, NH, NHO, NIBBLE, NMIN, NS, + $ NSMAX, NSR, NVE, NW, NWMAX, NWR, NWUPBD + LOGICAL SORTED + CHARACTER JBCMPZ*2 +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Local Arrays .. + COMPLEX*16 ZDUM( 1, 1 ) +* .. +* .. External Subroutines .. + EXTERNAL ZLACPY, ZLAHQR, ZLAQR3, ZLAQR4, ZLAQR5 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCMPLX, DIMAG, INT, MAX, MIN, MOD, + $ SQRT +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) +* .. +* .. Executable Statements .. + INFO = 0 +* +* ==== Quick return for N = 0: nothing to do. ==== +* + IF( N.EQ.0 ) THEN + WORK( 1 ) = ONE + RETURN + END IF +* + IF( N.LE.NTINY ) THEN +* +* ==== Tiny matrices must use ZLAHQR. ==== +* + LWKOPT = 1 + IF( LWORK.NE.-1 ) + $ CALL ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, + $ IHIZ, Z, LDZ, INFO ) + ELSE +* +* ==== Use small bulge multi-shift QR with aggressive early +* . deflation on larger-than-tiny matrices. ==== +* +* ==== Hope for the best. ==== +* + INFO = 0 +* +* ==== Set up job flags for ILAENV. ==== +* + IF( WANTT ) THEN + JBCMPZ( 1: 1 ) = 'S' + ELSE + JBCMPZ( 1: 1 ) = 'E' + END IF + IF( WANTZ ) THEN + JBCMPZ( 2: 2 ) = 'V' + ELSE + JBCMPZ( 2: 2 ) = 'N' + END IF +* +* ==== NWR = recommended deflation window size. At this +* . point, N .GT. NTINY = 11, so there is enough +* . subdiagonal workspace for NWR.GE.2 as required. +* . (In fact, there is enough subdiagonal space for +* . NWR.GE.3.) ==== +* + NWR = ILAENV( 13, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) + NWR = MAX( 2, NWR ) + NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR ) +* +* ==== NSR = recommended number of simultaneous shifts. +* . At this point N .GT. NTINY = 11, so there is at +* . enough subdiagonal workspace for NSR to be even +* . and greater than or equal to two as required. ==== +* + NSR = ILAENV( 15, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) + NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO ) + NSR = MAX( 2, NSR-MOD( NSR, 2 ) ) +* +* ==== Estimate optimal workspace ==== +* +* ==== Workspace query call to ZLAQR3 ==== +* + CALL ZLAQR3( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, LS, LD, W, H, LDH, N, H, LDH, N, H, + $ LDH, WORK, -1 ) +* +* ==== Optimal workspace = MAX(ZLAQR5, ZLAQR3) ==== +* + LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) ) +* +* ==== Quick return in case of workspace query. ==== +* + IF( LWORK.EQ.-1 ) THEN + WORK( 1 ) = DCMPLX( LWKOPT, 0 ) + RETURN + END IF +* +* ==== ZLAHQR/ZLAQR0 crossover point ==== +* + NMIN = ILAENV( 12, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) + NMIN = MAX( NTINY, NMIN ) +* +* ==== Nibble crossover point ==== +* + NIBBLE = ILAENV( 14, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) + NIBBLE = MAX( 0, NIBBLE ) +* +* ==== Accumulate reflections during ttswp? Use block +* . 2-by-2 structure during matrix-matrix multiply? ==== +* + KACC22 = ILAENV( 16, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) + KACC22 = MAX( 0, KACC22 ) + KACC22 = MIN( 2, KACC22 ) +* +* ==== NWMAX = the largest possible deflation window for +* . which there is sufficient workspace. ==== +* + NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 ) + NW = NWMAX +* +* ==== NSMAX = the Largest number of simultaneous shifts +* . for which there is sufficient workspace. ==== +* + NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 ) + NSMAX = NSMAX - MOD( NSMAX, 2 ) +* +* ==== NDFL: an iteration count restarted at deflation. ==== +* + NDFL = 1 +* +* ==== ITMAX = iteration limit ==== +* + ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) ) +* +* ==== Last row and column in the active block ==== +* + KBOT = IHI +* +* ==== Main Loop ==== +* + DO 70 IT = 1, ITMAX +* +* ==== Done when KBOT falls below ILO ==== +* + IF( KBOT.LT.ILO ) + $ GO TO 80 +* +* ==== Locate active block ==== +* + DO 10 K = KBOT, ILO + 1, -1 + IF( H( K, K-1 ).EQ.ZERO ) + $ GO TO 20 + 10 CONTINUE + K = ILO + 20 CONTINUE + KTOP = K +* +* ==== Select deflation window size: +* . Typical Case: +* . If possible and advisable, nibble the entire +* . active block. If not, use size MIN(NWR,NWMAX) +* . or MIN(NWR+1,NWMAX) depending upon which has +* . the smaller corresponding subdiagonal entry +* . (a heuristic). +* . +* . Exceptional Case: +* . If there have been no deflations in KEXNW or +* . more iterations, then vary the deflation window +* . size. At first, because, larger windows are, +* . in general, more powerful than smaller ones, +* . rapidly increase the window to the maximum possible. +* . Then, gradually reduce the window size. ==== +* + NH = KBOT - KTOP + 1 + NWUPBD = MIN( NH, NWMAX ) + IF( NDFL.LT.KEXNW ) THEN + NW = MIN( NWUPBD, NWR ) + ELSE + NW = MIN( NWUPBD, 2*NW ) + END IF + IF( NW.LT.NWMAX ) THEN + IF( NW.GE.NH-1 ) THEN + NW = NH + ELSE + KWTOP = KBOT - NW + 1 + IF( CABS1( H( KWTOP, KWTOP-1 ) ).GT. + $ CABS1( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 + END IF + END IF + IF( NDFL.LT.KEXNW ) THEN + NDEC = -1 + ELSE IF( NDEC.GE.0 .OR. NW.GE.NWUPBD ) THEN + NDEC = NDEC + 1 + IF( NW-NDEC.LT.2 ) + $ NDEC = 0 + NW = NW - NDEC + END IF +* +* ==== Aggressive early deflation: +* . split workspace under the subdiagonal into +* . - an nw-by-nw work array V in the lower +* . left-hand-corner, +* . - an NW-by-at-least-NW-but-more-is-better +* . (NW-by-NHO) horizontal work array along +* . the bottom edge, +* . - an at-least-NW-but-more-is-better (NHV-by-NW) +* . vertical work array along the left-hand-edge. +* . ==== +* + KV = N - NW + 1 + KT = NW + 1 + NHO = ( N-NW-1 ) - KT + 1 + KWV = NW + 2 + NVE = ( N-NW ) - KWV + 1 +* +* ==== Aggressive early deflation ==== +* + CALL ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, LS, LD, W, H( KV, 1 ), LDH, NHO, + $ H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH, WORK, + $ LWORK ) +* +* ==== Adjust KBOT accounting for new deflations. ==== +* + KBOT = KBOT - LD +* +* ==== KS points to the shifts. ==== +* + KS = KBOT - LS + 1 +* +* ==== Skip an expensive QR sweep if there is a (partly +* . heuristic) reason to expect that many eigenvalues +* . will deflate without it. Here, the QR sweep is +* . skipped if many eigenvalues have just been deflated +* . or if the remaining active block is small. +* + IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT- + $ KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN +* +* ==== NS = nominal number of simultaneous shifts. +* . This may be lowered (slightly) if ZLAQR3 +* . did not provide that many shifts. ==== +* + NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) ) + NS = NS - MOD( NS, 2 ) +* +* ==== If there have been no deflations +* . in a multiple of KEXSH iterations, +* . then try exceptional shifts. +* . Otherwise use shifts provided by +* . ZLAQR3 above or from the eigenvalues +* . of a trailing principal submatrix. ==== +* + IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN + KS = KBOT - NS + 1 + DO 30 I = KBOT, KS + 1, -2 + W( I ) = H( I, I ) + WILK1*CABS1( H( I, I-1 ) ) + W( I-1 ) = W( I ) + 30 CONTINUE + ELSE +* +* ==== Got NS/2 or fewer shifts? Use ZLAQR4 or +* . ZLAHQR on a trailing principal submatrix to +* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, +* . there is enough space below the subdiagonal +* . to fit an NS-by-NS scratch array.) ==== +* + IF( KBOT-KS+1.LE.NS / 2 ) THEN + KS = KBOT - NS + 1 + KT = N - NS + 1 + CALL ZLACPY( 'A', NS, NS, H( KS, KS ), LDH, + $ H( KT, 1 ), LDH ) + IF( NS.GT.NMIN ) THEN + CALL ZLAQR4( .false., .false., NS, 1, NS, + $ H( KT, 1 ), LDH, W( KS ), 1, 1, + $ ZDUM, 1, WORK, LWORK, INF ) + ELSE + CALL ZLAHQR( .false., .false., NS, 1, NS, + $ H( KT, 1 ), LDH, W( KS ), 1, 1, + $ ZDUM, 1, INF ) + END IF + KS = KS + INF +* +* ==== In case of a rare QR failure use +* . eigenvalues of the trailing 2-by-2 +* . principal submatrix. Scale to avoid +* . overflows, underflows and subnormals. +* . (The scale factor S can not be zero, +* . because H(KBOT,KBOT-1) is nonzero.) ==== +* + IF( KS.GE.KBOT ) THEN + S = CABS1( H( KBOT-1, KBOT-1 ) ) + + $ CABS1( H( KBOT, KBOT-1 ) ) + + $ CABS1( H( KBOT-1, KBOT ) ) + + $ CABS1( H( KBOT, KBOT ) ) + AA = H( KBOT-1, KBOT-1 ) / S + CC = H( KBOT, KBOT-1 ) / S + BB = H( KBOT-1, KBOT ) / S + DD = H( KBOT, KBOT ) / S + TR2 = ( AA+DD ) / TWO + DET = ( AA-TR2 )*( DD-TR2 ) - BB*CC + RTDISC = SQRT( -DET ) + W( KBOT-1 ) = ( TR2+RTDISC )*S + W( KBOT ) = ( TR2-RTDISC )*S +* + KS = KBOT - 1 + END IF + END IF +* + IF( KBOT-KS+1.GT.NS ) THEN +* +* ==== Sort the shifts (Helps a little) ==== +* + SORTED = .false. + DO 50 K = KBOT, KS + 1, -1 + IF( SORTED ) + $ GO TO 60 + SORTED = .true. + DO 40 I = KS, K - 1 + IF( CABS1( W( I ) ).LT.CABS1( W( I+1 ) ) ) + $ THEN + SORTED = .false. + SWAP = W( I ) + W( I ) = W( I+1 ) + W( I+1 ) = SWAP + END IF + 40 CONTINUE + 50 CONTINUE + 60 CONTINUE + END IF + END IF +* +* ==== If there are only two shifts, then use +* . only one. ==== +* + IF( KBOT-KS+1.EQ.2 ) THEN + IF( CABS1( W( KBOT )-H( KBOT, KBOT ) ).LT. + $ CABS1( W( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN + W( KBOT-1 ) = W( KBOT ) + ELSE + W( KBOT ) = W( KBOT-1 ) + END IF + END IF +* +* ==== Use up to NS of the the smallest magnatiude +* . shifts. If there aren't NS shifts available, +* . then use them all, possibly dropping one to +* . make the number of shifts even. ==== +* + NS = MIN( NS, KBOT-KS+1 ) + NS = NS - MOD( NS, 2 ) + KS = KBOT - NS + 1 +* +* ==== Small-bulge multi-shift QR sweep: +* . split workspace under the subdiagonal into +* . - a KDU-by-KDU work array U in the lower +* . left-hand-corner, +* . - a KDU-by-at-least-KDU-but-more-is-better +* . (KDU-by-NHo) horizontal work array WH along +* . the bottom edge, +* . - and an at-least-KDU-but-more-is-better-by-KDU +* . (NVE-by-KDU) vertical work WV arrow along +* . the left-hand-edge. ==== +* + KDU = 3*NS - 3 + KU = N - KDU + 1 + KWH = KDU + 1 + NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1 + KWV = KDU + 4 + NVE = N - KDU - KWV + 1 +* +* ==== Small-bulge multi-shift QR sweep ==== +* + CALL ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS, + $ W( KS ), H, LDH, ILOZ, IHIZ, Z, LDZ, WORK, + $ 3, H( KU, 1 ), LDH, NVE, H( KWV, 1 ), LDH, + $ NHO, H( KU, KWH ), LDH ) + END IF +* +* ==== Note progress (or the lack of it). ==== +* + IF( LD.GT.0 ) THEN + NDFL = 1 + ELSE + NDFL = NDFL + 1 + END IF +* +* ==== End of main loop ==== + 70 CONTINUE +* +* ==== Iteration limit exceeded. Set INFO to show where +* . the problem occurred and exit. ==== +* + INFO = KBOT + 80 CONTINUE + END IF +* +* ==== Return the optimal value of LWORK. ==== +* + WORK( 1 ) = DCMPLX( LWKOPT, 0 ) +* +* ==== End of ZLAQR0 ==== +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/complex16/zlaqr1.f b/fortran_implementation/external_libraries/lapack_routines/complex16/zlaqr1.f new file mode 100644 index 0000000..ba62ccd --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/complex16/zlaqr1.f @@ -0,0 +1,97 @@ + SUBROUTINE ZLAQR1( N, H, LDH, S1, S2, V ) +* +* -- LAPACK auxiliary routine (version 3.2) -- +* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + COMPLEX*16 S1, S2 + INTEGER LDH, N +* .. +* .. Array Arguments .. + COMPLEX*16 H( LDH, * ), V( * ) +* .. +* +* Given a 2-by-2 or 3-by-3 matrix H, ZLAQR1 sets v to a +* scalar multiple of the first column of the product +* +* (*) K = (H - s1*I)*(H - s2*I) +* +* scaling to avoid overflows and most underflows. +* +* This is useful for starting double implicit shift bulges +* in the QR algorithm. +* +* +* N (input) integer +* Order of the matrix H. N must be either 2 or 3. +* +* H (input) COMPLEX*16 array of dimension (LDH,N) +* The 2-by-2 or 3-by-3 matrix H in (*). +* +* LDH (input) integer +* The leading dimension of H as declared in +* the calling procedure. LDH.GE.N +* +* S1 (input) COMPLEX*16 +* S2 S1 and S2 are the shifts defining K in (*) above. +* +* V (output) COMPLEX*16 array of dimension N +* A scalar multiple of the first column of the +* matrix K in (*). +* +* ================================================================ +* Based on contributions by +* Karen Braman and Ralph Byers, Department of Mathematics, +* University of Kansas, USA +* +* ================================================================ +* +* .. Parameters .. + COMPLEX*16 ZERO + PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ) ) + DOUBLE PRECISION RZERO + PARAMETER ( RZERO = 0.0d0 ) +* .. +* .. Local Scalars .. + COMPLEX*16 CDUM, H21S, H31S + DOUBLE PRECISION S +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DIMAG +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) +* .. +* .. Executable Statements .. + IF( N.EQ.2 ) THEN + S = CABS1( H( 1, 1 )-S2 ) + CABS1( H( 2, 1 ) ) + IF( S.EQ.RZERO ) THEN + V( 1 ) = ZERO + V( 2 ) = ZERO + ELSE + H21S = H( 2, 1 ) / S + V( 1 ) = H21S*H( 1, 2 ) + ( H( 1, 1 )-S1 )* + $ ( ( H( 1, 1 )-S2 ) / S ) + V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-S1-S2 ) + END IF + ELSE + S = CABS1( H( 1, 1 )-S2 ) + CABS1( H( 2, 1 ) ) + + $ CABS1( H( 3, 1 ) ) + IF( S.EQ.ZERO ) THEN + V( 1 ) = ZERO + V( 2 ) = ZERO + V( 3 ) = ZERO + ELSE + H21S = H( 2, 1 ) / S + H31S = H( 3, 1 ) / S + V( 1 ) = ( H( 1, 1 )-S1 )*( ( H( 1, 1 )-S2 ) / S ) + + $ H( 1, 2 )*H21S + H( 1, 3 )*H31S + V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-S1-S2 ) + H( 2, 3 )*H31S + V( 3 ) = H31S*( H( 1, 1 )+H( 3, 3 )-S1-S2 ) + H21S*H( 3, 2 ) + END IF + END IF + END diff --git a/fortran_implementation/external_libraries/lapack_routines/complex16/zlaqr2.f b/fortran_implementation/external_libraries/lapack_routines/complex16/zlaqr2.f new file mode 100644 index 0000000..2b900ab --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/complex16/zlaqr2.f @@ -0,0 +1,433 @@ + SUBROUTINE ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, + $ NV, WV, LDWV, WORK, LWORK ) +* +* -- LAPACK auxiliary routine (version 3.2.1) -- +* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. +* -- April 2009 -- +* +* .. Scalar Arguments .. + INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, + $ LDZ, LWORK, N, ND, NH, NS, NV, NW + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + COMPLEX*16 H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ), + $ WORK( * ), WV( LDWV, * ), Z( LDZ, * ) +* .. +* +* This subroutine is identical to ZLAQR3 except that it avoids +* recursion by calling ZLAHQR instead of ZLAQR4. +* +* +* ****************************************************************** +* Aggressive early deflation: +* +* This subroutine accepts as input an upper Hessenberg matrix +* H and performs an unitary similarity transformation +* designed to detect and deflate fully converged eigenvalues from +* a trailing principal submatrix. On output H has been over- +* written by a new Hessenberg matrix that is a perturbation of +* an unitary similarity transformation of H. It is to be +* hoped that the final version of H has many zero subdiagonal +* entries. +* +* ****************************************************************** +* WANTT (input) LOGICAL +* If .TRUE., then the Hessenberg matrix H is fully updated +* so that the triangular Schur factor may be +* computed (in cooperation with the calling subroutine). +* If .FALSE., then only enough of H is updated to preserve +* the eigenvalues. +* +* WANTZ (input) LOGICAL +* If .TRUE., then the unitary matrix Z is updated so +* so that the unitary Schur factor may be computed +* (in cooperation with the calling subroutine). +* If .FALSE., then Z is not referenced. +* +* N (input) INTEGER +* The order of the matrix H and (if WANTZ is .TRUE.) the +* order of the unitary matrix Z. +* +* KTOP (input) INTEGER +* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. +* KBOT and KTOP together determine an isolated block +* along the diagonal of the Hessenberg matrix. +* +* KBOT (input) INTEGER +* It is assumed without a check that either +* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together +* determine an isolated block along the diagonal of the +* Hessenberg matrix. +* +* NW (input) INTEGER +* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). +* +* H (input/output) COMPLEX*16 array, dimension (LDH,N) +* On input the initial N-by-N section of H stores the +* Hessenberg matrix undergoing aggressive early deflation. +* On output H has been transformed by a unitary +* similarity transformation, perturbed, and the returned +* to Hessenberg form that (it is to be hoped) has some +* zero subdiagonal entries. +* +* LDH (input) integer +* Leading dimension of H just as declared in the calling +* subroutine. N .LE. LDH +* +* ILOZ (input) INTEGER +* IHIZ (input) INTEGER +* Specify the rows of Z to which transformations must be +* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. +* +* Z (input/output) COMPLEX*16 array, dimension (LDZ,N) +* IF WANTZ is .TRUE., then on output, the unitary +* similarity transformation mentioned above has been +* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. +* If WANTZ is .FALSE., then Z is unreferenced. +* +* LDZ (input) integer +* The leading dimension of Z just as declared in the +* calling subroutine. 1 .LE. LDZ. +* +* NS (output) integer +* The number of unconverged (ie approximate) eigenvalues +* returned in SR and SI that may be used as shifts by the +* calling subroutine. +* +* ND (output) integer +* The number of converged eigenvalues uncovered by this +* subroutine. +* +* SH (output) COMPLEX*16 array, dimension KBOT +* On output, approximate eigenvalues that may +* be used for shifts are stored in SH(KBOT-ND-NS+1) +* through SR(KBOT-ND). Converged eigenvalues are +* stored in SH(KBOT-ND+1) through SH(KBOT). +* +* V (workspace) COMPLEX*16 array, dimension (LDV,NW) +* An NW-by-NW work array. +* +* LDV (input) integer scalar +* The leading dimension of V just as declared in the +* calling subroutine. NW .LE. LDV +* +* NH (input) integer scalar +* The number of columns of T. NH.GE.NW. +* +* T (workspace) COMPLEX*16 array, dimension (LDT,NW) +* +* LDT (input) integer +* The leading dimension of T just as declared in the +* calling subroutine. NW .LE. LDT +* +* NV (input) integer +* The number of rows of work array WV available for +* workspace. NV.GE.NW. +* +* WV (workspace) COMPLEX*16 array, dimension (LDWV,NW) +* +* LDWV (input) integer +* The leading dimension of W just as declared in the +* calling subroutine. NW .LE. LDV +* +* WORK (workspace) COMPLEX*16 array, dimension LWORK. +* On exit, WORK(1) is set to an estimate of the optimal value +* of LWORK for the given values of N, NW, KTOP and KBOT. +* +* LWORK (input) integer +* The dimension of the work array WORK. LWORK = 2*NW +* suffices, but greater efficiency may result from larger +* values of LWORK. +* +* If LWORK = -1, then a workspace query is assumed; ZLAQR2 +* only estimates the optimal workspace size for the given +* values of N, NW, KTOP and KBOT. The estimate is returned +* in WORK(1). No error message related to LWORK is issued +* by XERBLA. Neither H nor Z are accessed. +* +* ================================================================ +* Based on contributions by +* Karen Braman and Ralph Byers, Department of Mathematics, +* University of Kansas, USA +* +* ================================================================ +* .. Parameters .. + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), + $ ONE = ( 1.0d0, 0.0d0 ) ) + DOUBLE PRECISION RZERO, RONE + PARAMETER ( RZERO = 0.0d0, RONE = 1.0d0 ) +* .. +* .. Local Scalars .. + COMPLEX*16 BETA, CDUM, S, TAU + DOUBLE PRECISION FOO, SAFMAX, SAFMIN, SMLNUM, ULP + INTEGER I, IFST, ILST, INFO, INFQR, J, JW, KCOL, KLN, + $ KNT, KROW, KWTOP, LTOP, LWK1, LWK2, LWKOPT +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DLABAD, ZCOPY, ZGEHRD, ZGEMM, ZLACPY, ZLAHQR, + $ ZLARF, ZLARFG, ZLASET, ZTREXC, ZUNMHR +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, MAX, MIN +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) +* .. +* .. Executable Statements .. +* +* ==== Estimate optimal workspace. ==== +* + JW = MIN( NW, KBOT-KTOP+1 ) + IF( JW.LE.2 ) THEN + LWKOPT = 1 + ELSE +* +* ==== Workspace query call to ZGEHRD ==== +* + CALL ZGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) + LWK1 = INT( WORK( 1 ) ) +* +* ==== Workspace query call to ZUNMHR ==== +* + CALL ZUNMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV, + $ WORK, -1, INFO ) + LWK2 = INT( WORK( 1 ) ) +* +* ==== Optimal workspace ==== +* + LWKOPT = JW + MAX( LWK1, LWK2 ) + END IF +* +* ==== Quick return in case of workspace query. ==== +* + IF( LWORK.EQ.-1 ) THEN + WORK( 1 ) = DCMPLX( LWKOPT, 0 ) + RETURN + END IF +* +* ==== Nothing to do ... +* ... for an empty active block ... ==== + NS = 0 + ND = 0 + WORK( 1 ) = ONE + IF( KTOP.GT.KBOT ) + $ RETURN +* ... nor for an empty deflation window. ==== + IF( NW.LT.1 ) + $ RETURN +* +* ==== Machine constants ==== +* + SAFMIN = DLAMCH( 'SAFE MINIMUM' ) + SAFMAX = RONE / SAFMIN + CALL DLABAD( SAFMIN, SAFMAX ) + ULP = DLAMCH( 'PRECISION' ) + SMLNUM = SAFMIN*( DBLE( N ) / ULP ) +* +* ==== Setup deflation window ==== +* + JW = MIN( NW, KBOT-KTOP+1 ) + KWTOP = KBOT - JW + 1 + IF( KWTOP.EQ.KTOP ) THEN + S = ZERO + ELSE + S = H( KWTOP, KWTOP-1 ) + END IF +* + IF( KBOT.EQ.KWTOP ) THEN +* +* ==== 1-by-1 deflation window: not much to do ==== +* + SH( KWTOP ) = H( KWTOP, KWTOP ) + NS = 1 + ND = 0 + IF( CABS1( S ).LE.MAX( SMLNUM, ULP*CABS1( H( KWTOP, + $ KWTOP ) ) ) ) THEN + NS = 0 + ND = 1 + IF( KWTOP.GT.KTOP ) + $ H( KWTOP, KWTOP-1 ) = ZERO + END IF + WORK( 1 ) = ONE + RETURN + END IF +* +* ==== Convert to spike-triangular form. (In case of a +* . rare QR failure, this routine continues to do +* . aggressive early deflation using that part of +* . the deflation window that converged using INFQR +* . here and there to keep track.) ==== +* + CALL ZLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT ) + CALL ZCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 ) +* + CALL ZLASET( 'A', JW, JW, ZERO, ONE, V, LDV ) + CALL ZLAHQR( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1, + $ JW, V, LDV, INFQR ) +* +* ==== Deflation detection loop ==== +* + NS = JW + ILST = INFQR + 1 + DO 10 KNT = INFQR + 1, JW +* +* ==== Small spike tip deflation test ==== +* + FOO = CABS1( T( NS, NS ) ) + IF( FOO.EQ.RZERO ) + $ FOO = CABS1( S ) + IF( CABS1( S )*CABS1( V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) + $ THEN +* +* ==== One more converged eigenvalue ==== +* + NS = NS - 1 + ELSE +* +* ==== One undeflatable eigenvalue. Move it up out of the +* . way. (ZTREXC can not fail in this case.) ==== +* + IFST = NS + CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO ) + ILST = ILST + 1 + END IF + 10 CONTINUE +* +* ==== Return to Hessenberg form ==== +* + IF( NS.EQ.0 ) + $ S = ZERO +* + IF( NS.LT.JW ) THEN +* +* ==== sorting the diagonal of T improves accuracy for +* . graded matrices. ==== +* + DO 30 I = INFQR + 1, NS + IFST = I + DO 20 J = I + 1, NS + IF( CABS1( T( J, J ) ).GT.CABS1( T( IFST, IFST ) ) ) + $ IFST = J + 20 CONTINUE + ILST = I + IF( IFST.NE.ILST ) + $ CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO ) + 30 CONTINUE + END IF +* +* ==== Restore shift/eigenvalue array from T ==== +* + DO 40 I = INFQR + 1, JW + SH( KWTOP+I-1 ) = T( I, I ) + 40 CONTINUE +* +* + IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN + IF( NS.GT.1 .AND. S.NE.ZERO ) THEN +* +* ==== Reflect spike back into lower triangle ==== +* + CALL ZCOPY( NS, V, LDV, WORK, 1 ) + DO 50 I = 1, NS + WORK( I ) = DCONJG( WORK( I ) ) + 50 CONTINUE + BETA = WORK( 1 ) + CALL ZLARFG( NS, BETA, WORK( 2 ), 1, TAU ) + WORK( 1 ) = ONE +* + CALL ZLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT ) +* + CALL ZLARF( 'L', NS, JW, WORK, 1, DCONJG( TAU ), T, LDT, + $ WORK( JW+1 ) ) + CALL ZLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT, + $ WORK( JW+1 ) ) + CALL ZLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV, + $ WORK( JW+1 ) ) +* + CALL ZGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), + $ LWORK-JW, INFO ) + END IF +* +* ==== Copy updated reduced window into place ==== +* + IF( KWTOP.GT.1 ) + $ H( KWTOP, KWTOP-1 ) = S*DCONJG( V( 1, 1 ) ) + CALL ZLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH ) + CALL ZCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ), + $ LDH+1 ) +* +* ==== Accumulate orthogonal matrix in order update +* . H and Z, if requested. ==== +* + IF( NS.GT.1 .AND. S.NE.ZERO ) + $ CALL ZUNMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV, + $ WORK( JW+1 ), LWORK-JW, INFO ) +* +* ==== Update vertical slab in H ==== +* + IF( WANTT ) THEN + LTOP = 1 + ELSE + LTOP = KTOP + END IF + DO 60 KROW = LTOP, KWTOP - 1, NV + KLN = MIN( NV, KWTOP-KROW ) + CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ), + $ LDH, V, LDV, ZERO, WV, LDWV ) + CALL ZLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH ) + 60 CONTINUE +* +* ==== Update horizontal slab in H ==== +* + IF( WANTT ) THEN + DO 70 KCOL = KBOT + 1, N, NH + KLN = MIN( NH, N-KCOL+1 ) + CALL ZGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV, + $ H( KWTOP, KCOL ), LDH, ZERO, T, LDT ) + CALL ZLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ), + $ LDH ) + 70 CONTINUE + END IF +* +* ==== Update vertical slab in Z ==== +* + IF( WANTZ ) THEN + DO 80 KROW = ILOZ, IHIZ, NV + KLN = MIN( NV, IHIZ-KROW+1 ) + CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ), + $ LDZ, V, LDV, ZERO, WV, LDWV ) + CALL ZLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ), + $ LDZ ) + 80 CONTINUE + END IF + END IF +* +* ==== Return the number of deflations ... ==== +* + ND = JW - NS +* +* ==== ... and the number of shifts. (Subtracting +* . INFQR from the spike length takes care +* . of the case of a rare QR failure while +* . calculating eigenvalues of the deflation +* . window.) ==== +* + NS = NS - INFQR +* +* ==== Return optimal workspace. ==== +* + WORK( 1 ) = DCMPLX( LWKOPT, 0 ) +* +* ==== End of ZLAQR2 ==== +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/complex16/zlaqr3.f b/fortran_implementation/external_libraries/lapack_routines/complex16/zlaqr3.f new file mode 100644 index 0000000..2a10ac9 --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/complex16/zlaqr3.f @@ -0,0 +1,443 @@ + SUBROUTINE ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, + $ NV, WV, LDWV, WORK, LWORK ) +* +* -- LAPACK auxiliary routine (version 3.2.1) -- +* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. +* -- April 2009 -- +* +* .. Scalar Arguments .. + INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, + $ LDZ, LWORK, N, ND, NH, NS, NV, NW + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + COMPLEX*16 H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ), + $ WORK( * ), WV( LDWV, * ), Z( LDZ, * ) +* .. +* +* ****************************************************************** +* Aggressive early deflation: +* +* This subroutine accepts as input an upper Hessenberg matrix +* H and performs an unitary similarity transformation +* designed to detect and deflate fully converged eigenvalues from +* a trailing principal submatrix. On output H has been over- +* written by a new Hessenberg matrix that is a perturbation of +* an unitary similarity transformation of H. It is to be +* hoped that the final version of H has many zero subdiagonal +* entries. +* +* ****************************************************************** +* WANTT (input) LOGICAL +* If .TRUE., then the Hessenberg matrix H is fully updated +* so that the triangular Schur factor may be +* computed (in cooperation with the calling subroutine). +* If .FALSE., then only enough of H is updated to preserve +* the eigenvalues. +* +* WANTZ (input) LOGICAL +* If .TRUE., then the unitary matrix Z is updated so +* so that the unitary Schur factor may be computed +* (in cooperation with the calling subroutine). +* If .FALSE., then Z is not referenced. +* +* N (input) INTEGER +* The order of the matrix H and (if WANTZ is .TRUE.) the +* order of the unitary matrix Z. +* +* KTOP (input) INTEGER +* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. +* KBOT and KTOP together determine an isolated block +* along the diagonal of the Hessenberg matrix. +* +* KBOT (input) INTEGER +* It is assumed without a check that either +* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together +* determine an isolated block along the diagonal of the +* Hessenberg matrix. +* +* NW (input) INTEGER +* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). +* +* H (input/output) COMPLEX*16 array, dimension (LDH,N) +* On input the initial N-by-N section of H stores the +* Hessenberg matrix undergoing aggressive early deflation. +* On output H has been transformed by a unitary +* similarity transformation, perturbed, and the returned +* to Hessenberg form that (it is to be hoped) has some +* zero subdiagonal entries. +* +* LDH (input) integer +* Leading dimension of H just as declared in the calling +* subroutine. N .LE. LDH +* +* ILOZ (input) INTEGER +* IHIZ (input) INTEGER +* Specify the rows of Z to which transformations must be +* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. +* +* Z (input/output) COMPLEX*16 array, dimension (LDZ,N) +* IF WANTZ is .TRUE., then on output, the unitary +* similarity transformation mentioned above has been +* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. +* If WANTZ is .FALSE., then Z is unreferenced. +* +* LDZ (input) integer +* The leading dimension of Z just as declared in the +* calling subroutine. 1 .LE. LDZ. +* +* NS (output) integer +* The number of unconverged (ie approximate) eigenvalues +* returned in SR and SI that may be used as shifts by the +* calling subroutine. +* +* ND (output) integer +* The number of converged eigenvalues uncovered by this +* subroutine. +* +* SH (output) COMPLEX*16 array, dimension KBOT +* On output, approximate eigenvalues that may +* be used for shifts are stored in SH(KBOT-ND-NS+1) +* through SR(KBOT-ND). Converged eigenvalues are +* stored in SH(KBOT-ND+1) through SH(KBOT). +* +* V (workspace) COMPLEX*16 array, dimension (LDV,NW) +* An NW-by-NW work array. +* +* LDV (input) integer scalar +* The leading dimension of V just as declared in the +* calling subroutine. NW .LE. LDV +* +* NH (input) integer scalar +* The number of columns of T. NH.GE.NW. +* +* T (workspace) COMPLEX*16 array, dimension (LDT,NW) +* +* LDT (input) integer +* The leading dimension of T just as declared in the +* calling subroutine. NW .LE. LDT +* +* NV (input) integer +* The number of rows of work array WV available for +* workspace. NV.GE.NW. +* +* WV (workspace) COMPLEX*16 array, dimension (LDWV,NW) +* +* LDWV (input) integer +* The leading dimension of W just as declared in the +* calling subroutine. NW .LE. LDV +* +* WORK (workspace) COMPLEX*16 array, dimension LWORK. +* On exit, WORK(1) is set to an estimate of the optimal value +* of LWORK for the given values of N, NW, KTOP and KBOT. +* +* LWORK (input) integer +* The dimension of the work array WORK. LWORK = 2*NW +* suffices, but greater efficiency may result from larger +* values of LWORK. +* +* If LWORK = -1, then a workspace query is assumed; ZLAQR3 +* only estimates the optimal workspace size for the given +* values of N, NW, KTOP and KBOT. The estimate is returned +* in WORK(1). No error message related to LWORK is issued +* by XERBLA. Neither H nor Z are accessed. +* +* ================================================================ +* Based on contributions by +* Karen Braman and Ralph Byers, Department of Mathematics, +* University of Kansas, USA +* +* ================================================================ +* .. Parameters .. + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), + $ ONE = ( 1.0d0, 0.0d0 ) ) + DOUBLE PRECISION RZERO, RONE + PARAMETER ( RZERO = 0.0d0, RONE = 1.0d0 ) +* .. +* .. Local Scalars .. + COMPLEX*16 BETA, CDUM, S, TAU + DOUBLE PRECISION FOO, SAFMAX, SAFMIN, SMLNUM, ULP + INTEGER I, IFST, ILST, INFO, INFQR, J, JW, KCOL, KLN, + $ KNT, KROW, KWTOP, LTOP, LWK1, LWK2, LWK3, + $ LWKOPT, NMIN +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + INTEGER ILAENV + EXTERNAL DLAMCH, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DLABAD, ZCOPY, ZGEHRD, ZGEMM, ZLACPY, ZLAHQR, + $ ZLAQR4, ZLARF, ZLARFG, ZLASET, ZTREXC, ZUNMHR +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, MAX, MIN +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) +* .. +* .. Executable Statements .. +* +* ==== Estimate optimal workspace. ==== +* + JW = MIN( NW, KBOT-KTOP+1 ) + IF( JW.LE.2 ) THEN + LWKOPT = 1 + ELSE +* +* ==== Workspace query call to ZGEHRD ==== +* + CALL ZGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) + LWK1 = INT( WORK( 1 ) ) +* +* ==== Workspace query call to ZUNMHR ==== +* + CALL ZUNMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV, + $ WORK, -1, INFO ) + LWK2 = INT( WORK( 1 ) ) +* +* ==== Workspace query call to ZLAQR4 ==== +* + CALL ZLAQR4( .true., .true., JW, 1, JW, T, LDT, SH, 1, JW, V, + $ LDV, WORK, -1, INFQR ) + LWK3 = INT( WORK( 1 ) ) +* +* ==== Optimal workspace ==== +* + LWKOPT = MAX( JW+MAX( LWK1, LWK2 ), LWK3 ) + END IF +* +* ==== Quick return in case of workspace query. ==== +* + IF( LWORK.EQ.-1 ) THEN + WORK( 1 ) = DCMPLX( LWKOPT, 0 ) + RETURN + END IF +* +* ==== Nothing to do ... +* ... for an empty active block ... ==== + NS = 0 + ND = 0 + WORK( 1 ) = ONE + IF( KTOP.GT.KBOT ) + $ RETURN +* ... nor for an empty deflation window. ==== + IF( NW.LT.1 ) + $ RETURN +* +* ==== Machine constants ==== +* + SAFMIN = DLAMCH( 'SAFE MINIMUM' ) + SAFMAX = RONE / SAFMIN + CALL DLABAD( SAFMIN, SAFMAX ) + ULP = DLAMCH( 'PRECISION' ) + SMLNUM = SAFMIN*( DBLE( N ) / ULP ) +* +* ==== Setup deflation window ==== +* + JW = MIN( NW, KBOT-KTOP+1 ) + KWTOP = KBOT - JW + 1 + IF( KWTOP.EQ.KTOP ) THEN + S = ZERO + ELSE + S = H( KWTOP, KWTOP-1 ) + END IF +* + IF( KBOT.EQ.KWTOP ) THEN +* +* ==== 1-by-1 deflation window: not much to do ==== +* + SH( KWTOP ) = H( KWTOP, KWTOP ) + NS = 1 + ND = 0 + IF( CABS1( S ).LE.MAX( SMLNUM, ULP*CABS1( H( KWTOP, + $ KWTOP ) ) ) ) THEN + NS = 0 + ND = 1 + IF( KWTOP.GT.KTOP ) + $ H( KWTOP, KWTOP-1 ) = ZERO + END IF + WORK( 1 ) = ONE + RETURN + END IF +* +* ==== Convert to spike-triangular form. (In case of a +* . rare QR failure, this routine continues to do +* . aggressive early deflation using that part of +* . the deflation window that converged using INFQR +* . here and there to keep track.) ==== +* + CALL ZLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT ) + CALL ZCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 ) +* + CALL ZLASET( 'A', JW, JW, ZERO, ONE, V, LDV ) + NMIN = ILAENV( 12, 'ZLAQR3', 'SV', JW, 1, JW, LWORK ) + IF( JW.GT.NMIN ) THEN + CALL ZLAQR4( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1, + $ JW, V, LDV, WORK, LWORK, INFQR ) + ELSE + CALL ZLAHQR( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1, + $ JW, V, LDV, INFQR ) + END IF +* +* ==== Deflation detection loop ==== +* + NS = JW + ILST = INFQR + 1 + DO 10 KNT = INFQR + 1, JW +* +* ==== Small spike tip deflation test ==== +* + FOO = CABS1( T( NS, NS ) ) + IF( FOO.EQ.RZERO ) + $ FOO = CABS1( S ) + IF( CABS1( S )*CABS1( V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) + $ THEN +* +* ==== One more converged eigenvalue ==== +* + NS = NS - 1 + ELSE +* +* ==== One undeflatable eigenvalue. Move it up out of the +* . way. (ZTREXC can not fail in this case.) ==== +* + IFST = NS + CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO ) + ILST = ILST + 1 + END IF + 10 CONTINUE +* +* ==== Return to Hessenberg form ==== +* + IF( NS.EQ.0 ) + $ S = ZERO +* + IF( NS.LT.JW ) THEN +* +* ==== sorting the diagonal of T improves accuracy for +* . graded matrices. ==== +* + DO 30 I = INFQR + 1, NS + IFST = I + DO 20 J = I + 1, NS + IF( CABS1( T( J, J ) ).GT.CABS1( T( IFST, IFST ) ) ) + $ IFST = J + 20 CONTINUE + ILST = I + IF( IFST.NE.ILST ) + $ CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO ) + 30 CONTINUE + END IF +* +* ==== Restore shift/eigenvalue array from T ==== +* + DO 40 I = INFQR + 1, JW + SH( KWTOP+I-1 ) = T( I, I ) + 40 CONTINUE +* +* + IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN + IF( NS.GT.1 .AND. S.NE.ZERO ) THEN +* +* ==== Reflect spike back into lower triangle ==== +* + CALL ZCOPY( NS, V, LDV, WORK, 1 ) + DO 50 I = 1, NS + WORK( I ) = DCONJG( WORK( I ) ) + 50 CONTINUE + BETA = WORK( 1 ) + CALL ZLARFG( NS, BETA, WORK( 2 ), 1, TAU ) + WORK( 1 ) = ONE +* + CALL ZLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT ) +* + CALL ZLARF( 'L', NS, JW, WORK, 1, DCONJG( TAU ), T, LDT, + $ WORK( JW+1 ) ) + CALL ZLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT, + $ WORK( JW+1 ) ) + CALL ZLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV, + $ WORK( JW+1 ) ) +* + CALL ZGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), + $ LWORK-JW, INFO ) + END IF +* +* ==== Copy updated reduced window into place ==== +* + IF( KWTOP.GT.1 ) + $ H( KWTOP, KWTOP-1 ) = S*DCONJG( V( 1, 1 ) ) + CALL ZLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH ) + CALL ZCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ), + $ LDH+1 ) +* +* ==== Accumulate orthogonal matrix in order update +* . H and Z, if requested. ==== +* + IF( NS.GT.1 .AND. S.NE.ZERO ) + $ CALL ZUNMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV, + $ WORK( JW+1 ), LWORK-JW, INFO ) +* +* ==== Update vertical slab in H ==== +* + IF( WANTT ) THEN + LTOP = 1 + ELSE + LTOP = KTOP + END IF + DO 60 KROW = LTOP, KWTOP - 1, NV + KLN = MIN( NV, KWTOP-KROW ) + CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ), + $ LDH, V, LDV, ZERO, WV, LDWV ) + CALL ZLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH ) + 60 CONTINUE +* +* ==== Update horizontal slab in H ==== +* + IF( WANTT ) THEN + DO 70 KCOL = KBOT + 1, N, NH + KLN = MIN( NH, N-KCOL+1 ) + CALL ZGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV, + $ H( KWTOP, KCOL ), LDH, ZERO, T, LDT ) + CALL ZLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ), + $ LDH ) + 70 CONTINUE + END IF +* +* ==== Update vertical slab in Z ==== +* + IF( WANTZ ) THEN + DO 80 KROW = ILOZ, IHIZ, NV + KLN = MIN( NV, IHIZ-KROW+1 ) + CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ), + $ LDZ, V, LDV, ZERO, WV, LDWV ) + CALL ZLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ), + $ LDZ ) + 80 CONTINUE + END IF + END IF +* +* ==== Return the number of deflations ... ==== +* + ND = JW - NS +* +* ==== ... and the number of shifts. (Subtracting +* . INFQR from the spike length takes care +* . of the case of a rare QR failure while +* . calculating eigenvalues of the deflation +* . window.) ==== +* + NS = NS - INFQR +* +* ==== Return optimal workspace. ==== +* + WORK( 1 ) = DCMPLX( LWKOPT, 0 ) +* +* ==== End of ZLAQR3 ==== +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/complex16/zlaqr4.f b/fortran_implementation/external_libraries/lapack_routines/complex16/zlaqr4.f new file mode 100644 index 0000000..b5209e8 --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/complex16/zlaqr4.f @@ -0,0 +1,599 @@ + SUBROUTINE ZLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, + $ IHIZ, Z, LDZ, WORK, LWORK, INFO ) +* +* -- LAPACK auxiliary routine (version 3.2) -- +* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* This subroutine implements one level of recursion for ZLAQR0. +* It is a complete implementation of the small bulge multi-shift +* QR algorithm. It may be called by ZLAQR0 and, for large enough +* deflation window size, it may be called by ZLAQR3. This +* subroutine is identical to ZLAQR0 except that it calls ZLAQR2 +* instead of ZLAQR3. +* +* Purpose +* ======= +* +* ZLAQR4 computes the eigenvalues of a Hessenberg matrix H +* and, optionally, the matrices T and Z from the Schur decomposition +* H = Z T Z**H, where T is an upper triangular matrix (the +* Schur form), and Z is the unitary matrix of Schur vectors. +* +* Optionally Z may be postmultiplied into an input unitary +* matrix Q so that this routine can give the Schur factorization +* of a matrix A which has been reduced to the Hessenberg form H +* by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H. +* +* Arguments +* ========= +* +* WANTT (input) LOGICAL +* = .TRUE. : the full Schur form T is required; +* = .FALSE.: only eigenvalues are required. +* +* WANTZ (input) LOGICAL +* = .TRUE. : the matrix of Schur vectors Z is required; +* = .FALSE.: Schur vectors are not required. +* +* N (input) INTEGER +* The order of the matrix H. N .GE. 0. +* +* ILO (input) INTEGER +* IHI (input) INTEGER +* It is assumed that H is already upper triangular in rows +* and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1, +* H(ILO,ILO-1) is zero. ILO and IHI are normally set by a +* previous call to ZGEBAL, and then passed to ZGEHRD when the +* matrix output by ZGEBAL is reduced to Hessenberg form. +* Otherwise, ILO and IHI should be set to 1 and N, +* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. +* If N = 0, then ILO = 1 and IHI = 0. +* +* H (input/output) COMPLEX*16 array, dimension (LDH,N) +* On entry, the upper Hessenberg matrix H. +* On exit, if INFO = 0 and WANTT is .TRUE., then H +* contains the upper triangular matrix T from the Schur +* decomposition (the Schur form). If INFO = 0 and WANT is +* .FALSE., then the contents of H are unspecified on exit. +* (The output value of H when INFO.GT.0 is given under the +* description of INFO below.) +* +* This subroutine may explicitly set H(i,j) = 0 for i.GT.j and +* j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. +* +* LDH (input) INTEGER +* The leading dimension of the array H. LDH .GE. max(1,N). +* +* W (output) COMPLEX*16 array, dimension (N) +* The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored +* in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are +* stored in the same order as on the diagonal of the Schur +* form returned in H, with W(i) = H(i,i). +* +* Z (input/output) COMPLEX*16 array, dimension (LDZ,IHI) +* If WANTZ is .FALSE., then Z is not referenced. +* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is +* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the +* orthogonal Schur factor of H(ILO:IHI,ILO:IHI). +* (The output value of Z when INFO.GT.0 is given under +* the description of INFO below.) +* +* LDZ (input) INTEGER +* The leading dimension of the array Z. if WANTZ is .TRUE. +* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. +* +* WORK (workspace/output) COMPLEX*16 array, dimension LWORK +* On exit, if LWORK = -1, WORK(1) returns an estimate of +* the optimal value for LWORK. +* +* LWORK (input) INTEGER +* The dimension of the array WORK. LWORK .GE. max(1,N) +* is sufficient, but LWORK typically as large as 6*N may +* be required for optimal performance. A workspace query +* to determine the optimal workspace size is recommended. +* +* If LWORK = -1, then ZLAQR4 does a workspace query. +* In this case, ZLAQR4 checks the input parameters and +* estimates the optimal workspace size for the given +* values of N, ILO and IHI. The estimate is returned +* in WORK(1). No error message related to LWORK is +* issued by XERBLA. Neither H nor Z are accessed. +* +* +* INFO (output) INTEGER +* = 0: successful exit +* .GT. 0: if INFO = i, ZLAQR4 failed to compute all of +* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR +* and WI contain those eigenvalues which have been +* successfully computed. (Failures are rare.) +* +* If INFO .GT. 0 and WANT is .FALSE., then on exit, +* the remaining unconverged eigenvalues are the eigen- +* values of the upper Hessenberg matrix rows and +* columns ILO through INFO of the final, output +* value of H. +* +* If INFO .GT. 0 and WANTT is .TRUE., then on exit +* +* (*) (initial value of H)*U = U*(final value of H) +* +* where U is a unitary matrix. The final +* value of H is upper Hessenberg and triangular in +* rows and columns INFO+1 through IHI. +* +* If INFO .GT. 0 and WANTZ is .TRUE., then on exit +* +* (final value of Z(ILO:IHI,ILOZ:IHIZ) +* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U +* +* where U is the unitary matrix in (*) (regard- +* less of the value of WANTT.) +* +* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not +* accessed. +* +* ================================================================ +* Based on contributions by +* Karen Braman and Ralph Byers, Department of Mathematics, +* University of Kansas, USA +* +* ================================================================ +* References: +* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR +* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 +* Performance, SIAM Journal of Matrix Analysis, volume 23, pages +* 929--947, 2002. +* +* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR +* Algorithm Part II: Aggressive Early Deflation, SIAM Journal +* of Matrix Analysis, volume 23, pages 948--973, 2002. +* +* ================================================================ +* .. Parameters .. +* +* ==== Matrices of order NTINY or smaller must be processed by +* . ZLAHQR because of insufficient subdiagonal scratch space. +* . (This is a hard limit.) ==== + INTEGER NTINY + PARAMETER ( NTINY = 11 ) +* +* ==== Exceptional deflation windows: try to cure rare +* . slow convergence by varying the size of the +* . deflation window after KEXNW iterations. ==== + INTEGER KEXNW + PARAMETER ( KEXNW = 5 ) +* +* ==== Exceptional shifts: try to cure rare slow convergence +* . with ad-hoc exceptional shifts every KEXSH iterations. +* . ==== + INTEGER KEXSH + PARAMETER ( KEXSH = 6 ) +* +* ==== The constant WILK1 is used to form the exceptional +* . shifts. ==== + DOUBLE PRECISION WILK1 + PARAMETER ( WILK1 = 0.75d0 ) + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), + $ ONE = ( 1.0d0, 0.0d0 ) ) + DOUBLE PRECISION TWO + PARAMETER ( TWO = 2.0d0 ) +* .. +* .. Local Scalars .. + COMPLEX*16 AA, BB, CC, CDUM, DD, DET, RTDISC, SWAP, TR2 + DOUBLE PRECISION S + INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS, + $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS, + $ LWKOPT, NDEC, NDFL, NH, NHO, NIBBLE, NMIN, NS, + $ NSMAX, NSR, NVE, NW, NWMAX, NWR, NWUPBD + LOGICAL SORTED + CHARACTER JBCMPZ*2 +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Local Arrays .. + COMPLEX*16 ZDUM( 1, 1 ) +* .. +* .. External Subroutines .. + EXTERNAL ZLACPY, ZLAHQR, ZLAQR2, ZLAQR5 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCMPLX, DIMAG, INT, MAX, MIN, MOD, + $ SQRT +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) +* .. +* .. Executable Statements .. + INFO = 0 +* +* ==== Quick return for N = 0: nothing to do. ==== +* + IF( N.EQ.0 ) THEN + WORK( 1 ) = ONE + RETURN + END IF +* + IF( N.LE.NTINY ) THEN +* +* ==== Tiny matrices must use ZLAHQR. ==== +* + LWKOPT = 1 + IF( LWORK.NE.-1 ) + $ CALL ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, + $ IHIZ, Z, LDZ, INFO ) + ELSE +* +* ==== Use small bulge multi-shift QR with aggressive early +* . deflation on larger-than-tiny matrices. ==== +* +* ==== Hope for the best. ==== +* + INFO = 0 +* +* ==== Set up job flags for ILAENV. ==== +* + IF( WANTT ) THEN + JBCMPZ( 1: 1 ) = 'S' + ELSE + JBCMPZ( 1: 1 ) = 'E' + END IF + IF( WANTZ ) THEN + JBCMPZ( 2: 2 ) = 'V' + ELSE + JBCMPZ( 2: 2 ) = 'N' + END IF +* +* ==== NWR = recommended deflation window size. At this +* . point, N .GT. NTINY = 11, so there is enough +* . subdiagonal workspace for NWR.GE.2 as required. +* . (In fact, there is enough subdiagonal space for +* . NWR.GE.3.) ==== +* + NWR = ILAENV( 13, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) + NWR = MAX( 2, NWR ) + NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR ) +* +* ==== NSR = recommended number of simultaneous shifts. +* . At this point N .GT. NTINY = 11, so there is at +* . enough subdiagonal workspace for NSR to be even +* . and greater than or equal to two as required. ==== +* + NSR = ILAENV( 15, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) + NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO ) + NSR = MAX( 2, NSR-MOD( NSR, 2 ) ) +* +* ==== Estimate optimal workspace ==== +* +* ==== Workspace query call to ZLAQR2 ==== +* + CALL ZLAQR2( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, LS, LD, W, H, LDH, N, H, LDH, N, H, + $ LDH, WORK, -1 ) +* +* ==== Optimal workspace = MAX(ZLAQR5, ZLAQR2) ==== +* + LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) ) +* +* ==== Quick return in case of workspace query. ==== +* + IF( LWORK.EQ.-1 ) THEN + WORK( 1 ) = DCMPLX( LWKOPT, 0 ) + RETURN + END IF +* +* ==== ZLAHQR/ZLAQR0 crossover point ==== +* + NMIN = ILAENV( 12, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) + NMIN = MAX( NTINY, NMIN ) +* +* ==== Nibble crossover point ==== +* + NIBBLE = ILAENV( 14, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) + NIBBLE = MAX( 0, NIBBLE ) +* +* ==== Accumulate reflections during ttswp? Use block +* . 2-by-2 structure during matrix-matrix multiply? ==== +* + KACC22 = ILAENV( 16, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) + KACC22 = MAX( 0, KACC22 ) + KACC22 = MIN( 2, KACC22 ) +* +* ==== NWMAX = the largest possible deflation window for +* . which there is sufficient workspace. ==== +* + NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 ) + NW = NWMAX +* +* ==== NSMAX = the Largest number of simultaneous shifts +* . for which there is sufficient workspace. ==== +* + NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 ) + NSMAX = NSMAX - MOD( NSMAX, 2 ) +* +* ==== NDFL: an iteration count restarted at deflation. ==== +* + NDFL = 1 +* +* ==== ITMAX = iteration limit ==== +* + ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) ) +* +* ==== Last row and column in the active block ==== +* + KBOT = IHI +* +* ==== Main Loop ==== +* + DO 70 IT = 1, ITMAX +* +* ==== Done when KBOT falls below ILO ==== +* + IF( KBOT.LT.ILO ) + $ GO TO 80 +* +* ==== Locate active block ==== +* + DO 10 K = KBOT, ILO + 1, -1 + IF( H( K, K-1 ).EQ.ZERO ) + $ GO TO 20 + 10 CONTINUE + K = ILO + 20 CONTINUE + KTOP = K +* +* ==== Select deflation window size: +* . Typical Case: +* . If possible and advisable, nibble the entire +* . active block. If not, use size MIN(NWR,NWMAX) +* . or MIN(NWR+1,NWMAX) depending upon which has +* . the smaller corresponding subdiagonal entry +* . (a heuristic). +* . +* . Exceptional Case: +* . If there have been no deflations in KEXNW or +* . more iterations, then vary the deflation window +* . size. At first, because, larger windows are, +* . in general, more powerful than smaller ones, +* . rapidly increase the window to the maximum possible. +* . Then, gradually reduce the window size. ==== +* + NH = KBOT - KTOP + 1 + NWUPBD = MIN( NH, NWMAX ) + IF( NDFL.LT.KEXNW ) THEN + NW = MIN( NWUPBD, NWR ) + ELSE + NW = MIN( NWUPBD, 2*NW ) + END IF + IF( NW.LT.NWMAX ) THEN + IF( NW.GE.NH-1 ) THEN + NW = NH + ELSE + KWTOP = KBOT - NW + 1 + IF( CABS1( H( KWTOP, KWTOP-1 ) ).GT. + $ CABS1( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 + END IF + END IF + IF( NDFL.LT.KEXNW ) THEN + NDEC = -1 + ELSE IF( NDEC.GE.0 .OR. NW.GE.NWUPBD ) THEN + NDEC = NDEC + 1 + IF( NW-NDEC.LT.2 ) + $ NDEC = 0 + NW = NW - NDEC + END IF +* +* ==== Aggressive early deflation: +* . split workspace under the subdiagonal into +* . - an nw-by-nw work array V in the lower +* . left-hand-corner, +* . - an NW-by-at-least-NW-but-more-is-better +* . (NW-by-NHO) horizontal work array along +* . the bottom edge, +* . - an at-least-NW-but-more-is-better (NHV-by-NW) +* . vertical work array along the left-hand-edge. +* . ==== +* + KV = N - NW + 1 + KT = NW + 1 + NHO = ( N-NW-1 ) - KT + 1 + KWV = NW + 2 + NVE = ( N-NW ) - KWV + 1 +* +* ==== Aggressive early deflation ==== +* + CALL ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, LS, LD, W, H( KV, 1 ), LDH, NHO, + $ H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH, WORK, + $ LWORK ) +* +* ==== Adjust KBOT accounting for new deflations. ==== +* + KBOT = KBOT - LD +* +* ==== KS points to the shifts. ==== +* + KS = KBOT - LS + 1 +* +* ==== Skip an expensive QR sweep if there is a (partly +* . heuristic) reason to expect that many eigenvalues +* . will deflate without it. Here, the QR sweep is +* . skipped if many eigenvalues have just been deflated +* . or if the remaining active block is small. +* + IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT- + $ KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN +* +* ==== NS = nominal number of simultaneous shifts. +* . This may be lowered (slightly) if ZLAQR2 +* . did not provide that many shifts. ==== +* + NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) ) + NS = NS - MOD( NS, 2 ) +* +* ==== If there have been no deflations +* . in a multiple of KEXSH iterations, +* . then try exceptional shifts. +* . Otherwise use shifts provided by +* . ZLAQR2 above or from the eigenvalues +* . of a trailing principal submatrix. ==== +* + IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN + KS = KBOT - NS + 1 + DO 30 I = KBOT, KS + 1, -2 + W( I ) = H( I, I ) + WILK1*CABS1( H( I, I-1 ) ) + W( I-1 ) = W( I ) + 30 CONTINUE + ELSE +* +* ==== Got NS/2 or fewer shifts? Use ZLAHQR +* . on a trailing principal submatrix to +* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, +* . there is enough space below the subdiagonal +* . to fit an NS-by-NS scratch array.) ==== +* + IF( KBOT-KS+1.LE.NS / 2 ) THEN + KS = KBOT - NS + 1 + KT = N - NS + 1 + CALL ZLACPY( 'A', NS, NS, H( KS, KS ), LDH, + $ H( KT, 1 ), LDH ) + CALL ZLAHQR( .false., .false., NS, 1, NS, + $ H( KT, 1 ), LDH, W( KS ), 1, 1, ZDUM, + $ 1, INF ) + KS = KS + INF +* +* ==== In case of a rare QR failure use +* . eigenvalues of the trailing 2-by-2 +* . principal submatrix. Scale to avoid +* . overflows, underflows and subnormals. +* . (The scale factor S can not be zero, +* . because H(KBOT,KBOT-1) is nonzero.) ==== +* + IF( KS.GE.KBOT ) THEN + S = CABS1( H( KBOT-1, KBOT-1 ) ) + + $ CABS1( H( KBOT, KBOT-1 ) ) + + $ CABS1( H( KBOT-1, KBOT ) ) + + $ CABS1( H( KBOT, KBOT ) ) + AA = H( KBOT-1, KBOT-1 ) / S + CC = H( KBOT, KBOT-1 ) / S + BB = H( KBOT-1, KBOT ) / S + DD = H( KBOT, KBOT ) / S + TR2 = ( AA+DD ) / TWO + DET = ( AA-TR2 )*( DD-TR2 ) - BB*CC + RTDISC = SQRT( -DET ) + W( KBOT-1 ) = ( TR2+RTDISC )*S + W( KBOT ) = ( TR2-RTDISC )*S +* + KS = KBOT - 1 + END IF + END IF +* + IF( KBOT-KS+1.GT.NS ) THEN +* +* ==== Sort the shifts (Helps a little) ==== +* + SORTED = .false. + DO 50 K = KBOT, KS + 1, -1 + IF( SORTED ) + $ GO TO 60 + SORTED = .true. + DO 40 I = KS, K - 1 + IF( CABS1( W( I ) ).LT.CABS1( W( I+1 ) ) ) + $ THEN + SORTED = .false. + SWAP = W( I ) + W( I ) = W( I+1 ) + W( I+1 ) = SWAP + END IF + 40 CONTINUE + 50 CONTINUE + 60 CONTINUE + END IF + END IF +* +* ==== If there are only two shifts, then use +* . only one. ==== +* + IF( KBOT-KS+1.EQ.2 ) THEN + IF( CABS1( W( KBOT )-H( KBOT, KBOT ) ).LT. + $ CABS1( W( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN + W( KBOT-1 ) = W( KBOT ) + ELSE + W( KBOT ) = W( KBOT-1 ) + END IF + END IF +* +* ==== Use up to NS of the the smallest magnatiude +* . shifts. If there aren't NS shifts available, +* . then use them all, possibly dropping one to +* . make the number of shifts even. ==== +* + NS = MIN( NS, KBOT-KS+1 ) + NS = NS - MOD( NS, 2 ) + KS = KBOT - NS + 1 +* +* ==== Small-bulge multi-shift QR sweep: +* . split workspace under the subdiagonal into +* . - a KDU-by-KDU work array U in the lower +* . left-hand-corner, +* . - a KDU-by-at-least-KDU-but-more-is-better +* . (KDU-by-NHo) horizontal work array WH along +* . the bottom edge, +* . - and an at-least-KDU-but-more-is-better-by-KDU +* . (NVE-by-KDU) vertical work WV arrow along +* . the left-hand-edge. ==== +* + KDU = 3*NS - 3 + KU = N - KDU + 1 + KWH = KDU + 1 + NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1 + KWV = KDU + 4 + NVE = N - KDU - KWV + 1 +* +* ==== Small-bulge multi-shift QR sweep ==== +* + CALL ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS, + $ W( KS ), H, LDH, ILOZ, IHIZ, Z, LDZ, WORK, + $ 3, H( KU, 1 ), LDH, NVE, H( KWV, 1 ), LDH, + $ NHO, H( KU, KWH ), LDH ) + END IF +* +* ==== Note progress (or the lack of it). ==== +* + IF( LD.GT.0 ) THEN + NDFL = 1 + ELSE + NDFL = NDFL + 1 + END IF +* +* ==== End of main loop ==== + 70 CONTINUE +* +* ==== Iteration limit exceeded. Set INFO to show where +* . the problem occurred and exit. ==== +* + INFO = KBOT + 80 CONTINUE + END IF +* +* ==== Return the optimal value of LWORK. ==== +* + WORK( 1 ) = DCMPLX( LWKOPT, 0 ) +* +* ==== End of ZLAQR4 ==== +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/complex16/zlaqr5.f b/fortran_implementation/external_libraries/lapack_routines/complex16/zlaqr5.f new file mode 100644 index 0000000..15c8b11 --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/complex16/zlaqr5.f @@ -0,0 +1,777 @@ + SUBROUTINE ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, S, + $ H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, LDU, NV, + $ WV, LDWV, NH, WH, LDWH ) +* +* -- LAPACK auxiliary routine (version 3.3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. +* November 2010 +* +* .. Scalar Arguments .. + INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV, + $ LDWH, LDWV, LDZ, N, NH, NSHFTS, NV + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + COMPLEX*16 H( LDH, * ), S( * ), U( LDU, * ), V( LDV, * ), + $ WH( LDWH, * ), WV( LDWV, * ), Z( LDZ, * ) +* .. +* +* This auxiliary subroutine called by ZLAQR0 performs a +* single small-bulge multi-shift QR sweep. +* +* WANTT (input) logical scalar +* WANTT = .true. if the triangular Schur factor +* is being computed. WANTT is set to .false. otherwise. +* +* WANTZ (input) logical scalar +* WANTZ = .true. if the unitary Schur factor is being +* computed. WANTZ is set to .false. otherwise. +* +* KACC22 (input) integer with value 0, 1, or 2. +* Specifies the computation mode of far-from-diagonal +* orthogonal updates. +* = 0: ZLAQR5 does not accumulate reflections and does not +* use matrix-matrix multiply to update far-from-diagonal +* matrix entries. +* = 1: ZLAQR5 accumulates reflections and uses matrix-matrix +* multiply to update the far-from-diagonal matrix entries. +* = 2: ZLAQR5 accumulates reflections, uses matrix-matrix +* multiply to update the far-from-diagonal matrix entries, +* and takes advantage of 2-by-2 block structure during +* matrix multiplies. +* +* N (input) integer scalar +* N is the order of the Hessenberg matrix H upon which this +* subroutine operates. +* +* KTOP (input) integer scalar +* KBOT (input) integer scalar +* These are the first and last rows and columns of an +* isolated diagonal block upon which the QR sweep is to be +* applied. It is assumed without a check that +* either KTOP = 1 or H(KTOP,KTOP-1) = 0 +* and +* either KBOT = N or H(KBOT+1,KBOT) = 0. +* +* NSHFTS (input) integer scalar +* NSHFTS gives the number of simultaneous shifts. NSHFTS +* must be positive and even. +* +* S (input/output) COMPLEX*16 array of size (NSHFTS) +* S contains the shifts of origin that define the multi- +* shift QR sweep. On output S may be reordered. +* +* H (input/output) COMPLEX*16 array of size (LDH,N) +* On input H contains a Hessenberg matrix. On output a +* multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied +* to the isolated diagonal block in rows and columns KTOP +* through KBOT. +* +* LDH (input) integer scalar +* LDH is the leading dimension of H just as declared in the +* calling procedure. LDH.GE.MAX(1,N). +* +* ILOZ (input) INTEGER +* IHIZ (input) INTEGER +* Specify the rows of Z to which transformations must be +* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N +* +* Z (input/output) COMPLEX*16 array of size (LDZ,IHI) +* If WANTZ = .TRUE., then the QR Sweep unitary +* similarity transformation is accumulated into +* Z(ILOZ:IHIZ,ILO:IHI) from the right. +* If WANTZ = .FALSE., then Z is unreferenced. +* +* LDZ (input) integer scalar +* LDA is the leading dimension of Z just as declared in +* the calling procedure. LDZ.GE.N. +* +* V (workspace) COMPLEX*16 array of size (LDV,NSHFTS/2) +* +* LDV (input) integer scalar +* LDV is the leading dimension of V as declared in the +* calling procedure. LDV.GE.3. +* +* U (workspace) COMPLEX*16 array of size +* (LDU,3*NSHFTS-3) +* +* LDU (input) integer scalar +* LDU is the leading dimension of U just as declared in the +* in the calling subroutine. LDU.GE.3*NSHFTS-3. +* +* NH (input) integer scalar +* NH is the number of columns in array WH available for +* workspace. NH.GE.1. +* +* WH (workspace) COMPLEX*16 array of size (LDWH,NH) +* +* LDWH (input) integer scalar +* Leading dimension of WH just as declared in the +* calling procedure. LDWH.GE.3*NSHFTS-3. +* +* NV (input) integer scalar +* NV is the number of rows in WV agailable for workspace. +* NV.GE.1. +* +* WV (workspace) COMPLEX*16 array of size +* (LDWV,3*NSHFTS-3) +* +* LDWV (input) integer scalar +* LDWV is the leading dimension of WV as declared in the +* in the calling subroutine. LDWV.GE.NV. +* +* ================================================================ +* Based on contributions by +* Karen Braman and Ralph Byers, Department of Mathematics, +* University of Kansas, USA +* +* ================================================================ +* Reference: +* +* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR +* Algorithm Part I: Maintaining Well Focused Shifts, and +* Level 3 Performance, SIAM Journal of Matrix Analysis, +* volume 23, pages 929--947, 2002. +* +* ================================================================ +* .. Parameters .. + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), + $ ONE = ( 1.0d0, 0.0d0 ) ) + DOUBLE PRECISION RZERO, RONE + PARAMETER ( RZERO = 0.0d0, RONE = 1.0d0 ) +* .. +* .. Local Scalars .. + COMPLEX*16 ALPHA, BETA, CDUM, REFSUM + DOUBLE PRECISION H11, H12, H21, H22, SAFMAX, SAFMIN, SCL, + $ SMLNUM, TST1, TST2, ULP + INTEGER I2, I4, INCOL, J, J2, J4, JBOT, JCOL, JLEN, + $ JROW, JTOP, K, K1, KDU, KMS, KNZ, KRCOL, KZS, + $ M, M22, MBOT, MEND, MSTART, MTOP, NBMPS, NDCOL, + $ NS, NU + LOGICAL ACCUM, BLK22, BMP22 +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. Intrinsic Functions .. +* + INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, MOD +* .. +* .. Local Arrays .. + COMPLEX*16 VT( 3 ) +* .. +* .. External Subroutines .. + EXTERNAL DLABAD, ZGEMM, ZLACPY, ZLAQR1, ZLARFG, ZLASET, + $ ZTRMM +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) +* .. +* .. Executable Statements .. +* +* ==== If there are no shifts, then there is nothing to do. ==== +* + IF( NSHFTS.LT.2 ) + $ RETURN +* +* ==== If the active block is empty or 1-by-1, then there +* . is nothing to do. ==== +* + IF( KTOP.GE.KBOT ) + $ RETURN +* +* ==== NSHFTS is supposed to be even, but if it is odd, +* . then simply reduce it by one. ==== +* + NS = NSHFTS - MOD( NSHFTS, 2 ) +* +* ==== Machine constants for deflation ==== +* + SAFMIN = DLAMCH( 'SAFE MINIMUM' ) + SAFMAX = RONE / SAFMIN + CALL DLABAD( SAFMIN, SAFMAX ) + ULP = DLAMCH( 'PRECISION' ) + SMLNUM = SAFMIN*( DBLE( N ) / ULP ) +* +* ==== Use accumulated reflections to update far-from-diagonal +* . entries ? ==== +* + ACCUM = ( KACC22.EQ.1 ) .OR. ( KACC22.EQ.2 ) +* +* ==== If so, exploit the 2-by-2 block structure? ==== +* + BLK22 = ( NS.GT.2 ) .AND. ( KACC22.EQ.2 ) +* +* ==== clear trash ==== +* + IF( KTOP+2.LE.KBOT ) + $ H( KTOP+2, KTOP ) = ZERO +* +* ==== NBMPS = number of 2-shift bulges in the chain ==== +* + NBMPS = NS / 2 +* +* ==== KDU = width of slab ==== +* + KDU = 6*NBMPS - 3 +* +* ==== Create and chase chains of NBMPS bulges ==== +* + DO 210 INCOL = 3*( 1-NBMPS ) + KTOP - 1, KBOT - 2, 3*NBMPS - 2 + NDCOL = INCOL + KDU + IF( ACCUM ) + $ CALL ZLASET( 'ALL', KDU, KDU, ZERO, ONE, U, LDU ) +* +* ==== Near-the-diagonal bulge chase. The following loop +* . performs the near-the-diagonal part of a small bulge +* . multi-shift QR sweep. Each 6*NBMPS-2 column diagonal +* . chunk extends from column INCOL to column NDCOL +* . (including both column INCOL and column NDCOL). The +* . following loop chases a 3*NBMPS column long chain of +* . NBMPS bulges 3*NBMPS-2 columns to the right. (INCOL +* . may be less than KTOP and and NDCOL may be greater than +* . KBOT indicating phantom columns from which to chase +* . bulges before they are actually introduced or to which +* . to chase bulges beyond column KBOT.) ==== +* + DO 140 KRCOL = INCOL, MIN( INCOL+3*NBMPS-3, KBOT-2 ) +* +* ==== Bulges number MTOP to MBOT are active double implicit +* . shift bulges. There may or may not also be small +* . 2-by-2 bulge, if there is room. The inactive bulges +* . (if any) must wait until the active bulges have moved +* . down the diagonal to make room. The phantom matrix +* . paradigm described above helps keep track. ==== +* + MTOP = MAX( 1, ( ( KTOP-1 )-KRCOL+2 ) / 3+1 ) + MBOT = MIN( NBMPS, ( KBOT-KRCOL ) / 3 ) + M22 = MBOT + 1 + BMP22 = ( MBOT.LT.NBMPS ) .AND. ( KRCOL+3*( M22-1 ) ).EQ. + $ ( KBOT-2 ) +* +* ==== Generate reflections to chase the chain right +* . one column. (The minimum value of K is KTOP-1.) ==== +* + DO 10 M = MTOP, MBOT + K = KRCOL + 3*( M-1 ) + IF( K.EQ.KTOP-1 ) THEN + CALL ZLAQR1( 3, H( KTOP, KTOP ), LDH, S( 2*M-1 ), + $ S( 2*M ), V( 1, M ) ) + ALPHA = V( 1, M ) + CALL ZLARFG( 3, ALPHA, V( 2, M ), 1, V( 1, M ) ) + ELSE + BETA = H( K+1, K ) + V( 2, M ) = H( K+2, K ) + V( 3, M ) = H( K+3, K ) + CALL ZLARFG( 3, BETA, V( 2, M ), 1, V( 1, M ) ) +* +* ==== A Bulge may collapse because of vigilant +* . deflation or destructive underflow. In the +* . underflow case, try the two-small-subdiagonals +* . trick to try to reinflate the bulge. ==== +* + IF( H( K+3, K ).NE.ZERO .OR. H( K+3, K+1 ).NE. + $ ZERO .OR. H( K+3, K+2 ).EQ.ZERO ) THEN +* +* ==== Typical case: not collapsed (yet). ==== +* + H( K+1, K ) = BETA + H( K+2, K ) = ZERO + H( K+3, K ) = ZERO + ELSE +* +* ==== Atypical case: collapsed. Attempt to +* . reintroduce ignoring H(K+1,K) and H(K+2,K). +* . If the fill resulting from the new +* . reflector is too large, then abandon it. +* . Otherwise, use the new one. ==== +* + CALL ZLAQR1( 3, H( K+1, K+1 ), LDH, S( 2*M-1 ), + $ S( 2*M ), VT ) + ALPHA = VT( 1 ) + CALL ZLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) ) + REFSUM = DCONJG( VT( 1 ) )* + $ ( H( K+1, K )+DCONJG( VT( 2 ) )* + $ H( K+2, K ) ) +* + IF( CABS1( H( K+2, K )-REFSUM*VT( 2 ) )+ + $ CABS1( REFSUM*VT( 3 ) ).GT.ULP* + $ ( CABS1( H( K, K ) )+CABS1( H( K+1, + $ K+1 ) )+CABS1( H( K+2, K+2 ) ) ) ) THEN +* +* ==== Starting a new bulge here would +* . create non-negligible fill. Use +* . the old one with trepidation. ==== +* + H( K+1, K ) = BETA + H( K+2, K ) = ZERO + H( K+3, K ) = ZERO + ELSE +* +* ==== Stating a new bulge here would +* . create only negligible fill. +* . Replace the old reflector with +* . the new one. ==== +* + H( K+1, K ) = H( K+1, K ) - REFSUM + H( K+2, K ) = ZERO + H( K+3, K ) = ZERO + V( 1, M ) = VT( 1 ) + V( 2, M ) = VT( 2 ) + V( 3, M ) = VT( 3 ) + END IF + END IF + END IF + 10 CONTINUE +* +* ==== Generate a 2-by-2 reflection, if needed. ==== +* + K = KRCOL + 3*( M22-1 ) + IF( BMP22 ) THEN + IF( K.EQ.KTOP-1 ) THEN + CALL ZLAQR1( 2, H( K+1, K+1 ), LDH, S( 2*M22-1 ), + $ S( 2*M22 ), V( 1, M22 ) ) + BETA = V( 1, M22 ) + CALL ZLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) ) + ELSE + BETA = H( K+1, K ) + V( 2, M22 ) = H( K+2, K ) + CALL ZLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) ) + H( K+1, K ) = BETA + H( K+2, K ) = ZERO + END IF + END IF +* +* ==== Multiply H by reflections from the left ==== +* + IF( ACCUM ) THEN + JBOT = MIN( NDCOL, KBOT ) + ELSE IF( WANTT ) THEN + JBOT = N + ELSE + JBOT = KBOT + END IF + DO 30 J = MAX( KTOP, KRCOL ), JBOT + MEND = MIN( MBOT, ( J-KRCOL+2 ) / 3 ) + DO 20 M = MTOP, MEND + K = KRCOL + 3*( M-1 ) + REFSUM = DCONJG( V( 1, M ) )* + $ ( H( K+1, J )+DCONJG( V( 2, M ) )* + $ H( K+2, J )+DCONJG( V( 3, M ) )*H( K+3, J ) ) + H( K+1, J ) = H( K+1, J ) - REFSUM + H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M ) + H( K+3, J ) = H( K+3, J ) - REFSUM*V( 3, M ) + 20 CONTINUE + 30 CONTINUE + IF( BMP22 ) THEN + K = KRCOL + 3*( M22-1 ) + DO 40 J = MAX( K+1, KTOP ), JBOT + REFSUM = DCONJG( V( 1, M22 ) )* + $ ( H( K+1, J )+DCONJG( V( 2, M22 ) )* + $ H( K+2, J ) ) + H( K+1, J ) = H( K+1, J ) - REFSUM + H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M22 ) + 40 CONTINUE + END IF +* +* ==== Multiply H by reflections from the right. +* . Delay filling in the last row until the +* . vigilant deflation check is complete. ==== +* + IF( ACCUM ) THEN + JTOP = MAX( KTOP, INCOL ) + ELSE IF( WANTT ) THEN + JTOP = 1 + ELSE + JTOP = KTOP + END IF + DO 80 M = MTOP, MBOT + IF( V( 1, M ).NE.ZERO ) THEN + K = KRCOL + 3*( M-1 ) + DO 50 J = JTOP, MIN( KBOT, K+3 ) + REFSUM = V( 1, M )*( H( J, K+1 )+V( 2, M )* + $ H( J, K+2 )+V( 3, M )*H( J, K+3 ) ) + H( J, K+1 ) = H( J, K+1 ) - REFSUM + H( J, K+2 ) = H( J, K+2 ) - + $ REFSUM*DCONJG( V( 2, M ) ) + H( J, K+3 ) = H( J, K+3 ) - + $ REFSUM*DCONJG( V( 3, M ) ) + 50 CONTINUE +* + IF( ACCUM ) THEN +* +* ==== Accumulate U. (If necessary, update Z later +* . with with an efficient matrix-matrix +* . multiply.) ==== +* + KMS = K - INCOL + DO 60 J = MAX( 1, KTOP-INCOL ), KDU + REFSUM = V( 1, M )*( U( J, KMS+1 )+V( 2, M )* + $ U( J, KMS+2 )+V( 3, M )*U( J, KMS+3 ) ) + U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM + U( J, KMS+2 ) = U( J, KMS+2 ) - + $ REFSUM*DCONJG( V( 2, M ) ) + U( J, KMS+3 ) = U( J, KMS+3 ) - + $ REFSUM*DCONJG( V( 3, M ) ) + 60 CONTINUE + ELSE IF( WANTZ ) THEN +* +* ==== U is not accumulated, so update Z +* . now by multiplying by reflections +* . from the right. ==== +* + DO 70 J = ILOZ, IHIZ + REFSUM = V( 1, M )*( Z( J, K+1 )+V( 2, M )* + $ Z( J, K+2 )+V( 3, M )*Z( J, K+3 ) ) + Z( J, K+1 ) = Z( J, K+1 ) - REFSUM + Z( J, K+2 ) = Z( J, K+2 ) - + $ REFSUM*DCONJG( V( 2, M ) ) + Z( J, K+3 ) = Z( J, K+3 ) - + $ REFSUM*DCONJG( V( 3, M ) ) + 70 CONTINUE + END IF + END IF + 80 CONTINUE +* +* ==== Special case: 2-by-2 reflection (if needed) ==== +* + K = KRCOL + 3*( M22-1 ) + IF( BMP22 ) THEN + IF ( V( 1, M22 ).NE.ZERO ) THEN + DO 90 J = JTOP, MIN( KBOT, K+3 ) + REFSUM = V( 1, M22 )*( H( J, K+1 )+V( 2, M22 )* + $ H( J, K+2 ) ) + H( J, K+1 ) = H( J, K+1 ) - REFSUM + H( J, K+2 ) = H( J, K+2 ) - + $ REFSUM*DCONJG( V( 2, M22 ) ) + 90 CONTINUE +* + IF( ACCUM ) THEN + KMS = K - INCOL + DO 100 J = MAX( 1, KTOP-INCOL ), KDU + REFSUM = V( 1, M22 )*( U( J, KMS+1 )+ + $ V( 2, M22 )*U( J, KMS+2 ) ) + U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM + U( J, KMS+2 ) = U( J, KMS+2 ) - + $ REFSUM*DCONJG( V( 2, M22 ) ) + 100 CONTINUE + ELSE IF( WANTZ ) THEN + DO 110 J = ILOZ, IHIZ + REFSUM = V( 1, M22 )*( Z( J, K+1 )+V( 2, M22 )* + $ Z( J, K+2 ) ) + Z( J, K+1 ) = Z( J, K+1 ) - REFSUM + Z( J, K+2 ) = Z( J, K+2 ) - + $ REFSUM*DCONJG( V( 2, M22 ) ) + 110 CONTINUE + END IF + END IF + END IF +* +* ==== Vigilant deflation check ==== +* + MSTART = MTOP + IF( KRCOL+3*( MSTART-1 ).LT.KTOP ) + $ MSTART = MSTART + 1 + MEND = MBOT + IF( BMP22 ) + $ MEND = MEND + 1 + IF( KRCOL.EQ.KBOT-2 ) + $ MEND = MEND + 1 + DO 120 M = MSTART, MEND + K = MIN( KBOT-1, KRCOL+3*( M-1 ) ) +* +* ==== The following convergence test requires that +* . the tradition small-compared-to-nearby-diagonals +* . criterion and the Ahues & Tisseur (LAWN 122, 1997) +* . criteria both be satisfied. The latter improves +* . accuracy in some examples. Falling back on an +* . alternate convergence criterion when TST1 or TST2 +* . is zero (as done here) is traditional but probably +* . unnecessary. ==== +* + IF( H( K+1, K ).NE.ZERO ) THEN + TST1 = CABS1( H( K, K ) ) + CABS1( H( K+1, K+1 ) ) + IF( TST1.EQ.RZERO ) THEN + IF( K.GE.KTOP+1 ) + $ TST1 = TST1 + CABS1( H( K, K-1 ) ) + IF( K.GE.KTOP+2 ) + $ TST1 = TST1 + CABS1( H( K, K-2 ) ) + IF( K.GE.KTOP+3 ) + $ TST1 = TST1 + CABS1( H( K, K-3 ) ) + IF( K.LE.KBOT-2 ) + $ TST1 = TST1 + CABS1( H( K+2, K+1 ) ) + IF( K.LE.KBOT-3 ) + $ TST1 = TST1 + CABS1( H( K+3, K+1 ) ) + IF( K.LE.KBOT-4 ) + $ TST1 = TST1 + CABS1( H( K+4, K+1 ) ) + END IF + IF( CABS1( H( K+1, K ) ).LE.MAX( SMLNUM, ULP*TST1 ) ) + $ THEN + H12 = MAX( CABS1( H( K+1, K ) ), + $ CABS1( H( K, K+1 ) ) ) + H21 = MIN( CABS1( H( K+1, K ) ), + $ CABS1( H( K, K+1 ) ) ) + H11 = MAX( CABS1( H( K+1, K+1 ) ), + $ CABS1( H( K, K )-H( K+1, K+1 ) ) ) + H22 = MIN( CABS1( H( K+1, K+1 ) ), + $ CABS1( H( K, K )-H( K+1, K+1 ) ) ) + SCL = H11 + H12 + TST2 = H22*( H11 / SCL ) +* + IF( TST2.EQ.RZERO .OR. H21*( H12 / SCL ).LE. + $ MAX( SMLNUM, ULP*TST2 ) )H( K+1, K ) = ZERO + END IF + END IF + 120 CONTINUE +* +* ==== Fill in the last row of each bulge. ==== +* + MEND = MIN( NBMPS, ( KBOT-KRCOL-1 ) / 3 ) + DO 130 M = MTOP, MEND + K = KRCOL + 3*( M-1 ) + REFSUM = V( 1, M )*V( 3, M )*H( K+4, K+3 ) + H( K+4, K+1 ) = -REFSUM + H( K+4, K+2 ) = -REFSUM*DCONJG( V( 2, M ) ) + H( K+4, K+3 ) = H( K+4, K+3 ) - + $ REFSUM*DCONJG( V( 3, M ) ) + 130 CONTINUE +* +* ==== End of near-the-diagonal bulge chase. ==== +* + 140 CONTINUE +* +* ==== Use U (if accumulated) to update far-from-diagonal +* . entries in H. If required, use U to update Z as +* . well. ==== +* + IF( ACCUM ) THEN + IF( WANTT ) THEN + JTOP = 1 + JBOT = N + ELSE + JTOP = KTOP + JBOT = KBOT + END IF + IF( ( .NOT.BLK22 ) .OR. ( INCOL.LT.KTOP ) .OR. + $ ( NDCOL.GT.KBOT ) .OR. ( NS.LE.2 ) ) THEN +* +* ==== Updates not exploiting the 2-by-2 block +* . structure of U. K1 and NU keep track of +* . the location and size of U in the special +* . cases of introducing bulges and chasing +* . bulges off the bottom. In these special +* . cases and in case the number of shifts +* . is NS = 2, there is no 2-by-2 block +* . structure to exploit. ==== +* + K1 = MAX( 1, KTOP-INCOL ) + NU = ( KDU-MAX( 0, NDCOL-KBOT ) ) - K1 + 1 +* +* ==== Horizontal Multiply ==== +* + DO 150 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH + JLEN = MIN( NH, JBOT-JCOL+1 ) + CALL ZGEMM( 'C', 'N', NU, JLEN, NU, ONE, U( K1, K1 ), + $ LDU, H( INCOL+K1, JCOL ), LDH, ZERO, WH, + $ LDWH ) + CALL ZLACPY( 'ALL', NU, JLEN, WH, LDWH, + $ H( INCOL+K1, JCOL ), LDH ) + 150 CONTINUE +* +* ==== Vertical multiply ==== +* + DO 160 JROW = JTOP, MAX( KTOP, INCOL ) - 1, NV + JLEN = MIN( NV, MAX( KTOP, INCOL )-JROW ) + CALL ZGEMM( 'N', 'N', JLEN, NU, NU, ONE, + $ H( JROW, INCOL+K1 ), LDH, U( K1, K1 ), + $ LDU, ZERO, WV, LDWV ) + CALL ZLACPY( 'ALL', JLEN, NU, WV, LDWV, + $ H( JROW, INCOL+K1 ), LDH ) + 160 CONTINUE +* +* ==== Z multiply (also vertical) ==== +* + IF( WANTZ ) THEN + DO 170 JROW = ILOZ, IHIZ, NV + JLEN = MIN( NV, IHIZ-JROW+1 ) + CALL ZGEMM( 'N', 'N', JLEN, NU, NU, ONE, + $ Z( JROW, INCOL+K1 ), LDZ, U( K1, K1 ), + $ LDU, ZERO, WV, LDWV ) + CALL ZLACPY( 'ALL', JLEN, NU, WV, LDWV, + $ Z( JROW, INCOL+K1 ), LDZ ) + 170 CONTINUE + END IF + ELSE +* +* ==== Updates exploiting U's 2-by-2 block structure. +* . (I2, I4, J2, J4 are the last rows and columns +* . of the blocks.) ==== +* + I2 = ( KDU+1 ) / 2 + I4 = KDU + J2 = I4 - I2 + J4 = KDU +* +* ==== KZS and KNZ deal with the band of zeros +* . along the diagonal of one of the triangular +* . blocks. ==== +* + KZS = ( J4-J2 ) - ( NS+1 ) + KNZ = NS + 1 +* +* ==== Horizontal multiply ==== +* + DO 180 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH + JLEN = MIN( NH, JBOT-JCOL+1 ) +* +* ==== Copy bottom of H to top+KZS of scratch ==== +* (The first KZS rows get multiplied by zero.) ==== +* + CALL ZLACPY( 'ALL', KNZ, JLEN, H( INCOL+1+J2, JCOL ), + $ LDH, WH( KZS+1, 1 ), LDWH ) +* +* ==== Multiply by U21**H ==== +* + CALL ZLASET( 'ALL', KZS, JLEN, ZERO, ZERO, WH, LDWH ) + CALL ZTRMM( 'L', 'U', 'C', 'N', KNZ, JLEN, ONE, + $ U( J2+1, 1+KZS ), LDU, WH( KZS+1, 1 ), + $ LDWH ) +* +* ==== Multiply top of H by U11**H ==== +* + CALL ZGEMM( 'C', 'N', I2, JLEN, J2, ONE, U, LDU, + $ H( INCOL+1, JCOL ), LDH, ONE, WH, LDWH ) +* +* ==== Copy top of H to bottom of WH ==== +* + CALL ZLACPY( 'ALL', J2, JLEN, H( INCOL+1, JCOL ), LDH, + $ WH( I2+1, 1 ), LDWH ) +* +* ==== Multiply by U21**H ==== +* + CALL ZTRMM( 'L', 'L', 'C', 'N', J2, JLEN, ONE, + $ U( 1, I2+1 ), LDU, WH( I2+1, 1 ), LDWH ) +* +* ==== Multiply by U22 ==== +* + CALL ZGEMM( 'C', 'N', I4-I2, JLEN, J4-J2, ONE, + $ U( J2+1, I2+1 ), LDU, + $ H( INCOL+1+J2, JCOL ), LDH, ONE, + $ WH( I2+1, 1 ), LDWH ) +* +* ==== Copy it back ==== +* + CALL ZLACPY( 'ALL', KDU, JLEN, WH, LDWH, + $ H( INCOL+1, JCOL ), LDH ) + 180 CONTINUE +* +* ==== Vertical multiply ==== +* + DO 190 JROW = JTOP, MAX( INCOL, KTOP ) - 1, NV + JLEN = MIN( NV, MAX( INCOL, KTOP )-JROW ) +* +* ==== Copy right of H to scratch (the first KZS +* . columns get multiplied by zero) ==== +* + CALL ZLACPY( 'ALL', JLEN, KNZ, H( JROW, INCOL+1+J2 ), + $ LDH, WV( 1, 1+KZS ), LDWV ) +* +* ==== Multiply by U21 ==== +* + CALL ZLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, LDWV ) + CALL ZTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE, + $ U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ), + $ LDWV ) +* +* ==== Multiply by U11 ==== +* + CALL ZGEMM( 'N', 'N', JLEN, I2, J2, ONE, + $ H( JROW, INCOL+1 ), LDH, U, LDU, ONE, WV, + $ LDWV ) +* +* ==== Copy left of H to right of scratch ==== +* + CALL ZLACPY( 'ALL', JLEN, J2, H( JROW, INCOL+1 ), LDH, + $ WV( 1, 1+I2 ), LDWV ) +* +* ==== Multiply by U21 ==== +* + CALL ZTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE, + $ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), LDWV ) +* +* ==== Multiply by U22 ==== +* + CALL ZGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE, + $ H( JROW, INCOL+1+J2 ), LDH, + $ U( J2+1, I2+1 ), LDU, ONE, WV( 1, 1+I2 ), + $ LDWV ) +* +* ==== Copy it back ==== +* + CALL ZLACPY( 'ALL', JLEN, KDU, WV, LDWV, + $ H( JROW, INCOL+1 ), LDH ) + 190 CONTINUE +* +* ==== Multiply Z (also vertical) ==== +* + IF( WANTZ ) THEN + DO 200 JROW = ILOZ, IHIZ, NV + JLEN = MIN( NV, IHIZ-JROW+1 ) +* +* ==== Copy right of Z to left of scratch (first +* . KZS columns get multiplied by zero) ==== +* + CALL ZLACPY( 'ALL', JLEN, KNZ, + $ Z( JROW, INCOL+1+J2 ), LDZ, + $ WV( 1, 1+KZS ), LDWV ) +* +* ==== Multiply by U12 ==== +* + CALL ZLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, + $ LDWV ) + CALL ZTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE, + $ U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ), + $ LDWV ) +* +* ==== Multiply by U11 ==== +* + CALL ZGEMM( 'N', 'N', JLEN, I2, J2, ONE, + $ Z( JROW, INCOL+1 ), LDZ, U, LDU, ONE, + $ WV, LDWV ) +* +* ==== Copy left of Z to right of scratch ==== +* + CALL ZLACPY( 'ALL', JLEN, J2, Z( JROW, INCOL+1 ), + $ LDZ, WV( 1, 1+I2 ), LDWV ) +* +* ==== Multiply by U21 ==== +* + CALL ZTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE, + $ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), + $ LDWV ) +* +* ==== Multiply by U22 ==== +* + CALL ZGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE, + $ Z( JROW, INCOL+1+J2 ), LDZ, + $ U( J2+1, I2+1 ), LDU, ONE, + $ WV( 1, 1+I2 ), LDWV ) +* +* ==== Copy the result back to Z ==== +* + CALL ZLACPY( 'ALL', JLEN, KDU, WV, LDWV, + $ Z( JROW, INCOL+1 ), LDZ ) + 200 CONTINUE + END IF + END IF + END IF + 210 CONTINUE +* +* ==== End of ZLAQR5 ==== +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/complex16/zlarf.f b/fortran_implementation/external_libraries/lapack_routines/complex16/zlarf.f new file mode 100644 index 0000000..cdfd222 --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/complex16/zlarf.f @@ -0,0 +1,158 @@ + SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + CHARACTER SIDE + INTEGER INCV, LDC, M, N + COMPLEX*16 TAU +* .. +* .. Array Arguments .. + COMPLEX*16 C( LDC, * ), V( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* ZLARF applies a complex elementary reflector H to a complex M-by-N +* matrix C, from either the left or the right. H is represented in the +* form +* +* H = I - tau * v * v**H +* +* where tau is a complex scalar and v is a complex vector. +* +* If tau = 0, then H is taken to be the unit matrix. +* +* To apply H**H, supply conjg(tau) instead +* tau. +* +* Arguments +* ========= +* +* SIDE (input) CHARACTER*1 +* = 'L': form H * C +* = 'R': form C * H +* +* M (input) INTEGER +* The number of rows of the matrix C. +* +* N (input) INTEGER +* The number of columns of the matrix C. +* +* V (input) COMPLEX*16 array, dimension +* (1 + (M-1)*abs(INCV)) if SIDE = 'L' +* or (1 + (N-1)*abs(INCV)) if SIDE = 'R' +* The vector v in the representation of H. V is not used if +* TAU = 0. +* +* INCV (input) INTEGER +* The increment between elements of v. INCV <> 0. +* +* TAU (input) COMPLEX*16 +* The value tau in the representation of H. +* +* C (input/output) COMPLEX*16 array, dimension (LDC,N) +* On entry, the M-by-N matrix C. +* On exit, C is overwritten by the matrix H * C if SIDE = 'L', +* or C * H if SIDE = 'R'. +* +* LDC (input) INTEGER +* The leading dimension of the array C. LDC >= max(1,M). +* +* WORK (workspace) COMPLEX*16 array, dimension +* (N) if SIDE = 'L' +* or (M) if SIDE = 'R' +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE, ZERO + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), + $ ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL APPLYLEFT + INTEGER I, LASTV, LASTC +* .. +* .. External Subroutines .. + EXTERNAL ZGEMV, ZGERC +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAZLR, ILAZLC + EXTERNAL LSAME, ILAZLR, ILAZLC +* .. +* .. Executable Statements .. +* + APPLYLEFT = LSAME( SIDE, 'L' ) + LASTV = 0 + LASTC = 0 + IF( TAU.NE.ZERO ) THEN +! Set up variables for scanning V. LASTV begins pointing to the end +! of V. + IF( APPLYLEFT ) THEN + LASTV = M + ELSE + LASTV = N + END IF + IF( INCV.GT.0 ) THEN + I = 1 + (LASTV-1) * INCV + ELSE + I = 1 + END IF +! Look for the last non-zero row in V. + DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO ) + LASTV = LASTV - 1 + I = I - INCV + END DO + IF( APPLYLEFT ) THEN +! Scan for the last non-zero column in C(1:lastv,:). + LASTC = ILAZLC(LASTV, N, C, LDC) + ELSE +! Scan for the last non-zero row in C(:,1:lastv). + LASTC = ILAZLR(M, LASTV, C, LDC) + END IF + END IF +! Note that lastc.eq.0 renders the BLAS operations null; no special +! case is needed at this level. + IF( APPLYLEFT ) THEN +* +* Form H * C +* + IF( LASTV.GT.0 ) THEN +* +* w(1:lastc,1) := C(1:lastv,1:lastc)**H * v(1:lastv,1) +* + CALL ZGEMV( 'Conjugate transpose', LASTV, LASTC, ONE, + $ C, LDC, V, INCV, ZERO, WORK, 1 ) +* +* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)**H +* + CALL ZGERC( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC ) + END IF + ELSE +* +* Form C * H +* + IF( LASTV.GT.0 ) THEN +* +* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) +* + CALL ZGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC, + $ V, INCV, ZERO, WORK, 1 ) +* +* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)**H +* + CALL ZGERC( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC ) + END IF + END IF + RETURN +* +* End of ZLARF +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/complex16/zlarfb.f b/fortran_implementation/external_libraries/lapack_routines/complex16/zlarfb.f new file mode 100644 index 0000000..ec42de0 --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/complex16/zlarfb.f @@ -0,0 +1,678 @@ + SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, + $ T, LDT, C, LDC, WORK, LDWORK ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + CHARACTER DIRECT, SIDE, STOREV, TRANS + INTEGER K, LDC, LDT, LDV, LDWORK, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 C( LDC, * ), T( LDT, * ), V( LDV, * ), + $ WORK( LDWORK, * ) +* .. +* +* Purpose +* ======= +* +* ZLARFB applies a complex block reflector H or its transpose H**H to a +* complex M-by-N matrix C, from either the left or the right. +* +* Arguments +* ========= +* +* SIDE (input) CHARACTER*1 +* = 'L': apply H or H**H from the Left +* = 'R': apply H or H**H from the Right +* +* TRANS (input) CHARACTER*1 +* = 'N': apply H (No transpose) +* = 'C': apply H**H (Conjugate transpose) +* +* DIRECT (input) CHARACTER*1 +* Indicates how H is formed from a product of elementary +* reflectors +* = 'F': H = H(1) H(2) . . . H(k) (Forward) +* = 'B': H = H(k) . . . H(2) H(1) (Backward) +* +* STOREV (input) CHARACTER*1 +* Indicates how the vectors which define the elementary +* reflectors are stored: +* = 'C': Columnwise +* = 'R': Rowwise +* +* M (input) INTEGER +* The number of rows of the matrix C. +* +* N (input) INTEGER +* The number of columns of the matrix C. +* +* K (input) INTEGER +* The order of the matrix T (= the number of elementary +* reflectors whose product defines the block reflector). +* +* V (input) COMPLEX*16 array, dimension +* (LDV,K) if STOREV = 'C' +* (LDV,M) if STOREV = 'R' and SIDE = 'L' +* (LDV,N) if STOREV = 'R' and SIDE = 'R' +* The matrix V. See Further Details. +* +* LDV (input) INTEGER +* The leading dimension of the array V. +* If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); +* if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); +* if STOREV = 'R', LDV >= K. +* +* T (input) COMPLEX*16 array, dimension (LDT,K) +* The triangular K-by-K matrix T in the representation of the +* block reflector. +* +* LDT (input) INTEGER +* The leading dimension of the array T. LDT >= K. +* +* C (input/output) COMPLEX*16 array, dimension (LDC,N) +* On entry, the M-by-N matrix C. +* On exit, C is overwritten by H*C or H**H*C or C*H or C*H**H. +* +* LDC (input) INTEGER +* The leading dimension of the array C. LDC >= max(1,M). +* +* WORK (workspace) COMPLEX*16 array, dimension (LDWORK,K) +* +* LDWORK (input) INTEGER +* The leading dimension of the array WORK. +* If SIDE = 'L', LDWORK >= max(1,N); +* if SIDE = 'R', LDWORK >= max(1,M). +* +* Further Details +* =============== +* +* The shape of the matrix V and the storage of the vectors which define +* the H(i) is best illustrated by the following example with n = 5 and +* k = 3. The elements equal to 1 are not stored; the corresponding +* array elements are modified but restored on exit. The rest of the +* array is not used. +* +* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': +* +* V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) +* ( v1 1 ) ( 1 v2 v2 v2 ) +* ( v1 v2 1 ) ( 1 v3 v3 ) +* ( v1 v2 v3 ) +* ( v1 v2 v3 ) +* +* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': +* +* V = ( v1 v2 v3 ) V = ( v1 v1 1 ) +* ( v1 v2 v3 ) ( v2 v2 v2 1 ) +* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) +* ( 1 v3 ) +* ( 1 ) +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + CHARACTER TRANST + INTEGER I, J, LASTV, LASTC +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAZLR, ILAZLC + EXTERNAL LSAME, ILAZLR, ILAZLC +* .. +* .. External Subroutines .. + EXTERNAL ZCOPY, ZGEMM, ZLACGV, ZTRMM +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( M.LE.0 .OR. N.LE.0 ) + $ RETURN +* + IF( LSAME( TRANS, 'N' ) ) THEN + TRANST = 'C' + ELSE + TRANST = 'N' + END IF +* + IF( LSAME( STOREV, 'C' ) ) THEN +* + IF( LSAME( DIRECT, 'F' ) ) THEN +* +* Let V = ( V1 ) (first K rows) +* ( V2 ) +* where V1 is unit lower triangular. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H**H * C where C = ( C1 ) +* ( C2 ) +* + LASTV = MAX( K, ILAZLR( M, K, V, LDV ) ) + LASTC = ILAZLC( LASTV, N, C, LDC ) +* +* W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK) +* +* W := C1**H +* + DO 10 J = 1, K + CALL ZCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) + CALL ZLACGV( LASTC, WORK( 1, J ), 1 ) + 10 CONTINUE +* +* W := W * V1 +* + CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', + $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C2**H *V2 +* + CALL ZGEMM( 'Conjugate transpose', 'No transpose', + $ LASTC, K, LASTV-K, ONE, C( K+1, 1 ), LDC, + $ V( K+1, 1 ), LDV, ONE, WORK, LDWORK ) + END IF +* +* W := W * T**H or W * T +* + CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V * W**H +* + IF( M.GT.K ) THEN +* +* C2 := C2 - V2 * W**H +* + CALL ZGEMM( 'No transpose', 'Conjugate transpose', + $ LASTV-K, LASTC, K, + $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, + $ ONE, C( K+1, 1 ), LDC ) + END IF +* +* W := W * V1**H +* + CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', + $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W**H +* + DO 30 J = 1, K + DO 20 I = 1, LASTC + C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) ) + 20 CONTINUE + 30 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H**H where C = ( C1 C2 ) +* + LASTV = MAX( K, ILAZLR( N, K, V, LDV ) ) + LASTC = ILAZLR( M, LASTV, C, LDC ) +* +* W := C * V = (C1*V1 + C2*V2) (stored in WORK) +* +* W := C1 +* + DO 40 J = 1, K + CALL ZCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) + 40 CONTINUE +* +* W := W * V1 +* + CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', + $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C2 * V2 +* + CALL ZGEMM( 'No transpose', 'No transpose', + $ LASTC, K, LASTV-K, + $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T or W * T**H +* + CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V**H +* + IF( LASTV.GT.K ) THEN +* +* C2 := C2 - W * V2**H +* + CALL ZGEMM( 'No transpose', 'Conjugate transpose', + $ LASTC, LASTV-K, K, + $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, + $ ONE, C( 1, K+1 ), LDC ) + END IF +* +* W := W * V1**H +* + CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', + $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W +* + DO 60 J = 1, K + DO 50 I = 1, LASTC + C( I, J ) = C( I, J ) - WORK( I, J ) + 50 CONTINUE + 60 CONTINUE + END IF +* + ELSE +* +* Let V = ( V1 ) +* ( V2 ) (last K rows) +* where V2 is unit upper triangular. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H**H * C where C = ( C1 ) +* ( C2 ) +* + LASTV = MAX( K, ILAZLR( M, K, V, LDV ) ) + LASTC = ILAZLC( LASTV, N, C, LDC ) +* +* W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK) +* +* W := C2**H +* + DO 70 J = 1, K + CALL ZCOPY( LASTC, C( LASTV-K+J, 1 ), LDC, + $ WORK( 1, J ), 1 ) + CALL ZLACGV( LASTC, WORK( 1, J ), 1 ) + 70 CONTINUE +* +* W := W * V2 +* + CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', + $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, + $ WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C1**H*V1 +* + CALL ZGEMM( 'Conjugate transpose', 'No transpose', + $ LASTC, K, LASTV-K, + $ ONE, C, LDC, V, LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T**H or W * T +* + CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V * W**H +* + IF( LASTV.GT.K ) THEN +* +* C1 := C1 - V1 * W**H +* + CALL ZGEMM( 'No transpose', 'Conjugate transpose', + $ LASTV-K, LASTC, K, + $ -ONE, V, LDV, WORK, LDWORK, + $ ONE, C, LDC ) + END IF +* +* W := W * V2**H +* + CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', + $ 'Unit', LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, + $ WORK, LDWORK ) +* +* C2 := C2 - W**H +* + DO 90 J = 1, K + DO 80 I = 1, LASTC + C( LASTV-K+J, I ) = C( LASTV-K+J, I ) - + $ DCONJG( WORK( I, J ) ) + 80 CONTINUE + 90 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H**H where C = ( C1 C2 ) +* + LASTV = MAX( K, ILAZLR( N, K, V, LDV ) ) + LASTC = ILAZLR( M, LASTV, C, LDC ) +* +* W := C * V = (C1*V1 + C2*V2) (stored in WORK) +* +* W := C2 +* + DO 100 J = 1, K + CALL ZCOPY( LASTC, C( 1, LASTV-K+J ), 1, + $ WORK( 1, J ), 1 ) + 100 CONTINUE +* +* W := W * V2 +* + CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', + $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, + $ WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C1 * V1 +* + CALL ZGEMM( 'No transpose', 'No transpose', + $ LASTC, K, LASTV-K, + $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) + END IF +* +* W := W * T or W * T**H +* + CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V**H +* + IF( LASTV.GT.K ) THEN +* +* C1 := C1 - W * V1**H +* + CALL ZGEMM( 'No transpose', 'Conjugate transpose', + $ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV, + $ ONE, C, LDC ) + END IF +* +* W := W * V2**H +* + CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', + $ 'Unit', LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, + $ WORK, LDWORK ) +* +* C2 := C2 - W +* + DO 120 J = 1, K + DO 110 I = 1, LASTC + C( I, LASTV-K+J ) = C( I, LASTV-K+J ) + $ - WORK( I, J ) + 110 CONTINUE + 120 CONTINUE + END IF + END IF +* + ELSE IF( LSAME( STOREV, 'R' ) ) THEN +* + IF( LSAME( DIRECT, 'F' ) ) THEN +* +* Let V = ( V1 V2 ) (V1: first K columns) +* where V1 is unit upper triangular. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H**H * C where C = ( C1 ) +* ( C2 ) +* + LASTV = MAX( K, ILAZLC( K, M, V, LDV ) ) + LASTC = ILAZLC( LASTV, N, C, LDC ) +* +* W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK) +* +* W := C1**H +* + DO 130 J = 1, K + CALL ZCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) + CALL ZLACGV( LASTC, WORK( 1, J ), 1 ) + 130 CONTINUE +* +* W := W * V1**H +* + CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', + $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C2**H*V2**H +* + CALL ZGEMM( 'Conjugate transpose', + $ 'Conjugate transpose', LASTC, K, LASTV-K, + $ ONE, C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T**H or W * T +* + CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V**H * W**H +* + IF( LASTV.GT.K ) THEN +* +* C2 := C2 - V2**H * W**H +* + CALL ZGEMM( 'Conjugate transpose', + $ 'Conjugate transpose', LASTV-K, LASTC, K, + $ -ONE, V( 1, K+1 ), LDV, WORK, LDWORK, + $ ONE, C( K+1, 1 ), LDC ) + END IF +* +* W := W * V1 +* + CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', + $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W**H +* + DO 150 J = 1, K + DO 140 I = 1, LASTC + C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) ) + 140 CONTINUE + 150 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H**H where C = ( C1 C2 ) +* + LASTV = MAX( K, ILAZLC( K, N, V, LDV ) ) + LASTC = ILAZLR( M, LASTV, C, LDC ) +* +* W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK) +* +* W := C1 +* + DO 160 J = 1, K + CALL ZCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) + 160 CONTINUE +* +* W := W * V1**H +* + CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', + $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C2 * V2**H +* + CALL ZGEMM( 'No transpose', 'Conjugate transpose', + $ LASTC, K, LASTV-K, ONE, C( 1, K+1 ), LDC, + $ V( 1, K+1 ), LDV, ONE, WORK, LDWORK ) + END IF +* +* W := W * T or W * T**H +* + CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V +* + IF( LASTV.GT.K ) THEN +* +* C2 := C2 - W * V2 +* + CALL ZGEMM( 'No transpose', 'No transpose', + $ LASTC, LASTV-K, K, + $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, + $ ONE, C( 1, K+1 ), LDC ) + END IF +* +* W := W * V1 +* + CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', + $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W +* + DO 180 J = 1, K + DO 170 I = 1, LASTC + C( I, J ) = C( I, J ) - WORK( I, J ) + 170 CONTINUE + 180 CONTINUE +* + END IF +* + ELSE +* +* Let V = ( V1 V2 ) (V2: last K columns) +* where V2 is unit lower triangular. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H**H * C where C = ( C1 ) +* ( C2 ) +* + LASTV = MAX( K, ILAZLC( K, M, V, LDV ) ) + LASTC = ILAZLC( LASTV, N, C, LDC ) +* +* W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK) +* +* W := C2**H +* + DO 190 J = 1, K + CALL ZCOPY( LASTC, C( LASTV-K+J, 1 ), LDC, + $ WORK( 1, J ), 1 ) + CALL ZLACGV( LASTC, WORK( 1, J ), 1 ) + 190 CONTINUE +* +* W := W * V2**H +* + CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', + $ 'Unit', LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, + $ WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C1**H * V1**H +* + CALL ZGEMM( 'Conjugate transpose', + $ 'Conjugate transpose', LASTC, K, LASTV-K, + $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) + END IF +* +* W := W * T**H or W * T +* + CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V**H * W**H +* + IF( LASTV.GT.K ) THEN +* +* C1 := C1 - V1**H * W**H +* + CALL ZGEMM( 'Conjugate transpose', + $ 'Conjugate transpose', LASTV-K, LASTC, K, + $ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC ) + END IF +* +* W := W * V2 +* + CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', + $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, + $ WORK, LDWORK ) +* +* C2 := C2 - W**H +* + DO 210 J = 1, K + DO 200 I = 1, LASTC + C( LASTV-K+J, I ) = C( LASTV-K+J, I ) - + $ DCONJG( WORK( I, J ) ) + 200 CONTINUE + 210 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H**H where C = ( C1 C2 ) +* + LASTV = MAX( K, ILAZLC( K, N, V, LDV ) ) + LASTC = ILAZLR( M, LASTV, C, LDC ) +* +* W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK) +* +* W := C2 +* + DO 220 J = 1, K + CALL ZCOPY( LASTC, C( 1, LASTV-K+J ), 1, + $ WORK( 1, J ), 1 ) + 220 CONTINUE +* +* W := W * V2**H +* + CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', + $ 'Unit', LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, + $ WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C1 * V1**H +* + CALL ZGEMM( 'No transpose', 'Conjugate transpose', + $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, ONE, + $ WORK, LDWORK ) + END IF +* +* W := W * T or W * T**H +* + CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V +* + IF( LASTV.GT.K ) THEN +* +* C1 := C1 - W * V1 +* + CALL ZGEMM( 'No transpose', 'No transpose', + $ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV, + $ ONE, C, LDC ) + END IF +* +* W := W * V2 +* + CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', + $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, + $ WORK, LDWORK ) +* +* C1 := C1 - W +* + DO 240 J = 1, K + DO 230 I = 1, LASTC + C( I, LASTV-K+J ) = C( I, LASTV-K+J ) + $ - WORK( I, J ) + 230 CONTINUE + 240 CONTINUE +* + END IF +* + END IF + END IF +* + RETURN +* +* End of ZLARFB +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/complex16/zlarfg.f b/fortran_implementation/external_libraries/lapack_routines/complex16/zlarfg.f new file mode 100644 index 0000000..8a28851 --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/complex16/zlarfg.f @@ -0,0 +1,141 @@ + SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU ) +* +* -- LAPACK auxiliary routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + INTEGER INCX, N + COMPLEX*16 ALPHA, TAU +* .. +* .. Array Arguments .. + COMPLEX*16 X( * ) +* .. +* +* Purpose +* ======= +* +* ZLARFG generates a complex elementary reflector H of order n, such +* that +* +* H**H * ( alpha ) = ( beta ), H**H * H = I. +* ( x ) ( 0 ) +* +* where alpha and beta are scalars, with beta real, and x is an +* (n-1)-element complex vector. H is represented in the form +* +* H = I - tau * ( 1 ) * ( 1 v**H ) , +* ( v ) +* +* where tau is a complex scalar and v is a complex (n-1)-element +* vector. Note that H is not hermitian. +* +* If the elements of x are all zero and alpha is real, then tau = 0 +* and H is taken to be the unit matrix. +* +* Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 . +* +* Arguments +* ========= +* +* N (input) INTEGER +* The order of the elementary reflector. +* +* ALPHA (input/output) COMPLEX*16 +* On entry, the value alpha. +* On exit, it is overwritten with the value beta. +* +* X (input/output) COMPLEX*16 array, dimension +* (1+(N-2)*abs(INCX)) +* On entry, the vector x. +* On exit, it is overwritten with the vector v. +* +* INCX (input) INTEGER +* The increment between elements of X. INCX > 0. +* +* TAU (output) COMPLEX*16 +* The value tau. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER J, KNT + DOUBLE PRECISION ALPHI, ALPHR, BETA, RSAFMN, SAFMIN, XNORM +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DLAPY3, DZNRM2 + COMPLEX*16 ZLADIV + EXTERNAL DLAMCH, DLAPY3, DZNRM2, ZLADIV +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCMPLX, DIMAG, SIGN +* .. +* .. External Subroutines .. + EXTERNAL ZDSCAL, ZSCAL +* .. +* .. Executable Statements .. +* + IF( N.LE.0 ) THEN + TAU = ZERO + RETURN + END IF +* + XNORM = DZNRM2( N-1, X, INCX ) + ALPHR = DBLE( ALPHA ) + ALPHI = DIMAG( ALPHA ) +* + IF( XNORM.EQ.ZERO .AND. ALPHI.EQ.ZERO ) THEN +* +* H = I +* + TAU = ZERO + ELSE +* +* general case +* + BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR ) + SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' ) + RSAFMN = ONE / SAFMIN +* + KNT = 0 + IF( ABS( BETA ).LT.SAFMIN ) THEN +* +* XNORM, BETA may be inaccurate; scale X and recompute them +* + 10 CONTINUE + KNT = KNT + 1 + CALL ZDSCAL( N-1, RSAFMN, X, INCX ) + BETA = BETA*RSAFMN + ALPHI = ALPHI*RSAFMN + ALPHR = ALPHR*RSAFMN + IF( ABS( BETA ).LT.SAFMIN ) + $ GO TO 10 +* +* New BETA is at most 1, at least SAFMIN +* + XNORM = DZNRM2( N-1, X, INCX ) + ALPHA = DCMPLX( ALPHR, ALPHI ) + BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR ) + END IF + TAU = DCMPLX( ( BETA-ALPHR ) / BETA, -ALPHI / BETA ) + ALPHA = ZLADIV( DCMPLX( ONE ), ALPHA-BETA ) + CALL ZSCAL( N-1, ALPHA, X, INCX ) +* +* If ALPHA is subnormal, it may lose relative accuracy +* + DO 20 J = 1, KNT + BETA = BETA*SAFMIN + 20 CONTINUE + ALPHA = BETA + END IF +* + RETURN +* +* End of ZLARFG +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/complex16/zlarft.f b/fortran_implementation/external_libraries/lapack_routines/complex16/zlarft.f new file mode 100644 index 0000000..06d5adb --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/complex16/zlarft.f @@ -0,0 +1,258 @@ + SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) +* +* -- LAPACK auxiliary routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + CHARACTER DIRECT, STOREV + INTEGER K, LDT, LDV, N +* .. +* .. Array Arguments .. + COMPLEX*16 T( LDT, * ), TAU( * ), V( LDV, * ) +* .. +* +* Purpose +* ======= +* +* ZLARFT forms the triangular factor T of a complex block reflector H +* of order n, which is defined as a product of k elementary reflectors. +* +* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; +* +* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. +* +* If STOREV = 'C', the vector which defines the elementary reflector +* H(i) is stored in the i-th column of the array V, and +* +* H = I - V * T * V**H +* +* If STOREV = 'R', the vector which defines the elementary reflector +* H(i) is stored in the i-th row of the array V, and +* +* H = I - V**H * T * V +* +* Arguments +* ========= +* +* DIRECT (input) CHARACTER*1 +* Specifies the order in which the elementary reflectors are +* multiplied to form the block reflector: +* = 'F': H = H(1) H(2) . . . H(k) (Forward) +* = 'B': H = H(k) . . . H(2) H(1) (Backward) +* +* STOREV (input) CHARACTER*1 +* Specifies how the vectors which define the elementary +* reflectors are stored (see also Further Details): +* = 'C': columnwise +* = 'R': rowwise +* +* N (input) INTEGER +* The order of the block reflector H. N >= 0. +* +* K (input) INTEGER +* The order of the triangular factor T (= the number of +* elementary reflectors). K >= 1. +* +* V (input/output) COMPLEX*16 array, dimension +* (LDV,K) if STOREV = 'C' +* (LDV,N) if STOREV = 'R' +* The matrix V. See further details. +* +* LDV (input) INTEGER +* The leading dimension of the array V. +* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. +* +* TAU (input) COMPLEX*16 array, dimension (K) +* TAU(i) must contain the scalar factor of the elementary +* reflector H(i). +* +* T (output) COMPLEX*16 array, dimension (LDT,K) +* The k by k triangular factor T of the block reflector. +* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is +* lower triangular. The rest of the array is not used. +* +* LDT (input) INTEGER +* The leading dimension of the array T. LDT >= K. +* +* Further Details +* =============== +* +* The shape of the matrix V and the storage of the vectors which define +* the H(i) is best illustrated by the following example with n = 5 and +* k = 3. The elements equal to 1 are not stored; the corresponding +* array elements are modified but restored on exit. The rest of the +* array is not used. +* +* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': +* +* V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) +* ( v1 1 ) ( 1 v2 v2 v2 ) +* ( v1 v2 1 ) ( 1 v3 v3 ) +* ( v1 v2 v3 ) +* ( v1 v2 v3 ) +* +* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': +* +* V = ( v1 v2 v3 ) V = ( v1 v1 1 ) +* ( v1 v2 v3 ) ( v2 v2 v2 1 ) +* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) +* ( 1 v3 ) +* ( 1 ) +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE, ZERO + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), + $ ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, J, PREVLASTV, LASTV + COMPLEX*16 VII +* .. +* .. External Subroutines .. + EXTERNAL ZGEMV, ZLACGV, ZTRMV +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( LSAME( DIRECT, 'F' ) ) THEN + PREVLASTV = N + DO 20 I = 1, K + PREVLASTV = MAX( PREVLASTV, I ) + IF( TAU( I ).EQ.ZERO ) THEN +* +* H(i) = I +* + DO 10 J = 1, I + T( J, I ) = ZERO + 10 CONTINUE + ELSE +* +* general case +* + VII = V( I, I ) + V( I, I ) = ONE + IF( LSAME( STOREV, 'C' ) ) THEN +! Skip any trailing zeros. + DO LASTV = N, I+1, -1 + IF( V( LASTV, I ).NE.ZERO ) EXIT + END DO + J = MIN( LASTV, PREVLASTV ) +* +* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**H * V(i:j,i) +* + CALL ZGEMV( 'Conjugate transpose', J-I+1, I-1, + $ -TAU( I ), V( I, 1 ), LDV, V( I, I ), 1, + $ ZERO, T( 1, I ), 1 ) + ELSE +! Skip any trailing zeros. + DO LASTV = N, I+1, -1 + IF( V( I, LASTV ).NE.ZERO ) EXIT + END DO + J = MIN( LASTV, PREVLASTV ) +* +* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**H +* + IF( I.LT.J ) + $ CALL ZLACGV( J-I, V( I, I+1 ), LDV ) + CALL ZGEMV( 'No transpose', I-1, J-I+1, -TAU( I ), + $ V( 1, I ), LDV, V( I, I ), LDV, ZERO, + $ T( 1, I ), 1 ) + IF( I.LT.J ) + $ CALL ZLACGV( J-I, V( I, I+1 ), LDV ) + END IF + V( I, I ) = VII +* +* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) +* + CALL ZTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, + $ LDT, T( 1, I ), 1 ) + T( I, I ) = TAU( I ) + IF( I.GT.1 ) THEN + PREVLASTV = MAX( PREVLASTV, LASTV ) + ELSE + PREVLASTV = LASTV + END IF + END IF + 20 CONTINUE + ELSE + PREVLASTV = 1 + DO 40 I = K, 1, -1 + IF( TAU( I ).EQ.ZERO ) THEN +* +* H(i) = I +* + DO 30 J = I, K + T( J, I ) = ZERO + 30 CONTINUE + ELSE +* +* general case +* + IF( I.LT.K ) THEN + IF( LSAME( STOREV, 'C' ) ) THEN + VII = V( N-K+I, I ) + V( N-K+I, I ) = ONE +! Skip any leading zeros. + DO LASTV = 1, I-1 + IF( V( LASTV, I ).NE.ZERO ) EXIT + END DO + J = MAX( LASTV, PREVLASTV ) +* +* T(i+1:k,i) := +* - tau(i) * V(j:n-k+i,i+1:k)**H * V(j:n-k+i,i) +* + CALL ZGEMV( 'Conjugate transpose', N-K+I-J+1, K-I, + $ -TAU( I ), V( J, I+1 ), LDV, V( J, I ), + $ 1, ZERO, T( I+1, I ), 1 ) + V( N-K+I, I ) = VII + ELSE + VII = V( I, N-K+I ) + V( I, N-K+I ) = ONE +! Skip any leading zeros. + DO LASTV = 1, I-1 + IF( V( I, LASTV ).NE.ZERO ) EXIT + END DO + J = MAX( LASTV, PREVLASTV ) +* +* T(i+1:k,i) := +* - tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**H +* + CALL ZLACGV( N-K+I-1-J+1, V( I, J ), LDV ) + CALL ZGEMV( 'No transpose', K-I, N-K+I-J+1, + $ -TAU( I ), V( I+1, J ), LDV, V( I, J ), LDV, + $ ZERO, T( I+1, I ), 1 ) + CALL ZLACGV( N-K+I-1-J+1, V( I, J ), LDV ) + V( I, N-K+I ) = VII + END IF +* +* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) +* + CALL ZTRMV( 'Lower', 'No transpose', 'Non-unit', K-I, + $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) + IF( I.GT.1 ) THEN + PREVLASTV = MIN( PREVLASTV, LASTV ) + ELSE + PREVLASTV = LASTV + END IF + END IF + T( I, I ) = TAU( I ) + END IF + 40 CONTINUE + END IF + RETURN +* +* End of ZLARFT +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/complex16/zlartg.f b/fortran_implementation/external_libraries/lapack_routines/complex16/zlartg.f new file mode 100644 index 0000000..44376ee --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/complex16/zlartg.f @@ -0,0 +1,196 @@ + SUBROUTINE ZLARTG( F, G, CS, SN, R ) +* +* -- LAPACK auxiliary routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + DOUBLE PRECISION CS + COMPLEX*16 F, G, R, SN +* .. +* +* Purpose +* ======= +* +* ZLARTG generates a plane rotation so that +* +* [ CS SN ] [ F ] [ R ] +* [ __ ] . [ ] = [ ] where CS**2 + |SN|**2 = 1. +* [ -SN CS ] [ G ] [ 0 ] +* +* This is a faster version of the BLAS1 routine ZROTG, except for +* the following differences: +* F and G are unchanged on return. +* If G=0, then CS=1 and SN=0. +* If F=0, then CS=0 and SN is chosen so that R is real. +* +* Arguments +* ========= +* +* F (input) COMPLEX*16 +* The first component of vector to be rotated. +* +* G (input) COMPLEX*16 +* The second component of vector to be rotated. +* +* CS (output) DOUBLE PRECISION +* The cosine of the rotation. +* +* SN (output) COMPLEX*16 +* The sine of the rotation. +* +* R (output) COMPLEX*16 +* The nonzero component of the rotated vector. +* +* Further Details +* ======= ======= +* +* 3-5-96 - Modified with a new algorithm by W. Kahan and J. Demmel +* +* This version has a few statements commented out for thread safety +* (machine parameters are computed on each entry). 10 feb 03, SJH. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION TWO, ONE, ZERO + PARAMETER ( TWO = 2.0D+0, ONE = 1.0D+0, ZERO = 0.0D+0 ) + COMPLEX*16 CZERO + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. +* LOGICAL FIRST + INTEGER COUNT, I + DOUBLE PRECISION D, DI, DR, EPS, F2, F2S, G2, G2S, SAFMIN, + $ SAFMN2, SAFMX2, SCALE + COMPLEX*16 FF, FS, GS +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DLAPY2 + EXTERNAL DLAMCH, DLAPY2 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, LOG, + $ MAX, SQRT +* .. +* .. Statement Functions .. + DOUBLE PRECISION ABS1, ABSSQ +* .. +* .. Save statement .. +* SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 +* .. +* .. Data statements .. +* DATA FIRST / .TRUE. / +* .. +* .. Statement Function definitions .. + ABS1( FF ) = MAX( ABS( DBLE( FF ) ), ABS( DIMAG( FF ) ) ) + ABSSQ( FF ) = DBLE( FF )**2 + DIMAG( FF )**2 +* .. +* .. Executable Statements .. +* +* IF( FIRST ) THEN + SAFMIN = DLAMCH( 'S' ) + EPS = DLAMCH( 'E' ) + SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) / + $ LOG( DLAMCH( 'B' ) ) / TWO ) + SAFMX2 = ONE / SAFMN2 +* FIRST = .FALSE. +* END IF + SCALE = MAX( ABS1( F ), ABS1( G ) ) + FS = F + GS = G + COUNT = 0 + IF( SCALE.GE.SAFMX2 ) THEN + 10 CONTINUE + COUNT = COUNT + 1 + FS = FS*SAFMN2 + GS = GS*SAFMN2 + SCALE = SCALE*SAFMN2 + IF( SCALE.GE.SAFMX2 ) + $ GO TO 10 + ELSE IF( SCALE.LE.SAFMN2 ) THEN + IF( G.EQ.CZERO ) THEN + CS = ONE + SN = CZERO + R = F + RETURN + END IF + 20 CONTINUE + COUNT = COUNT - 1 + FS = FS*SAFMX2 + GS = GS*SAFMX2 + SCALE = SCALE*SAFMX2 + IF( SCALE.LE.SAFMN2 ) + $ GO TO 20 + END IF + F2 = ABSSQ( FS ) + G2 = ABSSQ( GS ) + IF( F2.LE.MAX( G2, ONE )*SAFMIN ) THEN +* +* This is a rare case: F is very small. +* + IF( F.EQ.CZERO ) THEN + CS = ZERO + R = DLAPY2( DBLE( G ), DIMAG( G ) ) +* Do complex/real division explicitly with two real divisions + D = DLAPY2( DBLE( GS ), DIMAG( GS ) ) + SN = DCMPLX( DBLE( GS ) / D, -DIMAG( GS ) / D ) + RETURN + END IF + F2S = DLAPY2( DBLE( FS ), DIMAG( FS ) ) +* G2 and G2S are accurate +* G2 is at least SAFMIN, and G2S is at least SAFMN2 + G2S = SQRT( G2 ) +* Error in CS from underflow in F2S is at most +* UNFL / SAFMN2 .lt. sqrt(UNFL*EPS) .lt. EPS +* If MAX(G2,ONE)=G2, then F2 .lt. G2*SAFMIN, +* and so CS .lt. sqrt(SAFMIN) +* If MAX(G2,ONE)=ONE, then F2 .lt. SAFMIN +* and so CS .lt. sqrt(SAFMIN)/SAFMN2 = sqrt(EPS) +* Therefore, CS = F2S/G2S / sqrt( 1 + (F2S/G2S)**2 ) = F2S/G2S + CS = F2S / G2S +* Make sure abs(FF) = 1 +* Do complex/real division explicitly with 2 real divisions + IF( ABS1( F ).GT.ONE ) THEN + D = DLAPY2( DBLE( F ), DIMAG( F ) ) + FF = DCMPLX( DBLE( F ) / D, DIMAG( F ) / D ) + ELSE + DR = SAFMX2*DBLE( F ) + DI = SAFMX2*DIMAG( F ) + D = DLAPY2( DR, DI ) + FF = DCMPLX( DR / D, DI / D ) + END IF + SN = FF*DCMPLX( DBLE( GS ) / G2S, -DIMAG( GS ) / G2S ) + R = CS*F + SN*G + ELSE +* +* This is the most common case. +* Neither F2 nor F2/G2 are less than SAFMIN +* F2S cannot overflow, and it is accurate +* + F2S = SQRT( ONE+G2 / F2 ) +* Do the F2S(real)*FS(complex) multiply with two real multiplies + R = DCMPLX( F2S*DBLE( FS ), F2S*DIMAG( FS ) ) + CS = ONE / F2S + D = F2 + G2 +* Do complex/real division explicitly with two real divisions + SN = DCMPLX( DBLE( R ) / D, DIMAG( R ) / D ) + SN = SN*DCONJG( GS ) + IF( COUNT.NE.0 ) THEN + IF( COUNT.GT.0 ) THEN + DO 30 I = 1, COUNT + R = R*SAFMX2 + 30 CONTINUE + ELSE + DO 40 I = 1, -COUNT + R = R*SAFMN2 + 40 CONTINUE + END IF + END IF + END IF + RETURN +* +* End of ZLARTG +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/complex16/zlascl.f b/fortran_implementation/external_libraries/lapack_routines/complex16/zlascl.f new file mode 100644 index 0000000..e9afdfd --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/complex16/zlascl.f @@ -0,0 +1,284 @@ + SUBROUTINE ZLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) +* +* -- LAPACK auxiliary routine (version 3.3.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2010 +* +* .. Scalar Arguments .. + CHARACTER TYPE + INTEGER INFO, KL, KU, LDA, M, N + DOUBLE PRECISION CFROM, CTO +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ) +* .. +* +* Purpose +* ======= +* +* ZLASCL multiplies the M by N complex matrix A by the real scalar +* CTO/CFROM. This is done without over/underflow as long as the final +* result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that +* A may be full, upper triangular, lower triangular, upper Hessenberg, +* or banded. +* +* Arguments +* ========= +* +* TYPE (input) CHARACTER*1 +* TYPE indices the storage type of the input matrix. +* = 'G': A is a full matrix. +* = 'L': A is a lower triangular matrix. +* = 'U': A is an upper triangular matrix. +* = 'H': A is an upper Hessenberg matrix. +* = 'B': A is a symmetric band matrix with lower bandwidth KL +* and upper bandwidth KU and with the only the lower +* half stored. +* = 'Q': A is a symmetric band matrix with lower bandwidth KL +* and upper bandwidth KU and with the only the upper +* half stored. +* = 'Z': A is a band matrix with lower bandwidth KL and upper +* bandwidth KU. See ZGBTRF for storage details. +* +* KL (input) INTEGER +* The lower bandwidth of A. Referenced only if TYPE = 'B', +* 'Q' or 'Z'. +* +* KU (input) INTEGER +* The upper bandwidth of A. Referenced only if TYPE = 'B', +* 'Q' or 'Z'. +* +* CFROM (input) DOUBLE PRECISION +* CTO (input) DOUBLE PRECISION +* The matrix A is multiplied by CTO/CFROM. A(I,J) is computed +* without over/underflow if the final result CTO*A(I,J)/CFROM +* can be represented without over/underflow. CFROM must be +* nonzero. +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* A (input/output) COMPLEX*16 array, dimension (LDA,N) +* The matrix to be multiplied by CTO/CFROM. See TYPE for the +* storage type. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,M). +* +* INFO (output) INTEGER +* 0 - successful exit +* <0 - if INFO = -i, the i-th argument had an illegal value. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL DONE + INTEGER I, ITYPE, J, K1, K2, K3, K4 + DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM +* .. +* .. External Functions .. + LOGICAL LSAME, DISNAN + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, DLAMCH, DISNAN +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 +* + IF( LSAME( TYPE, 'G' ) ) THEN + ITYPE = 0 + ELSE IF( LSAME( TYPE, 'L' ) ) THEN + ITYPE = 1 + ELSE IF( LSAME( TYPE, 'U' ) ) THEN + ITYPE = 2 + ELSE IF( LSAME( TYPE, 'H' ) ) THEN + ITYPE = 3 + ELSE IF( LSAME( TYPE, 'B' ) ) THEN + ITYPE = 4 + ELSE IF( LSAME( TYPE, 'Q' ) ) THEN + ITYPE = 5 + ELSE IF( LSAME( TYPE, 'Z' ) ) THEN + ITYPE = 6 + ELSE + ITYPE = -1 + END IF +* + IF( ITYPE.EQ.-1 ) THEN + INFO = -1 + ELSE IF( CFROM.EQ.ZERO .OR. DISNAN(CFROM) ) THEN + INFO = -4 + ELSE IF( DISNAN(CTO) ) THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR. + $ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN + INFO = -7 + ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN + INFO = -9 + ELSE IF( ITYPE.GE.4 ) THEN + IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN + INFO = -2 + ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR. + $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) ) + $ THEN + INFO = -3 + ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR. + $ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR. + $ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN + INFO = -9 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZLASCL', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. M.EQ.0 ) + $ RETURN +* +* Get machine parameters +* + SMLNUM = DLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM +* + CFROMC = CFROM + CTOC = CTO +* + 10 CONTINUE + CFROM1 = CFROMC*SMLNUM + IF( CFROM1.EQ.CFROMC ) THEN +! CFROMC is an inf. Multiply by a correctly signed zero for +! finite CTOC, or a NaN if CTOC is infinite. + MUL = CTOC / CFROMC + DONE = .TRUE. + CTO1 = CTOC + ELSE + CTO1 = CTOC / BIGNUM + IF( CTO1.EQ.CTOC ) THEN +! CTOC is either 0 or an inf. In both cases, CTOC itself +! serves as the correct multiplication factor. + MUL = CTOC + DONE = .TRUE. + CFROMC = ONE + ELSE IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN + MUL = SMLNUM + DONE = .FALSE. + CFROMC = CFROM1 + ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN + MUL = BIGNUM + DONE = .FALSE. + CTOC = CTO1 + ELSE + MUL = CTOC / CFROMC + DONE = .TRUE. + END IF + END IF +* + IF( ITYPE.EQ.0 ) THEN +* +* Full matrix +* + DO 30 J = 1, N + DO 20 I = 1, M + A( I, J ) = A( I, J )*MUL + 20 CONTINUE + 30 CONTINUE +* + ELSE IF( ITYPE.EQ.1 ) THEN +* +* Lower triangular matrix +* + DO 50 J = 1, N + DO 40 I = J, M + A( I, J ) = A( I, J )*MUL + 40 CONTINUE + 50 CONTINUE +* + ELSE IF( ITYPE.EQ.2 ) THEN +* +* Upper triangular matrix +* + DO 70 J = 1, N + DO 60 I = 1, MIN( J, M ) + A( I, J ) = A( I, J )*MUL + 60 CONTINUE + 70 CONTINUE +* + ELSE IF( ITYPE.EQ.3 ) THEN +* +* Upper Hessenberg matrix +* + DO 90 J = 1, N + DO 80 I = 1, MIN( J+1, M ) + A( I, J ) = A( I, J )*MUL + 80 CONTINUE + 90 CONTINUE +* + ELSE IF( ITYPE.EQ.4 ) THEN +* +* Lower half of a symmetric band matrix +* + K3 = KL + 1 + K4 = N + 1 + DO 110 J = 1, N + DO 100 I = 1, MIN( K3, K4-J ) + A( I, J ) = A( I, J )*MUL + 100 CONTINUE + 110 CONTINUE +* + ELSE IF( ITYPE.EQ.5 ) THEN +* +* Upper half of a symmetric band matrix +* + K1 = KU + 2 + K3 = KU + 1 + DO 130 J = 1, N + DO 120 I = MAX( K1-J, 1 ), K3 + A( I, J ) = A( I, J )*MUL + 120 CONTINUE + 130 CONTINUE +* + ELSE IF( ITYPE.EQ.6 ) THEN +* +* Band matrix +* + K1 = KL + KU + 2 + K2 = KL + 1 + K3 = 2*KL + KU + 1 + K4 = KL + KU + 1 + M + DO 150 J = 1, N + DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J ) + A( I, J ) = A( I, J )*MUL + 140 CONTINUE + 150 CONTINUE +* + END IF +* + IF( .NOT.DONE ) + $ GO TO 10 +* + RETURN +* +* End of ZLASCL +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/complex16/zlaset.f b/fortran_implementation/external_libraries/lapack_routines/complex16/zlaset.f new file mode 100644 index 0000000..f832ee8 --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/complex16/zlaset.f @@ -0,0 +1,115 @@ + SUBROUTINE ZLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) +* +* -- LAPACK auxiliary routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, M, N + COMPLEX*16 ALPHA, BETA +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ) +* .. +* +* Purpose +* ======= +* +* ZLASET initializes a 2-D array A to BETA on the diagonal and +* ALPHA on the offdiagonals. +* +* Arguments +* ========= +* +* UPLO (input) CHARACTER*1 +* Specifies the part of the matrix A to be set. +* = 'U': Upper triangular part is set. The lower triangle +* is unchanged. +* = 'L': Lower triangular part is set. The upper triangle +* is unchanged. +* Otherwise: All of the matrix A is set. +* +* M (input) INTEGER +* On entry, M specifies the number of rows of A. +* +* N (input) INTEGER +* On entry, N specifies the number of columns of A. +* +* ALPHA (input) COMPLEX*16 +* All the offdiagonal array elements are set to ALPHA. +* +* BETA (input) COMPLEX*16 +* All the diagonal array elements are set to BETA. +* +* A (input/output) COMPLEX*16 array, dimension (LDA,N) +* On entry, the m by n matrix A. +* On exit, A(i,j) = ALPHA, 1 <= i <= m, 1 <= j <= n, i.ne.j; +* A(i,i) = BETA , 1 <= i <= min(m,n) +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,M). +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, J +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN +* .. +* .. Executable Statements .. +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Set the diagonal to BETA and the strictly upper triangular +* part of the array to ALPHA. +* + DO 20 J = 2, N + DO 10 I = 1, MIN( J-1, M ) + A( I, J ) = ALPHA + 10 CONTINUE + 20 CONTINUE + DO 30 I = 1, MIN( N, M ) + A( I, I ) = BETA + 30 CONTINUE +* + ELSE IF( LSAME( UPLO, 'L' ) ) THEN +* +* Set the diagonal to BETA and the strictly lower triangular +* part of the array to ALPHA. +* + DO 50 J = 1, MIN( M, N ) + DO 40 I = J + 1, M + A( I, J ) = ALPHA + 40 CONTINUE + 50 CONTINUE + DO 60 I = 1, MIN( N, M ) + A( I, I ) = BETA + 60 CONTINUE +* + ELSE +* +* Set the array to BETA on the diagonal and ALPHA on the +* offdiagonal. +* + DO 80 J = 1, N + DO 70 I = 1, M + A( I, J ) = ALPHA + 70 CONTINUE + 80 CONTINUE + DO 90 I = 1, MIN( M, N ) + A( I, I ) = BETA + 90 CONTINUE + END IF +* + RETURN +* +* End of ZLASET +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/complex16/zlassq.f b/fortran_implementation/external_libraries/lapack_routines/complex16/zlassq.f new file mode 100644 index 0000000..faa7b16 --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/complex16/zlassq.f @@ -0,0 +1,102 @@ + SUBROUTINE ZLASSQ( N, X, INCX, SCALE, SUMSQ ) +* +* -- LAPACK auxiliary routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INCX, N + DOUBLE PRECISION SCALE, SUMSQ +* .. +* .. Array Arguments .. + COMPLEX*16 X( * ) +* .. +* +* Purpose +* ======= +* +* ZLASSQ returns the values scl and ssq such that +* +* ( scl**2 )*ssq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, +* +* where x( i ) = abs( X( 1 + ( i - 1 )*INCX ) ). The value of sumsq is +* assumed to be at least unity and the value of ssq will then satisfy +* +* 1.0 .le. ssq .le. ( sumsq + 2*n ). +* +* scale is assumed to be non-negative and scl returns the value +* +* scl = max( scale, abs( real( x( i ) ) ), abs( aimag( x( i ) ) ) ), +* i +* +* scale and sumsq must be supplied in SCALE and SUMSQ respectively. +* SCALE and SUMSQ are overwritten by scl and ssq respectively. +* +* The routine makes only one pass through the vector X. +* +* Arguments +* ========= +* +* N (input) INTEGER +* The number of elements to be used from the vector X. +* +* X (input) COMPLEX*16 array, dimension (N) +* The vector x as described above. +* x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. +* +* INCX (input) INTEGER +* The increment between successive values of the vector X. +* INCX > 0. +* +* SCALE (input/output) DOUBLE PRECISION +* On entry, the value scale in the equation above. +* On exit, SCALE is overwritten with the value scl . +* +* SUMSQ (input/output) DOUBLE PRECISION +* On entry, the value sumsq in the equation above. +* On exit, SUMSQ is overwritten with the value ssq . +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER IX + DOUBLE PRECISION TEMP1 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DIMAG +* .. +* .. Executable Statements .. +* + IF( N.GT.0 ) THEN + DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX + IF( DBLE( X( IX ) ).NE.ZERO ) THEN + TEMP1 = ABS( DBLE( X( IX ) ) ) + IF( SCALE.LT.TEMP1 ) THEN + SUMSQ = 1 + SUMSQ*( SCALE / TEMP1 )**2 + SCALE = TEMP1 + ELSE + SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2 + END IF + END IF + IF( DIMAG( X( IX ) ).NE.ZERO ) THEN + TEMP1 = ABS( DIMAG( X( IX ) ) ) + IF( SCALE.LT.TEMP1 ) THEN + SUMSQ = 1 + SUMSQ*( SCALE / TEMP1 )**2 + SCALE = TEMP1 + ELSE + SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2 + END IF + END IF + 10 CONTINUE + END IF +* + RETURN +* +* End of ZLASSQ +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/complex16/zlatrs.f b/fortran_implementation/external_libraries/lapack_routines/complex16/zlatrs.f new file mode 100644 index 0000000..26ad436 --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/complex16/zlatrs.f @@ -0,0 +1,880 @@ + SUBROUTINE ZLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, + $ CNORM, INFO ) +* +* -- LAPACK auxiliary routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER DIAG, NORMIN, TRANS, UPLO + INTEGER INFO, LDA, N + DOUBLE PRECISION SCALE +* .. +* .. Array Arguments .. + DOUBLE PRECISION CNORM( * ) + COMPLEX*16 A( LDA, * ), X( * ) +* .. +* +* Purpose +* ======= +* +* ZLATRS solves one of the triangular systems +* +* A * x = s*b, A**T * x = s*b, or A**H * x = s*b, +* +* with scaling to prevent overflow. Here A is an upper or lower +* triangular matrix, A**T denotes the transpose of A, A**H denotes the +* conjugate transpose of A, x and b are n-element vectors, and s is a +* scaling factor, usually less than or equal to 1, chosen so that the +* components of x will be less than the overflow threshold. If the +* unscaled problem will not cause overflow, the Level 2 BLAS routine +* ZTRSV is called. If the matrix A is singular (A(j,j) = 0 for some j), +* then s is set to 0 and a non-trivial solution to A*x = 0 is returned. +* +* Arguments +* ========= +* +* UPLO (input) CHARACTER*1 +* Specifies whether the matrix A is upper or lower triangular. +* = 'U': Upper triangular +* = 'L': Lower triangular +* +* TRANS (input) CHARACTER*1 +* Specifies the operation applied to A. +* = 'N': Solve A * x = s*b (No transpose) +* = 'T': Solve A**T * x = s*b (Transpose) +* = 'C': Solve A**H * x = s*b (Conjugate transpose) +* +* DIAG (input) CHARACTER*1 +* Specifies whether or not the matrix A is unit triangular. +* = 'N': Non-unit triangular +* = 'U': Unit triangular +* +* NORMIN (input) CHARACTER*1 +* Specifies whether CNORM has been set or not. +* = 'Y': CNORM contains the column norms on entry +* = 'N': CNORM is not set on entry. On exit, the norms will +* be computed and stored in CNORM. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* A (input) COMPLEX*16 array, dimension (LDA,N) +* The triangular matrix A. If UPLO = 'U', the leading n by n +* upper triangular part of the array A contains the upper +* triangular matrix, and the strictly lower triangular part of +* A is not referenced. If UPLO = 'L', the leading n by n lower +* triangular part of the array A contains the lower triangular +* matrix, and the strictly upper triangular part of A is not +* referenced. If DIAG = 'U', the diagonal elements of A are +* also not referenced and are assumed to be 1. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max (1,N). +* +* X (input/output) COMPLEX*16 array, dimension (N) +* On entry, the right hand side b of the triangular system. +* On exit, X is overwritten by the solution vector x. +* +* SCALE (output) DOUBLE PRECISION +* The scaling factor s for the triangular system +* A * x = s*b, A**T * x = s*b, or A**H * x = s*b. +* If SCALE = 0, the matrix A is singular or badly scaled, and +* the vector x is an exact or approximate solution to A*x = 0. +* +* CNORM (input or output) DOUBLE PRECISION array, dimension (N) +* +* If NORMIN = 'Y', CNORM is an input argument and CNORM(j) +* contains the norm of the off-diagonal part of the j-th column +* of A. If TRANS = 'N', CNORM(j) must be greater than or equal +* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) +* must be greater than or equal to the 1-norm. +* +* If NORMIN = 'N', CNORM is an output argument and CNORM(j) +* returns the 1-norm of the offdiagonal part of the j-th column +* of A. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -k, the k-th argument had an illegal value +* +* Further Details +* ======= ======= +* +* A rough bound on x is computed; if that is less than overflow, ZTRSV +* is called, otherwise, specific code is used which checks for possible +* overflow or divide-by-zero at every operation. +* +* A columnwise scheme is used for solving A*x = b. The basic algorithm +* if A is lower triangular is +* +* x[1:n] := b[1:n] +* for j = 1, ..., n +* x(j) := x(j) / A(j,j) +* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] +* end +* +* Define bounds on the components of x after j iterations of the loop: +* M(j) = bound on x[1:j] +* G(j) = bound on x[j+1:n] +* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. +* +* Then for iteration j+1 we have +* M(j+1) <= G(j) / | A(j+1,j+1) | +* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | +* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) +* +* where CNORM(j+1) is greater than or equal to the infinity-norm of +* column j+1 of A, not counting the diagonal. Hence +* +* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) +* 1<=i<=j +* and +* +* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) +* 1<=i< j +* +* Since |x(j)| <= M(j), we use the Level 2 BLAS routine ZTRSV if the +* reciprocal of the largest M(j), j=1,..,n, is larger than +* max(underflow, 1/overflow). +* +* The bound on x(j) is also used to determine when a step in the +* columnwise method can be performed without fear of overflow. If +* the computed bound is greater than a large constant, x is scaled to +* prevent overflow, but if the bound overflows, x is set to 0, x(j) to +* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. +* +* Similarly, a row-wise scheme is used to solve A**T *x = b or +* A**H *x = b. The basic algorithm for A upper triangular is +* +* for j = 1, ..., n +* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) +* end +* +* We simultaneously compute two bounds +* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j +* M(j) = bound on x(i), 1<=i<=j +* +* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we +* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. +* Then the bound on x(j) is +* +* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | +* +* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) +* 1<=i<=j +* +* and we can safely call ZTRSV if 1/M(n) and 1/G(n) are both greater +* than max(underflow, 1/overflow). +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, HALF, ONE, TWO + PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0, + $ TWO = 2.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL NOTRAN, NOUNIT, UPPER + INTEGER I, IMAX, J, JFIRST, JINC, JLAST + DOUBLE PRECISION BIGNUM, GROW, REC, SMLNUM, TJJ, TMAX, TSCAL, + $ XBND, XJ, XMAX + COMPLEX*16 CSUMJ, TJJS, USCAL, ZDUM +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX, IZAMAX + DOUBLE PRECISION DLAMCH, DZASUM + COMPLEX*16 ZDOTC, ZDOTU, ZLADIV + EXTERNAL LSAME, IDAMAX, IZAMAX, DLAMCH, DZASUM, ZDOTC, + $ ZDOTU, ZLADIV +* .. +* .. External Subroutines .. + EXTERNAL DSCAL, XERBLA, ZAXPY, ZDSCAL, ZTRSV +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, MIN +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1, CABS2 +* .. +* .. Statement Function definitions .. + CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) + CABS2( ZDUM ) = ABS( DBLE( ZDUM ) / 2.D0 ) + + $ ABS( DIMAG( ZDUM ) / 2.D0 ) +* .. +* .. Executable Statements .. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + NOTRAN = LSAME( TRANS, 'N' ) + NOUNIT = LSAME( DIAG, 'N' ) +* +* Test the input parameters. +* + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. + $ LSAME( TRANS, 'C' ) ) THEN + INFO = -2 + ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN + INFO = -3 + ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT. + $ LSAME( NORMIN, 'N' ) ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZLATRS', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Determine machine dependent parameters to control overflow. +* + SMLNUM = DLAMCH( 'Safe minimum' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) + SMLNUM = SMLNUM / DLAMCH( 'Precision' ) + BIGNUM = ONE / SMLNUM + SCALE = ONE +* + IF( LSAME( NORMIN, 'N' ) ) THEN +* +* Compute the 1-norm of each column, not including the diagonal. +* + IF( UPPER ) THEN +* +* A is upper triangular. +* + DO 10 J = 1, N + CNORM( J ) = DZASUM( J-1, A( 1, J ), 1 ) + 10 CONTINUE + ELSE +* +* A is lower triangular. +* + DO 20 J = 1, N - 1 + CNORM( J ) = DZASUM( N-J, A( J+1, J ), 1 ) + 20 CONTINUE + CNORM( N ) = ZERO + END IF + END IF +* +* Scale the column norms by TSCAL if the maximum element in CNORM is +* greater than BIGNUM/2. +* + IMAX = IDAMAX( N, CNORM, 1 ) + TMAX = CNORM( IMAX ) + IF( TMAX.LE.BIGNUM*HALF ) THEN + TSCAL = ONE + ELSE + TSCAL = HALF / ( SMLNUM*TMAX ) + CALL DSCAL( N, TSCAL, CNORM, 1 ) + END IF +* +* Compute a bound on the computed solution vector to see if the +* Level 2 BLAS routine ZTRSV can be used. +* + XMAX = ZERO + DO 30 J = 1, N + XMAX = MAX( XMAX, CABS2( X( J ) ) ) + 30 CONTINUE + XBND = XMAX +* + IF( NOTRAN ) THEN +* +* Compute the growth in A * x = b. +* + IF( UPPER ) THEN + JFIRST = N + JLAST = 1 + JINC = -1 + ELSE + JFIRST = 1 + JLAST = N + JINC = 1 + END IF +* + IF( TSCAL.NE.ONE ) THEN + GROW = ZERO + GO TO 60 + END IF +* + IF( NOUNIT ) THEN +* +* A is non-unit triangular. +* +* Compute GROW = 1/G(j) and XBND = 1/M(j). +* Initially, G(0) = max{x(i), i=1,...,n}. +* + GROW = HALF / MAX( XBND, SMLNUM ) + XBND = GROW + DO 40 J = JFIRST, JLAST, JINC +* +* Exit the loop if the growth factor is too small. +* + IF( GROW.LE.SMLNUM ) + $ GO TO 60 +* + TJJS = A( J, J ) + TJJ = CABS1( TJJS ) +* + IF( TJJ.GE.SMLNUM ) THEN +* +* M(j) = G(j-1) / abs(A(j,j)) +* + XBND = MIN( XBND, MIN( ONE, TJJ )*GROW ) + ELSE +* +* M(j) could overflow, set XBND to 0. +* + XBND = ZERO + END IF +* + IF( TJJ+CNORM( J ).GE.SMLNUM ) THEN +* +* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) +* + GROW = GROW*( TJJ / ( TJJ+CNORM( J ) ) ) + ELSE +* +* G(j) could overflow, set GROW to 0. +* + GROW = ZERO + END IF + 40 CONTINUE + GROW = XBND + ELSE +* +* A is unit triangular. +* +* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. +* + GROW = MIN( ONE, HALF / MAX( XBND, SMLNUM ) ) + DO 50 J = JFIRST, JLAST, JINC +* +* Exit the loop if the growth factor is too small. +* + IF( GROW.LE.SMLNUM ) + $ GO TO 60 +* +* G(j) = G(j-1)*( 1 + CNORM(j) ) +* + GROW = GROW*( ONE / ( ONE+CNORM( J ) ) ) + 50 CONTINUE + END IF + 60 CONTINUE +* + ELSE +* +* Compute the growth in A**T * x = b or A**H * x = b. +* + IF( UPPER ) THEN + JFIRST = 1 + JLAST = N + JINC = 1 + ELSE + JFIRST = N + JLAST = 1 + JINC = -1 + END IF +* + IF( TSCAL.NE.ONE ) THEN + GROW = ZERO + GO TO 90 + END IF +* + IF( NOUNIT ) THEN +* +* A is non-unit triangular. +* +* Compute GROW = 1/G(j) and XBND = 1/M(j). +* Initially, M(0) = max{x(i), i=1,...,n}. +* + GROW = HALF / MAX( XBND, SMLNUM ) + XBND = GROW + DO 70 J = JFIRST, JLAST, JINC +* +* Exit the loop if the growth factor is too small. +* + IF( GROW.LE.SMLNUM ) + $ GO TO 90 +* +* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) +* + XJ = ONE + CNORM( J ) + GROW = MIN( GROW, XBND / XJ ) +* + TJJS = A( J, J ) + TJJ = CABS1( TJJS ) +* + IF( TJJ.GE.SMLNUM ) THEN +* +* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) +* + IF( XJ.GT.TJJ ) + $ XBND = XBND*( TJJ / XJ ) + ELSE +* +* M(j) could overflow, set XBND to 0. +* + XBND = ZERO + END IF + 70 CONTINUE + GROW = MIN( GROW, XBND ) + ELSE +* +* A is unit triangular. +* +* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. +* + GROW = MIN( ONE, HALF / MAX( XBND, SMLNUM ) ) + DO 80 J = JFIRST, JLAST, JINC +* +* Exit the loop if the growth factor is too small. +* + IF( GROW.LE.SMLNUM ) + $ GO TO 90 +* +* G(j) = ( 1 + CNORM(j) )*G(j-1) +* + XJ = ONE + CNORM( J ) + GROW = GROW / XJ + 80 CONTINUE + END IF + 90 CONTINUE + END IF +* + IF( ( GROW*TSCAL ).GT.SMLNUM ) THEN +* +* Use the Level 2 BLAS solve if the reciprocal of the bound on +* elements of X is not too small. +* + CALL ZTRSV( UPLO, TRANS, DIAG, N, A, LDA, X, 1 ) + ELSE +* +* Use a Level 1 BLAS solve, scaling intermediate results. +* + IF( XMAX.GT.BIGNUM*HALF ) THEN +* +* Scale X so that its components are less than or equal to +* BIGNUM in absolute value. +* + SCALE = ( BIGNUM*HALF ) / XMAX + CALL ZDSCAL( N, SCALE, X, 1 ) + XMAX = BIGNUM + ELSE + XMAX = XMAX*TWO + END IF +* + IF( NOTRAN ) THEN +* +* Solve A * x = b +* + DO 120 J = JFIRST, JLAST, JINC +* +* Compute x(j) = b(j) / A(j,j), scaling x if necessary. +* + XJ = CABS1( X( J ) ) + IF( NOUNIT ) THEN + TJJS = A( J, J )*TSCAL + ELSE + TJJS = TSCAL + IF( TSCAL.EQ.ONE ) + $ GO TO 110 + END IF + TJJ = CABS1( TJJS ) + IF( TJJ.GT.SMLNUM ) THEN +* +* abs(A(j,j)) > SMLNUM: +* + IF( TJJ.LT.ONE ) THEN + IF( XJ.GT.TJJ*BIGNUM ) THEN +* +* Scale x by 1/b(j). +* + REC = ONE / XJ + CALL ZDSCAL( N, REC, X, 1 ) + SCALE = SCALE*REC + XMAX = XMAX*REC + END IF + END IF + X( J ) = ZLADIV( X( J ), TJJS ) + XJ = CABS1( X( J ) ) + ELSE IF( TJJ.GT.ZERO ) THEN +* +* 0 < abs(A(j,j)) <= SMLNUM: +* + IF( XJ.GT.TJJ*BIGNUM ) THEN +* +* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM +* to avoid overflow when dividing by A(j,j). +* + REC = ( TJJ*BIGNUM ) / XJ + IF( CNORM( J ).GT.ONE ) THEN +* +* Scale by 1/CNORM(j) to avoid overflow when +* multiplying x(j) times column j. +* + REC = REC / CNORM( J ) + END IF + CALL ZDSCAL( N, REC, X, 1 ) + SCALE = SCALE*REC + XMAX = XMAX*REC + END IF + X( J ) = ZLADIV( X( J ), TJJS ) + XJ = CABS1( X( J ) ) + ELSE +* +* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and +* scale = 0, and compute a solution to A*x = 0. +* + DO 100 I = 1, N + X( I ) = ZERO + 100 CONTINUE + X( J ) = ONE + XJ = ONE + SCALE = ZERO + XMAX = ZERO + END IF + 110 CONTINUE +* +* Scale x if necessary to avoid overflow when adding a +* multiple of column j of A. +* + IF( XJ.GT.ONE ) THEN + REC = ONE / XJ + IF( CNORM( J ).GT.( BIGNUM-XMAX )*REC ) THEN +* +* Scale x by 1/(2*abs(x(j))). +* + REC = REC*HALF + CALL ZDSCAL( N, REC, X, 1 ) + SCALE = SCALE*REC + END IF + ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN +* +* Scale x by 1/2. +* + CALL ZDSCAL( N, HALF, X, 1 ) + SCALE = SCALE*HALF + END IF +* + IF( UPPER ) THEN + IF( J.GT.1 ) THEN +* +* Compute the update +* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) +* + CALL ZAXPY( J-1, -X( J )*TSCAL, A( 1, J ), 1, X, + $ 1 ) + I = IZAMAX( J-1, X, 1 ) + XMAX = CABS1( X( I ) ) + END IF + ELSE + IF( J.LT.N ) THEN +* +* Compute the update +* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) +* + CALL ZAXPY( N-J, -X( J )*TSCAL, A( J+1, J ), 1, + $ X( J+1 ), 1 ) + I = J + IZAMAX( N-J, X( J+1 ), 1 ) + XMAX = CABS1( X( I ) ) + END IF + END IF + 120 CONTINUE +* + ELSE IF( LSAME( TRANS, 'T' ) ) THEN +* +* Solve A**T * x = b +* + DO 170 J = JFIRST, JLAST, JINC +* +* Compute x(j) = b(j) - sum A(k,j)*x(k). +* k<>j +* + XJ = CABS1( X( J ) ) + USCAL = TSCAL + REC = ONE / MAX( XMAX, ONE ) + IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN +* +* If x(j) could overflow, scale x by 1/(2*XMAX). +* + REC = REC*HALF + IF( NOUNIT ) THEN + TJJS = A( J, J )*TSCAL + ELSE + TJJS = TSCAL + END IF + TJJ = CABS1( TJJS ) + IF( TJJ.GT.ONE ) THEN +* +* Divide by A(j,j) when scaling x if A(j,j) > 1. +* + REC = MIN( ONE, REC*TJJ ) + USCAL = ZLADIV( USCAL, TJJS ) + END IF + IF( REC.LT.ONE ) THEN + CALL ZDSCAL( N, REC, X, 1 ) + SCALE = SCALE*REC + XMAX = XMAX*REC + END IF + END IF +* + CSUMJ = ZERO + IF( USCAL.EQ.DCMPLX( ONE ) ) THEN +* +* If the scaling needed for A in the dot product is 1, +* call ZDOTU to perform the dot product. +* + IF( UPPER ) THEN + CSUMJ = ZDOTU( J-1, A( 1, J ), 1, X, 1 ) + ELSE IF( J.LT.N ) THEN + CSUMJ = ZDOTU( N-J, A( J+1, J ), 1, X( J+1 ), 1 ) + END IF + ELSE +* +* Otherwise, use in-line code for the dot product. +* + IF( UPPER ) THEN + DO 130 I = 1, J - 1 + CSUMJ = CSUMJ + ( A( I, J )*USCAL )*X( I ) + 130 CONTINUE + ELSE IF( J.LT.N ) THEN + DO 140 I = J + 1, N + CSUMJ = CSUMJ + ( A( I, J )*USCAL )*X( I ) + 140 CONTINUE + END IF + END IF +* + IF( USCAL.EQ.DCMPLX( TSCAL ) ) THEN +* +* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) +* was not used to scale the dotproduct. +* + X( J ) = X( J ) - CSUMJ + XJ = CABS1( X( J ) ) + IF( NOUNIT ) THEN + TJJS = A( J, J )*TSCAL + ELSE + TJJS = TSCAL + IF( TSCAL.EQ.ONE ) + $ GO TO 160 + END IF +* +* Compute x(j) = x(j) / A(j,j), scaling if necessary. +* + TJJ = CABS1( TJJS ) + IF( TJJ.GT.SMLNUM ) THEN +* +* abs(A(j,j)) > SMLNUM: +* + IF( TJJ.LT.ONE ) THEN + IF( XJ.GT.TJJ*BIGNUM ) THEN +* +* Scale X by 1/abs(x(j)). +* + REC = ONE / XJ + CALL ZDSCAL( N, REC, X, 1 ) + SCALE = SCALE*REC + XMAX = XMAX*REC + END IF + END IF + X( J ) = ZLADIV( X( J ), TJJS ) + ELSE IF( TJJ.GT.ZERO ) THEN +* +* 0 < abs(A(j,j)) <= SMLNUM: +* + IF( XJ.GT.TJJ*BIGNUM ) THEN +* +* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. +* + REC = ( TJJ*BIGNUM ) / XJ + CALL ZDSCAL( N, REC, X, 1 ) + SCALE = SCALE*REC + XMAX = XMAX*REC + END IF + X( J ) = ZLADIV( X( J ), TJJS ) + ELSE +* +* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and +* scale = 0 and compute a solution to A**T *x = 0. +* + DO 150 I = 1, N + X( I ) = ZERO + 150 CONTINUE + X( J ) = ONE + SCALE = ZERO + XMAX = ZERO + END IF + 160 CONTINUE + ELSE +* +* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot +* product has already been divided by 1/A(j,j). +* + X( J ) = ZLADIV( X( J ), TJJS ) - CSUMJ + END IF + XMAX = MAX( XMAX, CABS1( X( J ) ) ) + 170 CONTINUE +* + ELSE +* +* Solve A**H * x = b +* + DO 220 J = JFIRST, JLAST, JINC +* +* Compute x(j) = b(j) - sum A(k,j)*x(k). +* k<>j +* + XJ = CABS1( X( J ) ) + USCAL = TSCAL + REC = ONE / MAX( XMAX, ONE ) + IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN +* +* If x(j) could overflow, scale x by 1/(2*XMAX). +* + REC = REC*HALF + IF( NOUNIT ) THEN + TJJS = DCONJG( A( J, J ) )*TSCAL + ELSE + TJJS = TSCAL + END IF + TJJ = CABS1( TJJS ) + IF( TJJ.GT.ONE ) THEN +* +* Divide by A(j,j) when scaling x if A(j,j) > 1. +* + REC = MIN( ONE, REC*TJJ ) + USCAL = ZLADIV( USCAL, TJJS ) + END IF + IF( REC.LT.ONE ) THEN + CALL ZDSCAL( N, REC, X, 1 ) + SCALE = SCALE*REC + XMAX = XMAX*REC + END IF + END IF +* + CSUMJ = ZERO + IF( USCAL.EQ.DCMPLX( ONE ) ) THEN +* +* If the scaling needed for A in the dot product is 1, +* call ZDOTC to perform the dot product. +* + IF( UPPER ) THEN + CSUMJ = ZDOTC( J-1, A( 1, J ), 1, X, 1 ) + ELSE IF( J.LT.N ) THEN + CSUMJ = ZDOTC( N-J, A( J+1, J ), 1, X( J+1 ), 1 ) + END IF + ELSE +* +* Otherwise, use in-line code for the dot product. +* + IF( UPPER ) THEN + DO 180 I = 1, J - 1 + CSUMJ = CSUMJ + ( DCONJG( A( I, J ) )*USCAL )* + $ X( I ) + 180 CONTINUE + ELSE IF( J.LT.N ) THEN + DO 190 I = J + 1, N + CSUMJ = CSUMJ + ( DCONJG( A( I, J ) )*USCAL )* + $ X( I ) + 190 CONTINUE + END IF + END IF +* + IF( USCAL.EQ.DCMPLX( TSCAL ) ) THEN +* +* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) +* was not used to scale the dotproduct. +* + X( J ) = X( J ) - CSUMJ + XJ = CABS1( X( J ) ) + IF( NOUNIT ) THEN + TJJS = DCONJG( A( J, J ) )*TSCAL + ELSE + TJJS = TSCAL + IF( TSCAL.EQ.ONE ) + $ GO TO 210 + END IF +* +* Compute x(j) = x(j) / A(j,j), scaling if necessary. +* + TJJ = CABS1( TJJS ) + IF( TJJ.GT.SMLNUM ) THEN +* +* abs(A(j,j)) > SMLNUM: +* + IF( TJJ.LT.ONE ) THEN + IF( XJ.GT.TJJ*BIGNUM ) THEN +* +* Scale X by 1/abs(x(j)). +* + REC = ONE / XJ + CALL ZDSCAL( N, REC, X, 1 ) + SCALE = SCALE*REC + XMAX = XMAX*REC + END IF + END IF + X( J ) = ZLADIV( X( J ), TJJS ) + ELSE IF( TJJ.GT.ZERO ) THEN +* +* 0 < abs(A(j,j)) <= SMLNUM: +* + IF( XJ.GT.TJJ*BIGNUM ) THEN +* +* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. +* + REC = ( TJJ*BIGNUM ) / XJ + CALL ZDSCAL( N, REC, X, 1 ) + SCALE = SCALE*REC + XMAX = XMAX*REC + END IF + X( J ) = ZLADIV( X( J ), TJJS ) + ELSE +* +* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and +* scale = 0 and compute a solution to A**H *x = 0. +* + DO 200 I = 1, N + X( I ) = ZERO + 200 CONTINUE + X( J ) = ONE + SCALE = ZERO + XMAX = ZERO + END IF + 210 CONTINUE + ELSE +* +* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot +* product has already been divided by 1/A(j,j). +* + X( J ) = ZLADIV( X( J ), TJJS ) - CSUMJ + END IF + XMAX = MAX( XMAX, CABS1( X( J ) ) ) + 220 CONTINUE + END IF + SCALE = SCALE / TSCAL + END IF +* +* Scale the column norms by 1/TSCAL for return. +* + IF( TSCAL.NE.ONE ) THEN + CALL DSCAL( N, ONE / TSCAL, CNORM, 1 ) + END IF +* + RETURN +* +* End of ZLATRS +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/complex16/zrot.f b/fortran_implementation/external_libraries/lapack_routines/complex16/zrot.f new file mode 100644 index 0000000..ec1ebe6 --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/complex16/zrot.f @@ -0,0 +1,92 @@ + SUBROUTINE ZROT( N, CX, INCX, CY, INCY, C, S ) +* +* -- LAPACK auxiliary routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INCX, INCY, N + DOUBLE PRECISION C + COMPLEX*16 S +* .. +* .. Array Arguments .. + COMPLEX*16 CX( * ), CY( * ) +* .. +* +* Purpose +* ======= +* +* ZROT applies a plane rotation, where the cos (C) is real and the +* sin (S) is complex, and the vectors CX and CY are complex. +* +* Arguments +* ========= +* +* N (input) INTEGER +* The number of elements in the vectors CX and CY. +* +* CX (input/output) COMPLEX*16 array, dimension (N) +* On input, the vector X. +* On output, CX is overwritten with C*X + S*Y. +* +* INCX (input) INTEGER +* The increment between successive values of CY. INCX <> 0. +* +* CY (input/output) COMPLEX*16 array, dimension (N) +* On input, the vector Y. +* On output, CY is overwritten with -CONJG(S)*X + C*Y. +* +* INCY (input) INTEGER +* The increment between successive values of CY. INCX <> 0. +* +* C (input) DOUBLE PRECISION +* S (input) COMPLEX*16 +* C and S define a rotation +* [ C S ] +* [ -conjg(S) C ] +* where C*C + S*CONJG(S) = 1.0. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, IX, IY + COMPLEX*16 STEMP +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG +* .. +* .. Executable Statements .. +* + IF( N.LE.0 ) + $ RETURN + IF( INCX.EQ.1 .AND. INCY.EQ.1 ) + $ GO TO 20 +* +* Code for unequal increments or equal increments not equal to 1 +* + IX = 1 + IY = 1 + IF( INCX.LT.0 ) + $ IX = ( -N+1 )*INCX + 1 + IF( INCY.LT.0 ) + $ IY = ( -N+1 )*INCY + 1 + DO 10 I = 1, N + STEMP = C*CX( IX ) + S*CY( IY ) + CY( IY ) = C*CY( IY ) - DCONJG( S )*CX( IX ) + CX( IX ) = STEMP + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + RETURN +* +* Code for both increments equal to 1 +* + 20 CONTINUE + DO 30 I = 1, N + STEMP = C*CX( I ) + S*CY( I ) + CY( I ) = C*CY( I ) - DCONJG( S )*CX( I ) + CX( I ) = STEMP + 30 CONTINUE + RETURN + END diff --git a/fortran_implementation/external_libraries/lapack_routines/complex16/ztrevc.f b/fortran_implementation/external_libraries/lapack_routines/complex16/ztrevc.f new file mode 100644 index 0000000..f2ac7f9 --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/complex16/ztrevc.f @@ -0,0 +1,387 @@ + SUBROUTINE ZTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, + $ LDVR, MM, M, WORK, RWORK, INFO ) +* +* -- LAPACK routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + CHARACTER HOWMNY, SIDE + INTEGER INFO, LDT, LDVL, LDVR, M, MM, N +* .. +* .. Array Arguments .. + LOGICAL SELECT( * ) + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), + $ WORK( * ) +* .. +* +* Purpose +* ======= +* +* ZTREVC computes some or all of the right and/or left eigenvectors of +* a complex upper triangular matrix T. +* Matrices of this type are produced by the Schur factorization of +* a complex general matrix: A = Q*T*Q**H, as computed by ZHSEQR. +* +* The right eigenvector x and the left eigenvector y of T corresponding +* to an eigenvalue w are defined by: +* +* T*x = w*x, (y**H)*T = w*(y**H) +* +* where y**H denotes the conjugate transpose of the vector y. +* The eigenvalues are not input to this routine, but are read directly +* from the diagonal of T. +* +* This routine returns the matrices X and/or Y of right and left +* eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an +* input matrix. If Q is the unitary factor that reduces a matrix A to +* Schur form T, then Q*X and Q*Y are the matrices of right and left +* eigenvectors of A. +* +* Arguments +* ========= +* +* SIDE (input) CHARACTER*1 +* = 'R': compute right eigenvectors only; +* = 'L': compute left eigenvectors only; +* = 'B': compute both right and left eigenvectors. +* +* HOWMNY (input) CHARACTER*1 +* = 'A': compute all right and/or left eigenvectors; +* = 'B': compute all right and/or left eigenvectors, +* backtransformed using the matrices supplied in +* VR and/or VL; +* = 'S': compute selected right and/or left eigenvectors, +* as indicated by the logical array SELECT. +* +* SELECT (input) LOGICAL array, dimension (N) +* If HOWMNY = 'S', SELECT specifies the eigenvectors to be +* computed. +* The eigenvector corresponding to the j-th eigenvalue is +* computed if SELECT(j) = .TRUE.. +* Not referenced if HOWMNY = 'A' or 'B'. +* +* N (input) INTEGER +* The order of the matrix T. N >= 0. +* +* T (input/output) COMPLEX*16 array, dimension (LDT,N) +* The upper triangular matrix T. T is modified, but restored +* on exit. +* +* LDT (input) INTEGER +* The leading dimension of the array T. LDT >= max(1,N). +* +* VL (input/output) COMPLEX*16 array, dimension (LDVL,MM) +* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must +* contain an N-by-N matrix Q (usually the unitary matrix Q of +* Schur vectors returned by ZHSEQR). +* On exit, if SIDE = 'L' or 'B', VL contains: +* if HOWMNY = 'A', the matrix Y of left eigenvectors of T; +* if HOWMNY = 'B', the matrix Q*Y; +* if HOWMNY = 'S', the left eigenvectors of T specified by +* SELECT, stored consecutively in the columns +* of VL, in the same order as their +* eigenvalues. +* Not referenced if SIDE = 'R'. +* +* LDVL (input) INTEGER +* The leading dimension of the array VL. LDVL >= 1, and if +* SIDE = 'L' or 'B', LDVL >= N. +* +* VR (input/output) COMPLEX*16 array, dimension (LDVR,MM) +* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must +* contain an N-by-N matrix Q (usually the unitary matrix Q of +* Schur vectors returned by ZHSEQR). +* On exit, if SIDE = 'R' or 'B', VR contains: +* if HOWMNY = 'A', the matrix X of right eigenvectors of T; +* if HOWMNY = 'B', the matrix Q*X; +* if HOWMNY = 'S', the right eigenvectors of T specified by +* SELECT, stored consecutively in the columns +* of VR, in the same order as their +* eigenvalues. +* Not referenced if SIDE = 'L'. +* +* LDVR (input) INTEGER +* The leading dimension of the array VR. LDVR >= 1, and if +* SIDE = 'R' or 'B'; LDVR >= N. +* +* MM (input) INTEGER +* The number of columns in the arrays VL and/or VR. MM >= M. +* +* M (output) INTEGER +* The number of columns in the arrays VL and/or VR actually +* used to store the eigenvectors. If HOWMNY = 'A' or 'B', M +* is set to N. Each selected eigenvector occupies one +* column. +* +* WORK (workspace) COMPLEX*16 array, dimension (2*N) +* +* RWORK (workspace) DOUBLE PRECISION array, dimension (N) +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* Further Details +* =============== +* +* The algorithm used in this program is basically backward (forward) +* substitution, with scaling to make the the code robust against +* possible overflow. +* +* Each eigenvector is normalized so that the element of largest +* magnitude has magnitude 1; here the magnitude of a complex number +* (x,y) is taken to be |x| + |y|. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + COMPLEX*16 CMZERO, CMONE + PARAMETER ( CMZERO = ( 0.0D+0, 0.0D+0 ), + $ CMONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL ALLV, BOTHV, LEFTV, OVER, RIGHTV, SOMEV + INTEGER I, II, IS, J, K, KI + DOUBLE PRECISION OVFL, REMAX, SCALE, SMIN, SMLNUM, ULP, UNFL + COMPLEX*16 CDUM +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IZAMAX + DOUBLE PRECISION DLAMCH, DZASUM + EXTERNAL LSAME, IZAMAX, DLAMCH, DZASUM +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZCOPY, ZDSCAL, ZGEMV, ZLATRS +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) +* .. +* .. Executable Statements .. +* +* Decode and test the input parameters +* + BOTHV = LSAME( SIDE, 'B' ) + RIGHTV = LSAME( SIDE, 'R' ) .OR. BOTHV + LEFTV = LSAME( SIDE, 'L' ) .OR. BOTHV +* + ALLV = LSAME( HOWMNY, 'A' ) + OVER = LSAME( HOWMNY, 'B' ) + SOMEV = LSAME( HOWMNY, 'S' ) +* +* Set M to the number of columns required to store the selected +* eigenvectors. +* + IF( SOMEV ) THEN + M = 0 + DO 10 J = 1, N + IF( SELECT( J ) ) + $ M = M + 1 + 10 CONTINUE + ELSE + M = N + END IF +* + INFO = 0 + IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN + INFO = -1 + ELSE IF( .NOT.ALLV .AND. .NOT.OVER .AND. .NOT.SOMEV ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN + INFO = -8 + ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN + INFO = -10 + ELSE IF( MM.LT.M ) THEN + INFO = -11 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZTREVC', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) + $ RETURN +* +* Set the constants to control overflow. +* + UNFL = DLAMCH( 'Safe minimum' ) + OVFL = ONE / UNFL + CALL DLABAD( UNFL, OVFL ) + ULP = DLAMCH( 'Precision' ) + SMLNUM = UNFL*( N / ULP ) +* +* Store the diagonal elements of T in working array WORK. +* + DO 20 I = 1, N + WORK( I+N ) = T( I, I ) + 20 CONTINUE +* +* Compute 1-norm of each column of strictly upper triangular +* part of T to control overflow in triangular solver. +* + RWORK( 1 ) = ZERO + DO 30 J = 2, N + RWORK( J ) = DZASUM( J-1, T( 1, J ), 1 ) + 30 CONTINUE +* + IF( RIGHTV ) THEN +* +* Compute right eigenvectors. +* + IS = M + DO 80 KI = N, 1, -1 +* + IF( SOMEV ) THEN + IF( .NOT.SELECT( KI ) ) + $ GO TO 80 + END IF + SMIN = MAX( ULP*( CABS1( T( KI, KI ) ) ), SMLNUM ) +* + WORK( 1 ) = CMONE +* +* Form right-hand side. +* + DO 40 K = 1, KI - 1 + WORK( K ) = -T( K, KI ) + 40 CONTINUE +* +* Solve the triangular system: +* (T(1:KI-1,1:KI-1) - T(KI,KI))*X = SCALE*WORK. +* + DO 50 K = 1, KI - 1 + T( K, K ) = T( K, K ) - T( KI, KI ) + IF( CABS1( T( K, K ) ).LT.SMIN ) + $ T( K, K ) = SMIN + 50 CONTINUE +* + IF( KI.GT.1 ) THEN + CALL ZLATRS( 'Upper', 'No transpose', 'Non-unit', 'Y', + $ KI-1, T, LDT, WORK( 1 ), SCALE, RWORK, + $ INFO ) + WORK( KI ) = SCALE + END IF +* +* Copy the vector x or Q*x to VR and normalize. +* + IF( .NOT.OVER ) THEN + CALL ZCOPY( KI, WORK( 1 ), 1, VR( 1, IS ), 1 ) +* + II = IZAMAX( KI, VR( 1, IS ), 1 ) + REMAX = ONE / CABS1( VR( II, IS ) ) + CALL ZDSCAL( KI, REMAX, VR( 1, IS ), 1 ) +* + DO 60 K = KI + 1, N + VR( K, IS ) = CMZERO + 60 CONTINUE + ELSE + IF( KI.GT.1 ) + $ CALL ZGEMV( 'N', N, KI-1, CMONE, VR, LDVR, WORK( 1 ), + $ 1, DCMPLX( SCALE ), VR( 1, KI ), 1 ) +* + II = IZAMAX( N, VR( 1, KI ), 1 ) + REMAX = ONE / CABS1( VR( II, KI ) ) + CALL ZDSCAL( N, REMAX, VR( 1, KI ), 1 ) + END IF +* +* Set back the original diagonal elements of T. +* + DO 70 K = 1, KI - 1 + T( K, K ) = WORK( K+N ) + 70 CONTINUE +* + IS = IS - 1 + 80 CONTINUE + END IF +* + IF( LEFTV ) THEN +* +* Compute left eigenvectors. +* + IS = 1 + DO 130 KI = 1, N +* + IF( SOMEV ) THEN + IF( .NOT.SELECT( KI ) ) + $ GO TO 130 + END IF + SMIN = MAX( ULP*( CABS1( T( KI, KI ) ) ), SMLNUM ) +* + WORK( N ) = CMONE +* +* Form right-hand side. +* + DO 90 K = KI + 1, N + WORK( K ) = -DCONJG( T( KI, K ) ) + 90 CONTINUE +* +* Solve the triangular system: +* (T(KI+1:N,KI+1:N) - T(KI,KI))**H * X = SCALE*WORK. +* + DO 100 K = KI + 1, N + T( K, K ) = T( K, K ) - T( KI, KI ) + IF( CABS1( T( K, K ) ).LT.SMIN ) + $ T( K, K ) = SMIN + 100 CONTINUE +* + IF( KI.LT.N ) THEN + CALL ZLATRS( 'Upper', 'Conjugate transpose', 'Non-unit', + $ 'Y', N-KI, T( KI+1, KI+1 ), LDT, + $ WORK( KI+1 ), SCALE, RWORK, INFO ) + WORK( KI ) = SCALE + END IF +* +* Copy the vector x or Q*x to VL and normalize. +* + IF( .NOT.OVER ) THEN + CALL ZCOPY( N-KI+1, WORK( KI ), 1, VL( KI, IS ), 1 ) +* + II = IZAMAX( N-KI+1, VL( KI, IS ), 1 ) + KI - 1 + REMAX = ONE / CABS1( VL( II, IS ) ) + CALL ZDSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 ) +* + DO 110 K = 1, KI - 1 + VL( K, IS ) = CMZERO + 110 CONTINUE + ELSE + IF( KI.LT.N ) + $ CALL ZGEMV( 'N', N, N-KI, CMONE, VL( 1, KI+1 ), LDVL, + $ WORK( KI+1 ), 1, DCMPLX( SCALE ), + $ VL( 1, KI ), 1 ) +* + II = IZAMAX( N, VL( 1, KI ), 1 ) + REMAX = ONE / CABS1( VL( II, KI ) ) + CALL ZDSCAL( N, REMAX, VL( 1, KI ), 1 ) + END IF +* +* Set back the original diagonal elements of T. +* + DO 120 K = KI + 1, N + T( K, K ) = WORK( K+N ) + 120 CONTINUE +* + IS = IS + 1 + 130 CONTINUE + END IF +* + RETURN +* +* End of ZTREVC +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/complex16/ztrexc.f b/fortran_implementation/external_libraries/lapack_routines/complex16/ztrexc.f new file mode 100644 index 0000000..e259e12 --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/complex16/ztrexc.f @@ -0,0 +1,163 @@ + SUBROUTINE ZTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER COMPQ + INTEGER IFST, ILST, INFO, LDQ, LDT, N +* .. +* .. Array Arguments .. + COMPLEX*16 Q( LDQ, * ), T( LDT, * ) +* .. +* +* Purpose +* ======= +* +* ZTREXC reorders the Schur factorization of a complex matrix +* A = Q*T*Q**H, so that the diagonal element of T with row index IFST +* is moved to row ILST. +* +* The Schur form T is reordered by a unitary similarity transformation +* Z**H*T*Z, and optionally the matrix Q of Schur vectors is updated by +* postmultplying it with Z. +* +* Arguments +* ========= +* +* COMPQ (input) CHARACTER*1 +* = 'V': update the matrix Q of Schur vectors; +* = 'N': do not update Q. +* +* N (input) INTEGER +* The order of the matrix T. N >= 0. +* +* T (input/output) COMPLEX*16 array, dimension (LDT,N) +* On entry, the upper triangular matrix T. +* On exit, the reordered upper triangular matrix. +* +* LDT (input) INTEGER +* The leading dimension of the array T. LDT >= max(1,N). +* +* Q (input/output) COMPLEX*16 array, dimension (LDQ,N) +* On entry, if COMPQ = 'V', the matrix Q of Schur vectors. +* On exit, if COMPQ = 'V', Q has been postmultiplied by the +* unitary transformation matrix Z which reorders T. +* If COMPQ = 'N', Q is not referenced. +* +* LDQ (input) INTEGER +* The leading dimension of the array Q. LDQ >= max(1,N). +* +* IFST (input) INTEGER +* ILST (input) INTEGER +* Specify the reordering of the diagonal elements of T: +* The element with row index IFST is moved to row ILST by a +* sequence of transpositions between adjacent elements. +* 1 <= IFST <= N; 1 <= ILST <= N. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL WANTQ + INTEGER K, M1, M2, M3 + DOUBLE PRECISION CS + COMPLEX*16 SN, T11, T22, TEMP +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLARTG, ZROT +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG, MAX +* .. +* .. Executable Statements .. +* +* Decode and test the input parameters. +* + INFO = 0 + WANTQ = LSAME( COMPQ, 'V' ) + IF( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.MAX( 1, N ) ) ) THEN + INFO = -6 + ELSE IF( IFST.LT.1 .OR. IFST.GT.N ) THEN + INFO = -7 + ELSE IF( ILST.LT.1 .OR. ILST.GT.N ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZTREXC', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.1 .OR. IFST.EQ.ILST ) + $ RETURN +* + IF( IFST.LT.ILST ) THEN +* +* Move the IFST-th diagonal element forward down the diagonal. +* + M1 = 0 + M2 = -1 + M3 = 1 + ELSE +* +* Move the IFST-th diagonal element backward up the diagonal. +* + M1 = -1 + M2 = 0 + M3 = -1 + END IF +* + DO 10 K = IFST + M1, ILST + M2, M3 +* +* Interchange the k-th and (k+1)-th diagonal elements. +* + T11 = T( K, K ) + T22 = T( K+1, K+1 ) +* +* Determine the transformation to perform the interchange. +* + CALL ZLARTG( T( K, K+1 ), T22-T11, CS, SN, TEMP ) +* +* Apply transformation to the matrix T. +* + IF( K+2.LE.N ) + $ CALL ZROT( N-K-1, T( K, K+2 ), LDT, T( K+1, K+2 ), LDT, CS, + $ SN ) + CALL ZROT( K-1, T( 1, K ), 1, T( 1, K+1 ), 1, CS, + $ DCONJG( SN ) ) +* + T( K, K ) = T22 + T( K+1, K+1 ) = T11 +* + IF( WANTQ ) THEN +* +* Accumulate transformation in the matrix Q. +* + CALL ZROT( N, Q( 1, K ), 1, Q( 1, K+1 ), 1, CS, + $ DCONJG( SN ) ) + END IF +* + 10 CONTINUE +* + RETURN +* +* End of ZTREXC +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/complex16/zung2r.f b/fortran_implementation/external_libraries/lapack_routines/complex16/zung2r.f new file mode 100644 index 0000000..d328103 --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/complex16/zung2r.f @@ -0,0 +1,131 @@ + SUBROUTINE ZUNG2R( M, N, K, A, LDA, TAU, WORK, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDA, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* ZUNG2R generates an m by n complex matrix Q with orthonormal columns, +* which is defined as the first n columns of a product of k elementary +* reflectors of order m +* +* Q = H(1) H(2) . . . H(k) +* +* as returned by ZGEQRF. +* +* Arguments +* ========= +* +* M (input) INTEGER +* The number of rows of the matrix Q. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix Q. M >= N >= 0. +* +* K (input) INTEGER +* The number of elementary reflectors whose product defines the +* matrix Q. N >= K >= 0. +* +* A (input/output) COMPLEX*16 array, dimension (LDA,N) +* On entry, the i-th column must contain the vector which +* defines the elementary reflector H(i), for i = 1,2,...,k, as +* returned by ZGEQRF in the first k columns of its array +* argument A. +* On exit, the m by n matrix Q. +* +* LDA (input) INTEGER +* The first dimension of the array A. LDA >= max(1,M). +* +* TAU (input) COMPLEX*16 array, dimension (K) +* TAU(i) must contain the scalar factor of the elementary +* reflector H(i), as returned by ZGEQRF. +* +* WORK (workspace) COMPLEX*16 array, dimension (N) +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument has an illegal value +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE, ZERO + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), + $ ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, J, L +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLARF, ZSCAL +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 .OR. N.GT.M ) THEN + INFO = -2 + ELSE IF( K.LT.0 .OR. K.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZUNG2R', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.0 ) + $ RETURN +* +* Initialise columns k+1:n to columns of the unit matrix +* + DO 20 J = K + 1, N + DO 10 L = 1, M + A( L, J ) = ZERO + 10 CONTINUE + A( J, J ) = ONE + 20 CONTINUE +* + DO 40 I = K, 1, -1 +* +* Apply H(i) to A(i:m,i:n) from the left +* + IF( I.LT.N ) THEN + A( I, I ) = ONE + CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), + $ A( I, I+1 ), LDA, WORK ) + END IF + IF( I.LT.M ) + $ CALL ZSCAL( M-I, -TAU( I ), A( I+1, I ), 1 ) + A( I, I ) = ONE - TAU( I ) +* +* Set A(1:i-1,i) to zero +* + DO 30 L = 1, I - 1 + A( L, I ) = ZERO + 30 CONTINUE + 40 CONTINUE + RETURN +* +* End of ZUNG2R +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/complex16/zunghr.f b/fortran_implementation/external_libraries/lapack_routines/complex16/zunghr.f new file mode 100644 index 0000000..e887fdf --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/complex16/zunghr.f @@ -0,0 +1,166 @@ + SUBROUTINE ZUNGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + INTEGER IHI, ILO, INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* ZUNGHR generates a complex unitary matrix Q which is defined as the +* product of IHI-ILO elementary reflectors of order N, as returned by +* ZGEHRD: +* +* Q = H(ilo) H(ilo+1) . . . H(ihi-1). +* +* Arguments +* ========= +* +* N (input) INTEGER +* The order of the matrix Q. N >= 0. +* +* ILO (input) INTEGER +* IHI (input) INTEGER +* ILO and IHI must have the same values as in the previous call +* of ZGEHRD. Q is equal to the unit matrix except in the +* submatrix Q(ilo+1:ihi,ilo+1:ihi). +* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. +* +* A (input/output) COMPLEX*16 array, dimension (LDA,N) +* On entry, the vectors which define the elementary reflectors, +* as returned by ZGEHRD. +* On exit, the N-by-N unitary matrix Q. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* TAU (input) COMPLEX*16 array, dimension (N-1) +* TAU(i) must contain the scalar factor of the elementary +* reflector H(i), as returned by ZGEHRD. +* +* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) +* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +* +* LWORK (input) INTEGER +* The dimension of the array WORK. LWORK >= IHI-ILO. +* For optimum performance LWORK >= (IHI-ILO)*NB, where NB is +* the optimal blocksize. +* +* If LWORK = -1, then a workspace query is assumed; the routine +* only calculates the optimal size of the WORK array, returns +* this value as the first entry of the WORK array, and no error +* message related to LWORK is issued by XERBLA. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), + $ ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, IINFO, J, LWKOPT, NB, NH +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZUNGQR +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + NH = IHI - ILO + LQUERY = ( LWORK.EQ.-1 ) + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN + INFO = -2 + ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LWORK.LT.MAX( 1, NH ) .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF +* + IF( INFO.EQ.0 ) THEN + NB = ILAENV( 1, 'ZUNGQR', ' ', NH, NH, NH, -1 ) + LWKOPT = MAX( 1, NH )*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZUNGHR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* +* Shift the vectors which define the elementary reflectors one +* column to the right, and set the first ilo and the last n-ihi +* rows and columns to those of the unit matrix +* + DO 40 J = IHI, ILO + 1, -1 + DO 10 I = 1, J - 1 + A( I, J ) = ZERO + 10 CONTINUE + DO 20 I = J + 1, IHI + A( I, J ) = A( I, J-1 ) + 20 CONTINUE + DO 30 I = IHI + 1, N + A( I, J ) = ZERO + 30 CONTINUE + 40 CONTINUE + DO 60 J = 1, ILO + DO 50 I = 1, N + A( I, J ) = ZERO + 50 CONTINUE + A( J, J ) = ONE + 60 CONTINUE + DO 80 J = IHI + 1, N + DO 70 I = 1, N + A( I, J ) = ZERO + 70 CONTINUE + A( J, J ) = ONE + 80 CONTINUE +* + IF( NH.GT.0 ) THEN +* +* Generate Q(ilo+1:ihi,ilo+1:ihi) +* + CALL ZUNGQR( NH, NH, NH, A( ILO+1, ILO+1 ), LDA, TAU( ILO ), + $ WORK, LWORK, IINFO ) + END IF + WORK( 1 ) = LWKOPT + RETURN +* +* End of ZUNGHR +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/complex16/zungqr.f b/fortran_implementation/external_libraries/lapack_routines/complex16/zungqr.f new file mode 100644 index 0000000..372c387 --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/complex16/zungqr.f @@ -0,0 +1,217 @@ + SUBROUTINE ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* ZUNGQR generates an M-by-N complex matrix Q with orthonormal columns, +* which is defined as the first N columns of a product of K elementary +* reflectors of order M +* +* Q = H(1) H(2) . . . H(k) +* +* as returned by ZGEQRF. +* +* Arguments +* ========= +* +* M (input) INTEGER +* The number of rows of the matrix Q. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix Q. M >= N >= 0. +* +* K (input) INTEGER +* The number of elementary reflectors whose product defines the +* matrix Q. N >= K >= 0. +* +* A (input/output) COMPLEX*16 array, dimension (LDA,N) +* On entry, the i-th column must contain the vector which +* defines the elementary reflector H(i), for i = 1,2,...,k, as +* returned by ZGEQRF in the first k columns of its array +* argument A. +* On exit, the M-by-N matrix Q. +* +* LDA (input) INTEGER +* The first dimension of the array A. LDA >= max(1,M). +* +* TAU (input) COMPLEX*16 array, dimension (K) +* TAU(i) must contain the scalar factor of the elementary +* reflector H(i), as returned by ZGEQRF. +* +* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) +* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +* +* LWORK (input) INTEGER +* The dimension of the array WORK. LWORK >= max(1,N). +* For optimum performance LWORK >= N*NB, where NB is the +* optimal blocksize. +* +* If LWORK = -1, then a workspace query is assumed; the routine +* only calculates the optimal size of the WORK array, returns +* this value as the first entry of the WORK array, and no error +* message related to LWORK is issued by XERBLA. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument has an illegal value +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, + $ LWKOPT, NB, NBMIN, NX +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNG2R +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + NB = ILAENV( 1, 'ZUNGQR', ' ', M, N, K, -1 ) + LWKOPT = MAX( 1, N )*NB + WORK( 1 ) = LWKOPT + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 .OR. N.GT.M ) THEN + INFO = -2 + ELSE IF( K.LT.0 .OR. K.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZUNGQR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + NBMIN = 2 + NX = 0 + IWS = N + IF( NB.GT.1 .AND. NB.LT.K ) THEN +* +* Determine when to cross over from blocked to unblocked code. +* + NX = MAX( 0, ILAENV( 3, 'ZUNGQR', ' ', M, N, K, -1 ) ) + IF( NX.LT.K ) THEN +* +* Determine if workspace is large enough for blocked code. +* + LDWORK = N + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN +* +* Not enough workspace to use optimal NB: reduce NB and +* determine the minimum value of NB. +* + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'ZUNGQR', ' ', M, N, K, -1 ) ) + END IF + END IF + END IF +* + IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN +* +* Use blocked code after the last block. +* The first kk columns are handled by the block method. +* + KI = ( ( K-NX-1 ) / NB )*NB + KK = MIN( K, KI+NB ) +* +* Set A(1:kk,kk+1:n) to zero. +* + DO 20 J = KK + 1, N + DO 10 I = 1, KK + A( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + KK = 0 + END IF +* +* Use unblocked code for the last or only block. +* + IF( KK.LT.N ) + $ CALL ZUNG2R( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA, + $ TAU( KK+1 ), WORK, IINFO ) +* + IF( KK.GT.0 ) THEN +* +* Use blocked code +* + DO 50 I = KI + 1, 1, -NB + IB = MIN( NB, K-I+1 ) + IF( I+IB.LE.N ) THEN +* +* Form the triangular factor of the block reflector +* H = H(i) H(i+1) . . . H(i+ib-1) +* + CALL ZLARFT( 'Forward', 'Columnwise', M-I+1, IB, + $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) +* +* Apply H to A(i:m,i+ib:n) from the left +* + CALL ZLARFB( 'Left', 'No transpose', 'Forward', + $ 'Columnwise', M-I+1, N-I-IB+1, IB, + $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), + $ LDA, WORK( IB+1 ), LDWORK ) + END IF +* +* Apply H to rows i:m of current block +* + CALL ZUNG2R( M-I+1, IB, IB, A( I, I ), LDA, TAU( I ), WORK, + $ IINFO ) +* +* Set rows 1:i-1 of current block to zero +* + DO 40 J = I, I + IB - 1 + DO 30 L = 1, I - 1 + A( L, J ) = ZERO + 30 CONTINUE + 40 CONTINUE + 50 CONTINUE + END IF +* + WORK( 1 ) = IWS + RETURN +* +* End of ZUNGQR +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/complex16/zunm2r.f b/fortran_implementation/external_libraries/lapack_routines/complex16/zunm2r.f new file mode 100644 index 0000000..646fd09 --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/complex16/zunm2r.f @@ -0,0 +1,202 @@ + SUBROUTINE ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, INFO ) +* +* -- LAPACK routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* ZUNM2R overwrites the general complex m-by-n matrix C with +* +* Q * C if SIDE = 'L' and TRANS = 'N', or +* +* Q**H* C if SIDE = 'L' and TRANS = 'C', or +* +* C * Q if SIDE = 'R' and TRANS = 'N', or +* +* C * Q**H if SIDE = 'R' and TRANS = 'C', +* +* where Q is a complex unitary matrix defined as the product of k +* elementary reflectors +* +* Q = H(1) H(2) . . . H(k) +* +* as returned by ZGEQRF. Q is of order m if SIDE = 'L' and of order n +* if SIDE = 'R'. +* +* Arguments +* ========= +* +* SIDE (input) CHARACTER*1 +* = 'L': apply Q or Q**H from the Left +* = 'R': apply Q or Q**H from the Right +* +* TRANS (input) CHARACTER*1 +* = 'N': apply Q (No transpose) +* = 'C': apply Q**H (Conjugate transpose) +* +* M (input) INTEGER +* The number of rows of the matrix C. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix C. N >= 0. +* +* K (input) INTEGER +* The number of elementary reflectors whose product defines +* the matrix Q. +* If SIDE = 'L', M >= K >= 0; +* if SIDE = 'R', N >= K >= 0. +* +* A (input) COMPLEX*16 array, dimension (LDA,K) +* The i-th column must contain the vector which defines the +* elementary reflector H(i), for i = 1,2,...,k, as returned by +* ZGEQRF in the first k columns of its array argument A. +* A is modified by the routine but restored on exit. +* +* LDA (input) INTEGER +* The leading dimension of the array A. +* If SIDE = 'L', LDA >= max(1,M); +* if SIDE = 'R', LDA >= max(1,N). +* +* TAU (input) COMPLEX*16 array, dimension (K) +* TAU(i) must contain the scalar factor of the elementary +* reflector H(i), as returned by ZGEQRF. +* +* C (input/output) COMPLEX*16 array, dimension (LDC,N) +* On entry, the m-by-n matrix C. +* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. +* +* LDC (input) INTEGER +* The leading dimension of the array C. LDC >= max(1,M). +* +* WORK (workspace) COMPLEX*16 array, dimension +* (N) if SIDE = 'L', +* (M) if SIDE = 'R' +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, NOTRAN + INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ + COMPLEX*16 AII, TAUI +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLARF +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG, MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) +* +* NQ is the order of Q +* + IF( LEFT ) THEN + NQ = M + ELSE + NQ = N + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZUNM2R', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) + $ RETURN +* + IF( ( LEFT .AND. .NOT.NOTRAN .OR. .NOT.LEFT .AND. NOTRAN ) ) THEN + I1 = 1 + I2 = K + I3 = 1 + ELSE + I1 = K + I2 = 1 + I3 = -1 + END IF +* + IF( LEFT ) THEN + NI = N + JC = 1 + ELSE + MI = M + IC = 1 + END IF +* + DO 10 I = I1, I2, I3 + IF( LEFT ) THEN +* +* H(i) or H(i)**H is applied to C(i:m,1:n) +* + MI = M - I + 1 + IC = I + ELSE +* +* H(i) or H(i)**H is applied to C(1:m,i:n) +* + NI = N - I + 1 + JC = I + END IF +* +* Apply H(i) or H(i)**H +* + IF( NOTRAN ) THEN + TAUI = TAU( I ) + ELSE + TAUI = DCONJG( TAU( I ) ) + END IF + AII = A( I, I ) + A( I, I ) = ONE + CALL ZLARF( SIDE, MI, NI, A( I, I ), 1, TAUI, C( IC, JC ), LDC, + $ WORK ) + A( I, I ) = AII + 10 CONTINUE + RETURN +* +* End of ZUNM2R +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/complex16/zunmhr.f b/fortran_implementation/external_libraries/lapack_routines/complex16/zunmhr.f new file mode 100644 index 0000000..da0cb7e --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/complex16/zunmhr.f @@ -0,0 +1,202 @@ + SUBROUTINE ZUNMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, + $ LDC, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER IHI, ILO, INFO, LDA, LDC, LWORK, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* ZUNMHR overwrites the general complex M-by-N matrix C with +* +* SIDE = 'L' SIDE = 'R' +* TRANS = 'N': Q * C C * Q +* TRANS = 'C': Q**H * C C * Q**H +* +* where Q is a complex unitary matrix of order nq, with nq = m if +* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of +* IHI-ILO elementary reflectors, as returned by ZGEHRD: +* +* Q = H(ilo) H(ilo+1) . . . H(ihi-1). +* +* Arguments +* ========= +* +* SIDE (input) CHARACTER*1 +* = 'L': apply Q or Q**H from the Left; +* = 'R': apply Q or Q**H from the Right. +* +* TRANS (input) CHARACTER*1 +* = 'N': apply Q (No transpose) +* = 'C': apply Q**H (Conjugate transpose) +* +* M (input) INTEGER +* The number of rows of the matrix C. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix C. N >= 0. +* +* ILO (input) INTEGER +* IHI (input) INTEGER +* ILO and IHI must have the same values as in the previous call +* of ZGEHRD. Q is equal to the unit matrix except in the +* submatrix Q(ilo+1:ihi,ilo+1:ihi). +* If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and +* ILO = 1 and IHI = 0, if M = 0; +* if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and +* ILO = 1 and IHI = 0, if N = 0. +* +* A (input) COMPLEX*16 array, dimension +* (LDA,M) if SIDE = 'L' +* (LDA,N) if SIDE = 'R' +* The vectors which define the elementary reflectors, as +* returned by ZGEHRD. +* +* LDA (input) INTEGER +* The leading dimension of the array A. +* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'. +* +* TAU (input) COMPLEX*16 array, dimension +* (M-1) if SIDE = 'L' +* (N-1) if SIDE = 'R' +* TAU(i) must contain the scalar factor of the elementary +* reflector H(i), as returned by ZGEHRD. +* +* C (input/output) COMPLEX*16 array, dimension (LDC,N) +* On entry, the M-by-N matrix C. +* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. +* +* LDC (input) INTEGER +* The leading dimension of the array C. LDC >= max(1,M). +* +* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) +* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +* +* LWORK (input) INTEGER +* The dimension of the array WORK. +* If SIDE = 'L', LWORK >= max(1,N); +* if SIDE = 'R', LWORK >= max(1,M). +* For optimum performance LWORK >= N*NB if SIDE = 'L', and +* LWORK >= M*NB if SIDE = 'R', where NB is the optimal +* blocksize. +* +* If LWORK = -1, then a workspace query is assumed; the routine +* only calculates the optimal size of the WORK array, returns +* this value as the first entry of the WORK array, and no error +* message related to LWORK is issued by XERBLA. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LEFT, LQUERY + INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NH, NI, NQ, NW +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZUNMQR +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + NH = IHI - ILO + LEFT = LSAME( SIDE, 'L' ) + LQUERY = ( LWORK.EQ.-1 ) +* +* NQ is the order of Q and NW is the minimum dimension of WORK +* + IF( LEFT ) THEN + NQ = M + NW = N + ELSE + NQ = N + NW = M + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) + $ THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, NQ ) ) THEN + INFO = -5 + ELSE IF( IHI.LT.MIN( ILO, NQ ) .OR. IHI.GT.NQ ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -11 + ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN + INFO = -13 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( LEFT ) THEN + NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, NH, N, NH, -1 ) + ELSE + NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M, NH, NH, -1 ) + END IF + LWKOPT = MAX( 1, NW )*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZUNMHR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. NH.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + IF( LEFT ) THEN + MI = NH + NI = N + I1 = ILO + 1 + I2 = 1 + ELSE + MI = M + NI = NH + I1 = 1 + I2 = ILO + 1 + END IF +* + CALL ZUNMQR( SIDE, TRANS, MI, NI, NH, A( ILO+1, ILO ), LDA, + $ TAU( ILO ), C( I1, I2 ), LDC, WORK, LWORK, IINFO ) +* + WORK( 1 ) = LWKOPT + RETURN +* +* End of ZUNMHR +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/complex16/zunmqr.f b/fortran_implementation/external_libraries/lapack_routines/complex16/zunmqr.f new file mode 100644 index 0000000..25a2440 --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/complex16/zunmqr.f @@ -0,0 +1,261 @@ + SUBROUTINE ZUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, LWORK, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* ZUNMQR overwrites the general complex M-by-N matrix C with +* +* SIDE = 'L' SIDE = 'R' +* TRANS = 'N': Q * C C * Q +* TRANS = 'C': Q**H * C C * Q**H +* +* where Q is a complex unitary matrix defined as the product of k +* elementary reflectors +* +* Q = H(1) H(2) . . . H(k) +* +* as returned by ZGEQRF. Q is of order M if SIDE = 'L' and of order N +* if SIDE = 'R'. +* +* Arguments +* ========= +* +* SIDE (input) CHARACTER*1 +* = 'L': apply Q or Q**H from the Left; +* = 'R': apply Q or Q**H from the Right. +* +* TRANS (input) CHARACTER*1 +* = 'N': No transpose, apply Q; +* = 'C': Conjugate transpose, apply Q**H. +* +* M (input) INTEGER +* The number of rows of the matrix C. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix C. N >= 0. +* +* K (input) INTEGER +* The number of elementary reflectors whose product defines +* the matrix Q. +* If SIDE = 'L', M >= K >= 0; +* if SIDE = 'R', N >= K >= 0. +* +* A (input) COMPLEX*16 array, dimension (LDA,K) +* The i-th column must contain the vector which defines the +* elementary reflector H(i), for i = 1,2,...,k, as returned by +* ZGEQRF in the first k columns of its array argument A. +* A is modified by the routine but restored on exit. +* +* LDA (input) INTEGER +* The leading dimension of the array A. +* If SIDE = 'L', LDA >= max(1,M); +* if SIDE = 'R', LDA >= max(1,N). +* +* TAU (input) COMPLEX*16 array, dimension (K) +* TAU(i) must contain the scalar factor of the elementary +* reflector H(i), as returned by ZGEQRF. +* +* C (input/output) COMPLEX*16 array, dimension (LDC,N) +* On entry, the M-by-N matrix C. +* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. +* +* LDC (input) INTEGER +* The leading dimension of the array C. LDC >= max(1,M). +* +* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) +* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +* +* LWORK (input) INTEGER +* The dimension of the array WORK. +* If SIDE = 'L', LWORK >= max(1,N); +* if SIDE = 'R', LWORK >= max(1,M). +* For optimum performance LWORK >= N*NB if SIDE = 'L', and +* LWORK >= M*NB if SIDE = 'R', where NB is the optimal +* blocksize. +* +* If LWORK = -1, then a workspace query is assumed; the routine +* only calculates the optimal size of the WORK array, returns +* this value as the first entry of the WORK array, and no error +* message related to LWORK is issued by XERBLA. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NBMAX, LDT + PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, LQUERY, NOTRAN + INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK, + $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW +* .. +* .. Local Arrays .. + COMPLEX*16 T( LDT, NBMAX ) +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNM2R +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) + LQUERY = ( LWORK.EQ.-1 ) +* +* NQ is the order of Q and NW is the minimum dimension of WORK +* + IF( LEFT ) THEN + NQ = M + NW = N + ELSE + NQ = N + NW = M + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN + INFO = -12 + END IF +* + IF( INFO.EQ.0 ) THEN +* +* Determine the block size. NB may be at most NBMAX, where NBMAX +* is used to define the local array T. +* + NB = MIN( NBMAX, ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M, N, K, + $ -1 ) ) + LWKOPT = MAX( 1, NW )*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZUNMQR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + NBMIN = 2 + LDWORK = NW + IF( NB.GT.1 .AND. NB.LT.K ) THEN + IWS = NW*NB + IF( LWORK.LT.IWS ) THEN + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'ZUNMQR', SIDE // TRANS, M, N, K, + $ -1 ) ) + END IF + ELSE + IWS = NW + END IF +* + IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN +* +* Use unblocked code +* + CALL ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, + $ IINFO ) + ELSE +* +* Use blocked code +* + IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. + $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN + I1 = 1 + I2 = K + I3 = NB + ELSE + I1 = ( ( K-1 ) / NB )*NB + 1 + I2 = 1 + I3 = -NB + END IF +* + IF( LEFT ) THEN + NI = N + JC = 1 + ELSE + MI = M + IC = 1 + END IF +* + DO 10 I = I1, I2, I3 + IB = MIN( NB, K-I+1 ) +* +* Form the triangular factor of the block reflector +* H = H(i) H(i+1) . . . H(i+ib-1) +* + CALL ZLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I, I ), + $ LDA, TAU( I ), T, LDT ) + IF( LEFT ) THEN +* +* H or H**H is applied to C(i:m,1:n) +* + MI = M - I + 1 + IC = I + ELSE +* +* H or H**H is applied to C(1:m,i:n) +* + NI = N - I + 1 + JC = I + END IF +* +* Apply H or H**H +* + CALL ZLARFB( SIDE, TRANS, 'Forward', 'Columnwise', MI, NI, + $ IB, A( I, I ), LDA, T, LDT, C( IC, JC ), LDC, + $ WORK, LDWORK ) + 10 CONTINUE + END IF + WORK( 1 ) = LWKOPT + RETURN +* +* End of ZUNMQR +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/lapack_routine/dcabs1.f b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/dcabs1.f new file mode 100644 index 0000000..6505ffc --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/dcabs1.f @@ -0,0 +1,66 @@ +*> \brief \b DCABS1 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DCABS1(Z) +* +* .. Scalar Arguments .. +* COMPLEX*16 Z +* .. +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DCABS1 computes |Re(.)| + |Im(.)| of a double complex number +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] Z +*> \verbatim +*> Z is COMPLEX*16 +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup abs1 +* +* ===================================================================== + DOUBLE PRECISION FUNCTION DCABS1(Z) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX*16 Z +* .. +* .. +* ===================================================================== +* +* .. Intrinsic Functions .. + INTRINSIC ABS,DBLE,DIMAG +* + DCABS1 = ABS(DBLE(Z)) + ABS(DIMAG(Z)) + RETURN +* +* End of DCABS1 +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/lapack_routine/disnan.f b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/disnan.f new file mode 100644 index 0000000..fd59cfd --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/disnan.f @@ -0,0 +1,77 @@ +*> \brief \b DISNAN tests input for NaN. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DISNAN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* LOGICAL FUNCTION DISNAN( DIN ) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION, INTENT(IN) :: DIN +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DISNAN returns .TRUE. if its argument is NaN, and .FALSE. +*> otherwise. To be replaced by the Fortran 2003 intrinsic in the +*> future. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DIN +*> \verbatim +*> DIN is DOUBLE PRECISION +*> Input to test for NaN. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup isnan +* +* ===================================================================== + LOGICAL FUNCTION DISNAN( DIN ) +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + DOUBLE PRECISION, INTENT(IN) :: DIN +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL DLAISNAN + EXTERNAL DLAISNAN +* .. +* .. Executable Statements .. + DISNAN = DLAISNAN(DIN,DIN) + RETURN + END diff --git a/fortran_implementation/external_libraries/lapack_routines/lapack_routine/dlabad.f b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/dlabad.f new file mode 100644 index 0000000..da90494 --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/dlabad.f @@ -0,0 +1,96 @@ +*> \brief \b DLABAD +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLABAD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLABAD( SMALL, LARGE ) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION LARGE, SMALL +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLABAD is a no-op and kept for compatibility reasons. It used +*> to correct the overflow/underflow behavior of machines that +*> are not IEEE-754 compliant. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in,out] SMALL +*> \verbatim +*> SMALL is DOUBLE PRECISION +*> On entry, the underflow threshold as computed by DLAMCH. +*> On exit, the unchanged value SMALL. +*> \endverbatim +*> +*> \param[in,out] LARGE +*> \verbatim +*> LARGE is DOUBLE PRECISION +*> On entry, the overflow threshold as computed by DLAMCH. +*> On exit, the unchanged value LARGE. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup labad +* +* ===================================================================== + SUBROUTINE DLABAD( SMALL, LARGE ) +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + DOUBLE PRECISION LARGE, SMALL +* .. +* +* ===================================================================== +* +* .. Intrinsic Functions .. + INTRINSIC LOG10, SQRT +* .. +* .. Executable Statements .. +* +* If it looks like we're on a Cray, take the square root of +* SMALL and LARGE to avoid overflow and underflow problems. +* +* IF( LOG10( LARGE ).GT.2000.D0 ) THEN +* SMALL = SQRT( SMALL ) +* LARGE = SQRT( LARGE ) +* END IF +* + RETURN +* +* End of DLABAD +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/lapack_routine/dladiv.f b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/dladiv.f new file mode 100644 index 0000000..a0fbe1a --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/dladiv.f @@ -0,0 +1,251 @@ +*> \brief \b DLADIV performs complex division in real arithmetic, avoiding unnecessary overflow. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLADIV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLADIV( A, B, C, D, P, Q ) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION A, B, C, D, P, Q +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLADIV performs complex division in real arithmetic +*> +*> a + i*b +*> p + i*q = --------- +*> c + i*d +*> +*> The algorithm is due to Michael Baudin and Robert L. Smith +*> and can be found in the paper +*> "A Robust Complex Division in Scilab" +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] C +*> \verbatim +*> C is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is DOUBLE PRECISION +*> The scalars a, b, c, and d in the above expression. +*> \endverbatim +*> +*> \param[out] P +*> \verbatim +*> P is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[out] Q +*> \verbatim +*> Q is DOUBLE PRECISION +*> The scalars p and q in the above expression. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup ladiv +* +* ===================================================================== + SUBROUTINE DLADIV( A, B, C, D, P, Q ) +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + DOUBLE PRECISION A, B, C, D, P, Q +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION BS + PARAMETER ( BS = 2.0D0 ) + DOUBLE PRECISION HALF + PARAMETER ( HALF = 0.5D0 ) + DOUBLE PRECISION TWO + PARAMETER ( TWO = 2.0D0 ) +* +* .. Local Scalars .. + DOUBLE PRECISION AA, BB, CC, DD, AB, CD, S, OV, UN, BE, EPS +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DLADIV1 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* + AA = A + BB = B + CC = C + DD = D + AB = MAX( ABS(A), ABS(B) ) + CD = MAX( ABS(C), ABS(D) ) + S = 1.0D0 + + OV = DLAMCH( 'Overflow threshold' ) + UN = DLAMCH( 'Safe minimum' ) + EPS = DLAMCH( 'Epsilon' ) + BE = BS / (EPS*EPS) + + IF( AB >= HALF*OV ) THEN + AA = HALF * AA + BB = HALF * BB + S = TWO * S + END IF + IF( CD >= HALF*OV ) THEN + CC = HALF * CC + DD = HALF * DD + S = HALF * S + END IF + IF( AB <= UN*BS/EPS ) THEN + AA = AA * BE + BB = BB * BE + S = S / BE + END IF + IF( CD <= UN*BS/EPS ) THEN + CC = CC * BE + DD = DD * BE + S = S * BE + END IF + IF( ABS( D ).LE.ABS( C ) ) THEN + CALL DLADIV1(AA, BB, CC, DD, P, Q) + ELSE + CALL DLADIV1(BB, AA, DD, CC, P, Q) + Q = -Q + END IF + P = P * S + Q = Q * S +* + RETURN +* +* End of DLADIV +* + END + +*> \ingroup ladiv + + + SUBROUTINE DLADIV1( A, B, C, D, P, Q ) +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + DOUBLE PRECISION A, B, C, D, P, Q +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +* +* .. Local Scalars .. + DOUBLE PRECISION R, T +* .. +* .. External Functions .. + DOUBLE PRECISION DLADIV2 + EXTERNAL DLADIV2 +* .. +* .. Executable Statements .. +* + R = D / C + T = ONE / (C + D * R) + P = DLADIV2(A, B, C, D, R, T) + A = -A + Q = DLADIV2(B, A, C, D, R, T) +* + RETURN +* +* End of DLADIV1 +* + END + +*> \ingroup ladiv + + DOUBLE PRECISION FUNCTION DLADIV2( A, B, C, D, R, T ) +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + DOUBLE PRECISION A, B, C, D, R, T +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +* +* .. Local Scalars .. + DOUBLE PRECISION BR +* .. +* .. Executable Statements .. +* + IF( R.NE.ZERO ) THEN + BR = B * R + IF( BR.NE.ZERO ) THEN + DLADIV2 = (A + BR) * T + ELSE + DLADIV2 = A * T + (B * T) * R + END IF + ELSE + DLADIV2 = (A + D * (B / C)) * T + END IF +* + RETURN +* +* End of DLADIV2 +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/lapack_routine/dlaisnan.f b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/dlaisnan.f new file mode 100644 index 0000000..d879d9e --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/dlaisnan.f @@ -0,0 +1,88 @@ +*> \brief \b DLAISNAN tests input for NaN by comparing two arguments for inequality. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAISNAN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* LOGICAL FUNCTION DLAISNAN( DIN1, DIN2 ) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION, INTENT(IN) :: DIN1, DIN2 +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> This routine is not for general use. It exists solely to avoid +*> over-optimization in DISNAN. +*> +*> DLAISNAN checks for NaNs by comparing its two arguments for +*> inequality. NaN is the only floating-point value where NaN != NaN +*> returns .TRUE. To check for NaNs, pass the same variable as both +*> arguments. +*> +*> A compiler must assume that the two arguments are +*> not the same variable, and the test will not be optimized away. +*> Interprocedural or whole-program optimization may delete this +*> test. The ISNAN functions will be replaced by the correct +*> Fortran 03 intrinsic once the intrinsic is widely available. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DIN1 +*> \verbatim +*> DIN1 is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] DIN2 +*> \verbatim +*> DIN2 is DOUBLE PRECISION +*> Two numbers to compare for inequality. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup laisnan +* +* ===================================================================== + LOGICAL FUNCTION DLAISNAN( DIN1, DIN2 ) +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + DOUBLE PRECISION, INTENT(IN) :: DIN1, DIN2 +* .. +* +* ===================================================================== +* +* .. Executable Statements .. + DLAISNAN = (DIN1.NE.DIN2) + RETURN + END diff --git a/fortran_implementation/external_libraries/lapack_routines/lapack_routine/dlapy2.f b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/dlapy2.f new file mode 100644 index 0000000..627cacc --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/dlapy2.f @@ -0,0 +1,117 @@ +*> \brief \b DLAPY2 returns sqrt(x2+y2). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAPY2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION X, Y +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary +*> overflow and unnecessary underflow. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] X +*> \verbatim +*> X is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] Y +*> \verbatim +*> Y is DOUBLE PRECISION +*> X and Y specify the values x and y. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup lapy2 +* +* ===================================================================== + DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + DOUBLE PRECISION X, Y +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION W, XABS, YABS, Z, HUGEVAL + LOGICAL X_IS_NAN, Y_IS_NAN +* .. +* .. External Functions .. + LOGICAL DISNAN + EXTERNAL DISNAN +* .. +* .. External Subroutines .. + DOUBLE PRECISION DLAMCH +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* + X_IS_NAN = DISNAN( X ) + Y_IS_NAN = DISNAN( Y ) + IF ( X_IS_NAN ) DLAPY2 = X + IF ( Y_IS_NAN ) DLAPY2 = Y + HUGEVAL = DLAMCH( 'Overflow' ) +* + IF ( .NOT.( X_IS_NAN.OR.Y_IS_NAN ) ) THEN + XABS = ABS( X ) + YABS = ABS( Y ) + W = MAX( XABS, YABS ) + Z = MIN( XABS, YABS ) + IF( Z.EQ.ZERO .OR. W.GT.HUGEVAL ) THEN + DLAPY2 = W + ELSE + DLAPY2 = W*SQRT( ONE+( Z / W )**2 ) + END IF + END IF + RETURN +* +* End of DLAPY2 +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/lapack_routine/dlapy3.f b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/dlapy3.f new file mode 100644 index 0000000..b5974fb --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/dlapy3.f @@ -0,0 +1,112 @@ +*> \brief \b DLAPY3 returns sqrt(x2+y2+z2). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAPY3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z ) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION X, Y, Z +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause +*> unnecessary overflow and unnecessary underflow. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] X +*> \verbatim +*> X is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] Y +*> \verbatim +*> Y is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] Z +*> \verbatim +*> Z is DOUBLE PRECISION +*> X, Y and Z specify the values x, y and z. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup lapy3 +* +* ===================================================================== + DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z ) +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + DOUBLE PRECISION X, Y, Z +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION W, XABS, YABS, ZABS, HUGEVAL +* .. +* .. External Subroutines .. + DOUBLE PRECISION DLAMCH +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +* .. +* .. Executable Statements .. +* + HUGEVAL = DLAMCH( 'Overflow' ) + XABS = ABS( X ) + YABS = ABS( Y ) + ZABS = ABS( Z ) + W = MAX( XABS, YABS, ZABS ) + IF( W.EQ.ZERO .OR. W.GT.HUGEVAL ) THEN +* W can be zero for max(0,nan,0) +* adding all three entries together will make sure +* NaN will not disappear. + DLAPY3 = XABS + YABS + ZABS + ELSE + DLAPY3 = W*SQRT( ( XABS / W )**2+( YABS / W )**2+ + $ ( ZABS / W )**2 ) + END IF + RETURN +* +* End of DLAPY3 +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/lapack_routine/dscal.f b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/dscal.f new file mode 100644 index 0000000..625afba --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/dscal.f @@ -0,0 +1,139 @@ +*> \brief \b DSCAL +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DSCAL(N,DA,DX,INCX) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION DA +* INTEGER INCX,N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION DX(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSCAL scales a vector by a constant. +*> uses unrolled loops for increment equal to 1. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] DA +*> \verbatim +*> DA is DOUBLE PRECISION +*> On entry, DA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in,out] DX +*> \verbatim +*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of DX +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup scal +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, linpack, 3/11/78. +*> modified 3/93 to return if incx .le. 0. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DSCAL(N,DA,DX,INCX) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + DOUBLE PRECISION DA + INTEGER INCX,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DX(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,M,MP1,NINCX +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER (ONE=1.0D+0) +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. + IF (N.LE.0 .OR. INCX.LE.0 .OR. DA.EQ.ONE) RETURN + IF (INCX.EQ.1) THEN +* +* code for increment equal to 1 +* +* +* clean-up loop +* + M = MOD(N,5) + IF (M.NE.0) THEN + DO I = 1,M + DX(I) = DA*DX(I) + END DO + IF (N.LT.5) RETURN + END IF + MP1 = M + 1 + DO I = MP1,N,5 + DX(I) = DA*DX(I) + DX(I+1) = DA*DX(I+1) + DX(I+2) = DA*DX(I+2) + DX(I+3) = DA*DX(I+3) + DX(I+4) = DA*DX(I+4) + END DO + ELSE +* +* code for increment not equal to 1 +* + NINCX = N*INCX + DO I = 1,NINCX,INCX + DX(I) = DA*DX(I) + END DO + END IF + RETURN +* +* End of DSCAL +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/lapack_routine/dzasum.f b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/dzasum.f new file mode 100644 index 0000000..98f45b0 --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/dzasum.f @@ -0,0 +1,118 @@ +*> \brief \b DZASUM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DZASUM(N,ZX,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,N +* .. +* .. Array Arguments .. +* COMPLEX*16 ZX(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DZASUM takes the sum of the (|Re(.)| + |Im(.)|)'s of a complex vector and +*> returns a double precision result. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in,out] ZX +*> \verbatim +*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of ZX +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup asum +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, 3/11/78. +*> modified 3/93 to return if incx .le. 0. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + DOUBLE PRECISION FUNCTION DZASUM(N,ZX,INCX) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,N +* .. +* .. Array Arguments .. + COMPLEX*16 ZX(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + DOUBLE PRECISION STEMP + INTEGER I,NINCX +* .. +* .. External Functions .. + DOUBLE PRECISION DCABS1 + EXTERNAL DCABS1 +* .. + DZASUM = 0.0d0 + STEMP = 0.0d0 + IF (N.LE.0 .OR. INCX.LE.0) RETURN + IF (INCX.EQ.1) THEN +* +* code for increment equal to 1 +* + DO I = 1,N + STEMP = STEMP + DCABS1(ZX(I)) + END DO + ELSE +* +* code for increment not equal to 1 +* + NINCX = N*INCX + DO I = 1,NINCX,INCX + STEMP = STEMP + DCABS1(ZX(I)) + END DO + END IF + DZASUM = STEMP + RETURN +* +* End of DZASUM +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/lapack_routine/dznrm2.f90 b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/dznrm2.f90 new file mode 100644 index 0000000..f8e5ce0 --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/dznrm2.f90 @@ -0,0 +1,209 @@ +!> \brief \b DZNRM2 +! +! =========== DOCUMENTATION =========== +! +! Online html documentation available at +! http://www.netlib.org/lapack/explore-html/ +! +! Definition: +! =========== +! +! DOUBLE PRECISION FUNCTION DZNRM2(N,X,INCX) +! +! .. Scalar Arguments .. +! INTEGER INCX,N +! .. +! .. Array Arguments .. +! DOUBLE COMPLEX X(*) +! .. +! +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> DZNRM2 returns the euclidean norm of a vector via the function +!> name, so that +!> +!> DZNRM2 := sqrt( x**H*x ) +!> \endverbatim +! +! Arguments: +! ========== +! +!> \param[in] N +!> \verbatim +!> N is INTEGER +!> number of elements in input vector(s) +!> \endverbatim +!> +!> \param[in] X +!> \verbatim +!> X is COMPLEX*16 array, dimension (N) +!> complex vector with N elements +!> \endverbatim +!> +!> \param[in] INCX +!> \verbatim +!> INCX is INTEGER, storage spacing between elements of X +!> If INCX > 0, X(1+(i-1)*INCX) = x(i) for 1 <= i <= n +!> If INCX < 0, X(1-(n-i)*INCX) = x(i) for 1 <= i <= n +!> If INCX = 0, x isn't a vector so there is no need to call +!> this subroutine. If you call it anyway, it will count x(1) +!> in the vector norm N times. +!> \endverbatim +! +! Authors: +! ======== +! +!> \author Edward Anderson, Lockheed Martin +! +!> \date August 2016 +! +!> \ingroup nrm2 +! +!> \par Contributors: +! ================== +!> +!> Weslley Pereira, University of Colorado Denver, USA +! +!> \par Further Details: +! ===================== +!> +!> \verbatim +!> +!> Anderson E. (2017) +!> Algorithm 978: Safe Scaling in the Level 1 BLAS +!> ACM Trans Math Softw 44:1--28 +!> https://doi.org/10.1145/3061665 +!> +!> Blue, James L. (1978) +!> A Portable Fortran Program to Find the Euclidean Norm of a Vector +!> ACM Trans Math Softw 4:15--23 +!> https://doi.org/10.1145/355769.355771 +!> +!> \endverbatim +!> +! ===================================================================== +function DZNRM2( n, x, incx ) + integer, parameter :: wp = kind(1.d0) + real(wp) :: DZNRM2 +! +! -- Reference BLAS level1 routine (version 3.9.1) -- +! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +! March 2021 +! +! .. Constants .. + real(wp), parameter :: zero = 0.0_wp + real(wp), parameter :: one = 1.0_wp + real(wp), parameter :: maxN = huge(0.0_wp) +! .. +! .. Blue's scaling constants .. + real(wp), parameter :: tsml = real(radix(0._wp), wp)**ceiling( & + (minexponent(0._wp) - 1) * 0.5_wp) + real(wp), parameter :: tbig = real(radix(0._wp), wp)**floor( & + (maxexponent(0._wp) - digits(0._wp) + 1) * 0.5_wp) + real(wp), parameter :: ssml = real(radix(0._wp), wp)**( - floor( & + (minexponent(0._wp) - digits(0._wp)) * 0.5_wp)) + real(wp), parameter :: sbig = real(radix(0._wp), wp)**( - ceiling( & + (maxexponent(0._wp) + digits(0._wp) - 1) * 0.5_wp)) +! .. +! .. Scalar Arguments .. + integer :: incx, n +! .. +! .. Array Arguments .. + complex(wp) :: x(*) +! .. +! .. Local Scalars .. + integer :: i, ix + logical :: notbig + real(wp) :: abig, amed, asml, ax, scl, sumsq, ymax, ymin +! +! Quick return if possible +! + DZNRM2 = zero + if( n <= 0 ) return +! + scl = one + sumsq = zero +! +! Compute the sum of squares in 3 accumulators: +! abig -- sums of squares scaled down to avoid overflow +! asml -- sums of squares scaled up to avoid underflow +! amed -- sums of squares that do not require scaling +! The thresholds and multipliers are +! tbig -- values bigger than this are scaled down by sbig +! tsml -- values smaller than this are scaled up by ssml +! + notbig = .true. + asml = zero + amed = zero + abig = zero + ix = 1 + if( incx < 0 ) ix = 1 - (n-1)*incx + do i = 1, n + ax = abs(real(x(ix))) + if (ax > tbig) then + abig = abig + (ax*sbig)**2 + notbig = .false. + else if (ax < tsml) then + if (notbig) asml = asml + (ax*ssml)**2 + else + amed = amed + ax**2 + end if + ax = abs(aimag(x(ix))) + if (ax > tbig) then + abig = abig + (ax*sbig)**2 + notbig = .false. + else if (ax < tsml) then + if (notbig) asml = asml + (ax*ssml)**2 + else + amed = amed + ax**2 + end if + ix = ix + incx + end do +! +! Combine abig and amed or amed and asml if more than one +! accumulator was used. +! + if (abig > zero) then +! +! Combine abig and amed if abig > 0. +! + if ( (amed > zero) .or. (amed > maxN) .or. (amed /= amed) ) then + abig = abig + (amed*sbig)*sbig + end if + scl = one / sbig + sumsq = abig + else if (asml > zero) then +! +! Combine amed and asml if asml > 0. +! + if ( (amed > zero) .or. (amed > maxN) .or. (amed /= amed) ) then + amed = sqrt(amed) + asml = sqrt(asml) / ssml + if (asml > amed) then + ymin = amed + ymax = asml + else + ymin = asml + ymax = amed + end if + scl = one + sumsq = ymax**2*( one + (ymin/ymax)**2 ) + else + scl = one / ssml + sumsq = asml + end if + else +! +! Otherwise all values are mid-range +! + scl = one + sumsq = amed + end if + DZNRM2 = scl*sqrt( sumsq ) + return +end function diff --git a/fortran_implementation/external_libraries/lapack_routines/lapack_routine/idamax.f b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/idamax.f new file mode 100644 index 0000000..06d7d7e --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/idamax.f @@ -0,0 +1,126 @@ +*> \brief \b IDAMAX +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* INTEGER FUNCTION IDAMAX(N,DX,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION DX(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> IDAMAX finds the index of the first element having maximum absolute value. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] DX +*> \verbatim +*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of DX +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup iamax +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, linpack, 3/11/78. +*> modified 3/93 to return if incx .le. 0. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + INTEGER FUNCTION IDAMAX(N,DX,INCX) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DX(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + DOUBLE PRECISION DMAX + INTEGER I,IX +* .. +* .. Intrinsic Functions .. + INTRINSIC DABS +* .. + IDAMAX = 0 + IF (N.LT.1 .OR. INCX.LE.0) RETURN + IDAMAX = 1 + IF (N.EQ.1) RETURN + IF (INCX.EQ.1) THEN +* +* code for increment equal to 1 +* + DMAX = DABS(DX(1)) + DO I = 2,N + IF (DABS(DX(I)).GT.DMAX) THEN + IDAMAX = I + DMAX = DABS(DX(I)) + END IF + END DO + ELSE +* +* code for increment not equal to 1 +* + IX = 1 + DMAX = DABS(DX(1)) + IX = IX + INCX + DO I = 2,N + IF (DABS(DX(IX)).GT.DMAX) THEN + IDAMAX = I + DMAX = DABS(DX(IX)) + END IF + IX = IX + INCX + END DO + END IF + RETURN +* +* End of IDAMAX +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/lapack_routine/ieeeck.f b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/ieeeck.f new file mode 100644 index 0000000..9b9e8fa --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/ieeeck.f @@ -0,0 +1,200 @@ +*> \brief \b IEEECK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download IEEECK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) +* +* .. Scalar Arguments .. +* INTEGER ISPEC +* REAL ONE, ZERO +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> IEEECK is called from the ILAENV to verify that Infinity and +*> possibly NaN arithmetic is safe (i.e. will not trap). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ISPEC +*> \verbatim +*> ISPEC is INTEGER +*> Specifies whether to test just for infinity arithmetic +*> or whether to test for infinity and NaN arithmetic. +*> = 0: Verify infinity arithmetic only. +*> = 1: Verify infinity and NaN arithmetic. +*> \endverbatim +*> +*> \param[in] ZERO +*> \verbatim +*> ZERO is REAL +*> Must contain the value 0.0 +*> This is passed to prevent the compiler from optimizing +*> away this code. +*> \endverbatim +*> +*> \param[in] ONE +*> \verbatim +*> ONE is REAL +*> Must contain the value 1.0 +*> This is passed to prevent the compiler from optimizing +*> away this code. +*> +*> RETURN VALUE: INTEGER +*> = 0: Arithmetic failed to produce the correct answers +*> = 1: Arithmetic produced the correct answers +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup ieeeck +* +* ===================================================================== + INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER ISPEC + REAL ONE, ZERO +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + REAL NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF, + $ NEGZRO, NEWZRO, POSINF +* .. +* .. Executable Statements .. + IEEECK = 1 +* + POSINF = ONE / ZERO + IF( POSINF.LE.ONE ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGINF = -ONE / ZERO + IF( NEGINF.GE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGZRO = ONE / ( NEGINF+ONE ) + IF( NEGZRO.NE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGINF = ONE / NEGZRO + IF( NEGINF.GE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + NEWZRO = NEGZRO + ZERO + IF( NEWZRO.NE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + POSINF = ONE / NEWZRO + IF( POSINF.LE.ONE ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGINF = NEGINF*POSINF + IF( NEGINF.GE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + POSINF = POSINF*POSINF + IF( POSINF.LE.ONE ) THEN + IEEECK = 0 + RETURN + END IF +* +* +* +* +* Return if we were only asked to check infinity arithmetic +* + IF( ISPEC.EQ.0 ) + $ RETURN +* + NAN1 = POSINF + NEGINF +* + NAN2 = POSINF / NEGINF +* + NAN3 = POSINF / POSINF +* + NAN4 = POSINF*ZERO +* + NAN5 = NEGINF*NEGZRO +* + NAN6 = NAN5*ZERO +* + IF( NAN1.EQ.NAN1 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN2.EQ.NAN2 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN3.EQ.NAN3 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN4.EQ.NAN4 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN5.EQ.NAN5 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN6.EQ.NAN6 ) THEN + IEEECK = 0 + RETURN + END IF +* + RETURN + END diff --git a/fortran_implementation/external_libraries/lapack_routines/lapack_routine/ilaenv.f b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/ilaenv.f new file mode 100644 index 0000000..e74a2b3 --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/ilaenv.f @@ -0,0 +1,749 @@ +*> \brief \b ILAENV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ILAENV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) +* +* .. Scalar Arguments .. +* CHARACTER*( * ) NAME, OPTS +* INTEGER ISPEC, N1, N2, N3, N4 +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ILAENV is called from the LAPACK routines to choose problem-dependent +*> parameters for the local environment. See ISPEC for a description of +*> the parameters. +*> +*> ILAENV returns an INTEGER +*> if ILAENV >= 0: ILAENV returns the value of the parameter specified by ISPEC +*> if ILAENV < 0: if ILAENV = -k, the k-th argument had an illegal value. +*> +*> This version provides a set of parameters which should give good, +*> but not optimal, performance on many of the currently available +*> computers. Users are encouraged to modify this subroutine to set +*> the tuning parameters for their particular machine using the option +*> and problem size information in the arguments. +*> +*> This routine will not function correctly if it is converted to all +*> lower case. Converting it to all upper case is allowed. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ISPEC +*> \verbatim +*> ISPEC is INTEGER +*> Specifies the parameter to be returned as the value of +*> ILAENV. +*> = 1: the optimal blocksize; if this value is 1, an unblocked +*> algorithm will give the best performance. +*> = 2: the minimum block size for which the block routine +*> should be used; if the usable block size is less than +*> this value, an unblocked routine should be used. +*> = 3: the crossover point (in a block routine, for N less +*> than this value, an unblocked routine should be used) +*> = 4: the number of shifts, used in the nonsymmetric +*> eigenvalue routines (DEPRECATED) +*> = 5: the minimum column dimension for blocking to be used; +*> rectangular blocks must have dimension at least k by m, +*> where k is given by ILAENV(2,...) and m by ILAENV(5,...) +*> = 6: the crossover point for the SVD (when reducing an m by n +*> matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds +*> this value, a QR factorization is used first to reduce +*> the matrix to a triangular form.) +*> = 7: the number of processors +*> = 8: the crossover point for the multishift QR method +*> for nonsymmetric eigenvalue problems (DEPRECATED) +*> = 9: maximum size of the subproblems at the bottom of the +*> computation tree in the divide-and-conquer algorithm +*> (used by xGELSD and xGESDD) +*> =10: ieee infinity and NaN arithmetic can be trusted not to trap +*> =11: infinity arithmetic can be trusted not to trap +*> 12 <= ISPEC <= 17: +*> xHSEQR or related subroutines, +*> see IPARMQ for detailed explanation +*> \endverbatim +*> +*> \param[in] NAME +*> \verbatim +*> NAME is CHARACTER*(*) +*> The name of the calling subroutine, in either upper case or +*> lower case. +*> \endverbatim +*> +*> \param[in] OPTS +*> \verbatim +*> OPTS is CHARACTER*(*) +*> The character options to the subroutine NAME, concatenated +*> into a single character string. For example, UPLO = 'U', +*> TRANS = 'T', and DIAG = 'N' for a triangular routine would +*> be specified as OPTS = 'UTN'. +*> \endverbatim +*> +*> \param[in] N1 +*> \verbatim +*> N1 is INTEGER +*> \endverbatim +*> +*> \param[in] N2 +*> \verbatim +*> N2 is INTEGER +*> \endverbatim +*> +*> \param[in] N3 +*> \verbatim +*> N3 is INTEGER +*> \endverbatim +*> +*> \param[in] N4 +*> \verbatim +*> N4 is INTEGER +*> Problem dimensions for the subroutine NAME; these may not all +*> be required. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup ilaenv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The following conventions have been used when calling ILAENV from the +*> LAPACK routines: +*> 1) OPTS is a concatenation of all of the character options to +*> subroutine NAME, in the same order that they appear in the +*> argument list for NAME, even if they are not used in determining +*> the value of the parameter specified by ISPEC. +*> 2) The problem dimensions N1, N2, N3, N4 are specified in the order +*> that they appear in the argument list for NAME. N1 is used +*> first, N2 second, and so on, and unused problem dimensions are +*> passed a value of -1. +*> 3) The parameter value returned by ILAENV is checked for validity in +*> the calling subroutine. For example, ILAENV is used to retrieve +*> the optimal blocksize for STRTRI as follows: +*> +*> NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) +*> IF( NB.LE.1 ) NB = MAX( 1, N ) +*> \endverbatim +*> +* ===================================================================== + INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER*( * ) NAME, OPTS + INTEGER ISPEC, N1, N2, N3, N4 +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, IC, IZ, NB, NBMIN, NX + LOGICAL CNAME, SNAME, TWOSTAGE + CHARACTER C1*1, C2*2, C4*2, C3*3, SUBNAM*16 +* .. +* .. Intrinsic Functions .. + INTRINSIC CHAR, ICHAR, INT, MIN, REAL +* .. +* .. External Functions .. + INTEGER IEEECK, IPARMQ, IPARAM2STAGE + EXTERNAL IEEECK, IPARMQ, IPARAM2STAGE +* .. +* .. Executable Statements .. +* + GO TO ( 10, 10, 10, 80, 90, 100, 110, 120, + $ 130, 140, 150, 160, 160, 160, 160, 160, 160)ISPEC +* +* Invalid value for ISPEC +* + ILAENV = -1 + RETURN +* + 10 CONTINUE +* +* Convert NAME to upper case if the first character is lower case. +* + ILAENV = 1 + SUBNAM = NAME + IC = ICHAR( SUBNAM( 1: 1 ) ) + IZ = ICHAR( 'Z' ) + IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN +* +* ASCII character set +* + IF( IC.GE.97 .AND. IC.LE.122 ) THEN + SUBNAM( 1: 1 ) = CHAR( IC-32 ) + DO 20 I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( IC.GE.97 .AND. IC.LE.122 ) + $ SUBNAM( I: I ) = CHAR( IC-32 ) + 20 CONTINUE + END IF +* + ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN +* +* EBCDIC character set +* + IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN + SUBNAM( 1: 1 ) = CHAR( IC+64 ) + DO 30 I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) )SUBNAM( I: + $ I ) = CHAR( IC+64 ) + 30 CONTINUE + END IF +* + ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN +* +* Prime machines: ASCII+128 +* + IF( IC.GE.225 .AND. IC.LE.250 ) THEN + SUBNAM( 1: 1 ) = CHAR( IC-32 ) + DO 40 I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( IC.GE.225 .AND. IC.LE.250 ) + $ SUBNAM( I: I ) = CHAR( IC-32 ) + 40 CONTINUE + END IF + END IF +* + C1 = SUBNAM( 1: 1 ) + SNAME = C1.EQ.'S' .OR. C1.EQ.'D' + CNAME = C1.EQ.'C' .OR. C1.EQ.'Z' + IF( .NOT.( CNAME .OR. SNAME ) ) + $ RETURN + C2 = SUBNAM( 2: 3 ) + C3 = SUBNAM( 4: 6 ) + C4 = C3( 2: 3 ) + TWOSTAGE = LEN( SUBNAM ).GE.11 + $ .AND. SUBNAM( 11: 11 ).EQ.'2' +* + GO TO ( 50, 60, 70 )ISPEC +* + 50 CONTINUE +* +* ISPEC = 1: block size +* +* In these examples, separate code is provided for setting NB for +* real and complex. We assume that NB will take the same value in +* single or double precision. +* + NB = 1 +* + IF( SUBNAM(2:6).EQ.'LAORH' ) THEN +* +* This is for *LAORHR_GETRFNP routine +* + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + ELSE IF( C2.EQ.'GE' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. + $ C3.EQ.'QLF' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + ELSE IF( C3.EQ.'QR ') THEN + IF( N3 .EQ. 1) THEN + IF( SNAME ) THEN +* M*N + IF ((N1*N2.LE.131072).OR.(N1.LE.8192)) THEN + NB = N1 + ELSE + NB = 32768/N2 + END IF + ELSE + IF ((N1*N2.LE.131072).OR.(N1.LE.8192)) THEN + NB = N1 + ELSE + NB = 32768/N2 + END IF + END IF + ELSE + IF( SNAME ) THEN + NB = 1 + ELSE + NB = 1 + END IF + END IF + ELSE IF( C3.EQ.'LQ ') THEN + IF( N3 .EQ. 2) THEN + IF( SNAME ) THEN +* M*N + IF ((N1*N2.LE.131072).OR.(N1.LE.8192)) THEN + NB = N1 + ELSE + NB = 32768/N2 + END IF + ELSE + IF ((N1*N2.LE.131072).OR.(N1.LE.8192)) THEN + NB = N1 + ELSE + NB = 32768/N2 + END IF + END IF + ELSE + IF( SNAME ) THEN + NB = 1 + ELSE + NB = 1 + END IF + END IF + ELSE IF( C3.EQ.'HRD' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + ELSE IF( C3.EQ.'BRD' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + ELSE IF( C3.EQ.'TRI' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + ELSE IF( SUBNAM( 4: 7 ).EQ.'QP3RK' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + END IF + ELSE IF( C2.EQ.'PO' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( C2.EQ.'SY' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + IF( TWOSTAGE ) THEN + NB = 192 + ELSE + NB = 64 + END IF + ELSE + IF( TWOSTAGE ) THEN + NB = 192 + ELSE + NB = 64 + END IF + END IF + ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN + NB = 32 + ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN + NB = 64 + END IF + ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( TWOSTAGE ) THEN + NB = 192 + ELSE + NB = 64 + END IF + ELSE IF( C3.EQ.'TRD' ) THEN + NB = 32 + ELSE IF( C3.EQ.'GST' ) THEN + NB = 64 + END IF + ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NB = 32 + END IF + ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NB = 32 + END IF + END IF + ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NB = 32 + END IF + ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NB = 32 + END IF + END IF + ELSE IF( C2.EQ.'GB' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + IF( N4.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + ELSE + IF( N4.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + END IF + END IF + ELSE IF( C2.EQ.'PB' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + IF( N2.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + ELSE + IF( N2.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + END IF + END IF + ELSE IF( C2.EQ.'TR' ) THEN + IF( C3.EQ.'TRI' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + ELSE IF ( C3.EQ.'EVC' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + ELSE IF( C3.EQ.'SYL' ) THEN +* The upper bound is to prevent overly aggressive scaling. + IF( SNAME ) THEN + NB = MIN( MAX( 48, INT( ( MIN( N1, N2 ) * 16 ) / 100) ), + $ 240 ) + ELSE + NB = MIN( MAX( 24, INT( ( MIN( N1, N2 ) * 8 ) / 100) ), + $ 80 ) + END IF + END IF + ELSE IF( C2.EQ.'LA' ) THEN + IF( C3.EQ.'UUM' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + ELSE IF( C3.EQ.'TRS' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + END IF + ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN + IF( C3.EQ.'EBZ' ) THEN + NB = 1 + END IF + ELSE IF( C2.EQ.'GG' ) THEN + NB = 32 + IF( C3.EQ.'HD3' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + END IF + END IF + ILAENV = NB + RETURN +* + 60 CONTINUE +* +* ISPEC = 2: minimum block size +* + NBMIN = 2 + IF( C2.EQ.'GE' ) THEN + IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ. + $ 'QLF' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + ELSE IF( C3.EQ.'HRD' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + ELSE IF( C3.EQ.'BRD' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + ELSE IF( C3.EQ.'TRI' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + ELSE IF( SUBNAM( 4: 7 ).EQ.'QP3RK' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + END IF + + ELSE IF( C2.EQ.'SY' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NBMIN = 8 + ELSE + NBMIN = 8 + END IF + ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN + NBMIN = 2 + END IF + ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN + IF( C3.EQ.'TRD' ) THEN + NBMIN = 2 + END IF + ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NBMIN = 2 + END IF + ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NBMIN = 2 + END IF + END IF + ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NBMIN = 2 + END IF + ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NBMIN = 2 + END IF + END IF + ELSE IF( C2.EQ.'GG' ) THEN + NBMIN = 2 + IF( C3.EQ.'HD3' ) THEN + NBMIN = 2 + END IF + END IF + ILAENV = NBMIN + RETURN +* + 70 CONTINUE +* +* ISPEC = 3: crossover point +* + NX = 0 + IF( C2.EQ.'GE' ) THEN + IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ. + $ 'QLF' ) THEN + IF( SNAME ) THEN + NX = 128 + ELSE + NX = 128 + END IF + ELSE IF( C3.EQ.'HRD' ) THEN + IF( SNAME ) THEN + NX = 128 + ELSE + NX = 128 + END IF + ELSE IF( C3.EQ.'BRD' ) THEN + IF( SNAME ) THEN + NX = 128 + ELSE + NX = 128 + END IF + ELSE IF( SUBNAM( 4: 7 ).EQ.'QP3RK' ) THEN + IF( SNAME ) THEN + NX = 128 + ELSE + NX = 128 + END IF + END IF + ELSE IF( C2.EQ.'SY' ) THEN + IF( SNAME .AND. C3.EQ.'TRD' ) THEN + NX = 32 + END IF + ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN + IF( C3.EQ.'TRD' ) THEN + NX = 32 + END IF + ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NX = 128 + END IF + END IF + ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NX = 128 + END IF + END IF + ELSE IF( C2.EQ.'GG' ) THEN + NX = 128 + IF( C3.EQ.'HD3' ) THEN + NX = 128 + END IF + END IF + ILAENV = NX + RETURN +* + 80 CONTINUE +* +* ISPEC = 4: number of shifts (used by xHSEQR) +* + ILAENV = 6 + RETURN +* + 90 CONTINUE +* +* ISPEC = 5: minimum column dimension (not used) +* + ILAENV = 2 + RETURN +* + 100 CONTINUE +* +* ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) +* + ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 ) + RETURN +* + 110 CONTINUE +* +* ISPEC = 7: number of processors (not used) +* + ILAENV = 1 + RETURN +* + 120 CONTINUE +* +* ISPEC = 8: crossover point for multishift (used by xHSEQR) +* + ILAENV = 50 + RETURN +* + 130 CONTINUE +* +* ISPEC = 9: maximum size of the subproblems at the bottom of the +* computation tree in the divide-and-conquer algorithm +* (used by xGELSD and xGESDD) +* + ILAENV = 25 + RETURN +* + 140 CONTINUE +* +* ISPEC = 10: ieee and infinity NaN arithmetic can be trusted not to trap +* +* ILAENV = 0 + ILAENV = 1 + IF( ILAENV.EQ.1 ) THEN + ILAENV = IEEECK( 1, 0.0, 1.0 ) + END IF + RETURN +* + 150 CONTINUE +* +* ISPEC = 11: ieee infinity arithmetic can be trusted not to trap +* +* ILAENV = 0 + ILAENV = 1 + IF( ILAENV.EQ.1 ) THEN + ILAENV = IEEECK( 0, 0.0, 1.0 ) + END IF + RETURN +* + 160 CONTINUE +* +* 12 <= ISPEC <= 17: xHSEQR or related subroutines. +* + ILAENV = IPARMQ( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) + RETURN +* +* End of ILAENV +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/lapack_routine/ilazlc.f b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/ilazlc.f new file mode 100644 index 0000000..359f0ae --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/ilazlc.f @@ -0,0 +1,115 @@ +*> \brief \b ILAZLC scans a matrix for its last non-zero column. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ILAZLC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* INTEGER FUNCTION ILAZLC( M, N, A, LDA ) +* +* .. Scalar Arguments .. +* INTEGER M, N, LDA +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ILAZLC scans A for its last non-zero column. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> The m by n matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup ilalc +* +* ===================================================================== + INTEGER FUNCTION ILAZLC( M, N, A, LDA ) +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER M, N, LDA +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO + PARAMETER ( ZERO = (0.0D+0, 0.0D+0) ) +* .. +* .. Local Scalars .. + INTEGER I +* .. +* .. Executable Statements .. +* +* Quick test for the common case where one corner is non-zero. + IF( N.EQ.0 ) THEN + ILAZLC = N + ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN + ILAZLC = N + ELSE +* Now scan each column from the end, returning with the first non-zero. + DO ILAZLC = N, 1, -1 + DO I = 1, M + IF( A(I, ILAZLC).NE.ZERO ) RETURN + END DO + END DO + END IF + RETURN + END diff --git a/fortran_implementation/external_libraries/lapack_routines/lapack_routine/ilazlr.f b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/ilazlr.f new file mode 100644 index 0000000..f4359bd --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/ilazlr.f @@ -0,0 +1,118 @@ +*> \brief \b ILAZLR scans a matrix for its last non-zero row. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ILAZLR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* INTEGER FUNCTION ILAZLR( M, N, A, LDA ) +* +* .. Scalar Arguments .. +* INTEGER M, N, LDA +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ILAZLR scans A for its last non-zero row. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> The m by n matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup ilalr +* +* ===================================================================== + INTEGER FUNCTION ILAZLR( M, N, A, LDA ) +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER M, N, LDA +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO + PARAMETER ( ZERO = (0.0D+0, 0.0D+0) ) +* .. +* .. Local Scalars .. + INTEGER I, J +* .. +* .. Executable Statements .. +* +* Quick test for the common case where one corner is non-zero. + IF( M.EQ.0 ) THEN + ILAZLR = M + ELSE IF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN + ILAZLR = M + ELSE +* Scan up each column tracking the last zero row seen. + ILAZLR = 0 + DO J = 1, N + I=M + DO WHILE((A(MAX(I,1),J).EQ.ZERO).AND.(I.GE.1)) + I=I-1 + ENDDO + ILAZLR = MAX( ILAZLR, I ) + END DO + END IF + RETURN + END diff --git a/fortran_implementation/external_libraries/lapack_routines/lapack_routine/iparmq.f b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/iparmq.f new file mode 100644 index 0000000..4bd2c33 --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/iparmq.f @@ -0,0 +1,407 @@ +*> \brief \b IPARMQ +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download IPARMQ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK ) +* +* .. Scalar Arguments .. +* INTEGER IHI, ILO, ISPEC, LWORK, N +* CHARACTER NAME*( * ), OPTS*( * ) +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> This program sets problem and machine dependent parameters +*> useful for xHSEQR and related subroutines for eigenvalue +*> problems. It is called whenever +*> IPARMQ is called with 12 <= ISPEC <= 16 +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ISPEC +*> \verbatim +*> ISPEC is INTEGER +*> ISPEC specifies which tunable parameter IPARMQ should +*> return. +*> +*> ISPEC=12: (INMIN) Matrices of order nmin or less +*> are sent directly to xLAHQR, the implicit +*> double shift QR algorithm. NMIN must be +*> at least 11. +*> +*> ISPEC=13: (INWIN) Size of the deflation window. +*> This is best set greater than or equal to +*> the number of simultaneous shifts NS. +*> Larger matrices benefit from larger deflation +*> windows. +*> +*> ISPEC=14: (INIBL) Determines when to stop nibbling and +*> invest in an (expensive) multi-shift QR sweep. +*> If the aggressive early deflation subroutine +*> finds LD converged eigenvalues from an order +*> NW deflation window and LD > (NW*NIBBLE)/100, +*> then the next QR sweep is skipped and early +*> deflation is applied immediately to the +*> remaining active diagonal block. Setting +*> IPARMQ(ISPEC=14) = 0 causes TTQRE to skip a +*> multi-shift QR sweep whenever early deflation +*> finds a converged eigenvalue. Setting +*> IPARMQ(ISPEC=14) greater than or equal to 100 +*> prevents TTQRE from skipping a multi-shift +*> QR sweep. +*> +*> ISPEC=15: (NSHFTS) The number of simultaneous shifts in +*> a multi-shift QR iteration. +*> +*> ISPEC=16: (IACC22) IPARMQ is set to 0, 1 or 2 with the +*> following meanings. +*> 0: During the multi-shift QR/QZ sweep, +*> blocked eigenvalue reordering, blocked +*> Hessenberg-triangular reduction, +*> reflections and/or rotations are not +*> accumulated when updating the +*> far-from-diagonal matrix entries. +*> 1: During the multi-shift QR/QZ sweep, +*> blocked eigenvalue reordering, blocked +*> Hessenberg-triangular reduction, +*> reflections and/or rotations are +*> accumulated, and matrix-matrix +*> multiplication is used to update the +*> far-from-diagonal matrix entries. +*> 2: During the multi-shift QR/QZ sweep, +*> blocked eigenvalue reordering, blocked +*> Hessenberg-triangular reduction, +*> reflections and/or rotations are +*> accumulated, and 2-by-2 block structure +*> is exploited during matrix-matrix +*> multiplies. +*> (If xTRMM is slower than xGEMM, then +*> IPARMQ(ISPEC=16)=1 may be more efficient than +*> IPARMQ(ISPEC=16)=2 despite the greater level of +*> arithmetic work implied by the latter choice.) +*> +*> ISPEC=17: (ICOST) An estimate of the relative cost of flops +*> within the near-the-diagonal shift chase compared +*> to flops within the BLAS calls of a QZ sweep. +*> \endverbatim +*> +*> \param[in] NAME +*> \verbatim +*> NAME is CHARACTER string +*> Name of the calling subroutine +*> \endverbatim +*> +*> \param[in] OPTS +*> \verbatim +*> OPTS is CHARACTER string +*> This is a concatenation of the string arguments to +*> TTQRE. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> N is the order of the Hessenberg matrix H. +*> \endverbatim +*> +*> \param[in] ILO +*> \verbatim +*> ILO is INTEGER +*> \endverbatim +*> +*> \param[in] IHI +*> \verbatim +*> IHI is INTEGER +*> It is assumed that H is already upper triangular +*> in rows and columns 1:ILO-1 and IHI+1:N. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The amount of workspace available. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup iparmq +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Little is known about how best to choose these parameters. +*> It is possible to use different values of the parameters +*> for each of CHSEQR, DHSEQR, SHSEQR and ZHSEQR. +*> +*> It is probably best to choose different parameters for +*> different matrices and different parameters at different +*> times during the iteration, but this has not been +*> implemented --- yet. +*> +*> +*> The best choices of most of the parameters depend +*> in an ill-understood way on the relative execution +*> rate of xLAQR3 and xLAQR5 and on the nature of each +*> particular eigenvalue problem. Experiment may be the +*> only practical way to determine which choices are most +*> effective. +*> +*> Following is a list of default values supplied by IPARMQ. +*> These defaults may be adjusted in order to attain better +*> performance in any particular computational environment. +*> +*> IPARMQ(ISPEC=12) The xLAHQR vs xLAQR0 crossover point. +*> Default: 75. (Must be at least 11.) +*> +*> IPARMQ(ISPEC=13) Recommended deflation window size. +*> This depends on ILO, IHI and NS, the +*> number of simultaneous shifts returned +*> by IPARMQ(ISPEC=15). The default for +*> (IHI-ILO+1) <= 500 is NS. The default +*> for (IHI-ILO+1) > 500 is 3*NS/2. +*> +*> IPARMQ(ISPEC=14) Nibble crossover point. Default: 14. +*> +*> IPARMQ(ISPEC=15) Number of simultaneous shifts, NS. +*> a multi-shift QR iteration. +*> +*> If IHI-ILO+1 is ... +*> +*> greater than ...but less ... the +*> or equal to ... than default is +*> +*> 0 30 NS = 2+ +*> 30 60 NS = 4+ +*> 60 150 NS = 10 +*> 150 590 NS = ** +*> 590 3000 NS = 64 +*> 3000 6000 NS = 128 +*> 6000 infinity NS = 256 +*> +*> (+) By default matrices of this order are +*> passed to the implicit double shift routine +*> xLAHQR. See IPARMQ(ISPEC=12) above. These +*> values of NS are used only in case of a rare +*> xLAHQR failure. +*> +*> (**) The asterisks (**) indicate an ad-hoc +*> function increasing from 10 to 64. +*> +*> IPARMQ(ISPEC=16) Select structured matrix multiply. +*> (See ISPEC=16 above for details.) +*> Default: 3. +*> +*> IPARMQ(ISPEC=17) Relative cost heuristic for blocksize selection. +*> Expressed as a percentage. +*> Default: 10. +*> \endverbatim +*> +* ===================================================================== + INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, + $ LWORK ) +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER IHI, ILO, ISPEC, LWORK, N + CHARACTER NAME*( * ), OPTS*( * ) +* +* ================================================================ +* .. Parameters .. + INTEGER INMIN, INWIN, INIBL, ISHFTS, IACC22, ICOST + PARAMETER ( INMIN = 12, INWIN = 13, INIBL = 14, + $ ISHFTS = 15, IACC22 = 16, ICOST = 17 ) + INTEGER NMIN, K22MIN, KACMIN, NIBBLE, KNWSWP, RCOST + PARAMETER ( NMIN = 75, K22MIN = 14, KACMIN = 14, + $ NIBBLE = 14, KNWSWP = 500, RCOST = 10 ) + REAL TWO + PARAMETER ( TWO = 2.0 ) +* .. +* .. Local Scalars .. + INTEGER NH, NS + INTEGER I, IC, IZ + CHARACTER SUBNAM*6 +* .. +* .. Intrinsic Functions .. + INTRINSIC LOG, MAX, MOD, NINT, REAL +* .. +* .. Executable Statements .. + IF( ( ISPEC.EQ.ISHFTS ) .OR. ( ISPEC.EQ.INWIN ) .OR. + $ ( ISPEC.EQ.IACC22 ) ) THEN +* +* ==== Set the number simultaneous shifts ==== +* + NH = IHI - ILO + 1 + NS = 2 + IF( NH.GE.30 ) + $ NS = 4 + IF( NH.GE.60 ) + $ NS = 10 + IF( NH.GE.150 ) + $ NS = MAX( 10, NH / NINT( LOG( REAL( NH ) ) / LOG( TWO ) ) ) + IF( NH.GE.590 ) + $ NS = 64 + IF( NH.GE.3000 ) + $ NS = 128 + IF( NH.GE.6000 ) + $ NS = 256 + NS = MAX( 2, NS-MOD( NS, 2 ) ) + END IF +* + IF( ISPEC.EQ.INMIN ) THEN +* +* +* ===== Matrices of order smaller than NMIN get sent +* . to xLAHQR, the classic double shift algorithm. +* . This must be at least 11. ==== +* + IPARMQ = NMIN +* + ELSE IF( ISPEC.EQ.INIBL ) THEN +* +* ==== INIBL: skip a multi-shift qr iteration and +* . whenever aggressive early deflation finds +* . at least (NIBBLE*(window size)/100) deflations. ==== +* + IPARMQ = NIBBLE +* + ELSE IF( ISPEC.EQ.ISHFTS ) THEN +* +* ==== NSHFTS: The number of simultaneous shifts ===== +* + IPARMQ = NS +* + ELSE IF( ISPEC.EQ.INWIN ) THEN +* +* ==== NW: deflation window size. ==== +* + IF( NH.LE.KNWSWP ) THEN + IPARMQ = NS + ELSE + IPARMQ = 3*NS / 2 + END IF +* + ELSE IF( ISPEC.EQ.IACC22 ) THEN +* +* ==== IACC22: Whether to accumulate reflections +* . before updating the far-from-diagonal elements +* . and whether to use 2-by-2 block structure while +* . doing it. A small amount of work could be saved +* . by making this choice dependent also upon the +* . NH=IHI-ILO+1. +* +* +* Convert NAME to upper case if the first character is lower case. +* + IPARMQ = 0 + SUBNAM = NAME + IC = ICHAR( SUBNAM( 1: 1 ) ) + IZ = ICHAR( 'Z' ) + IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN +* +* ASCII character set +* + IF( IC.GE.97 .AND. IC.LE.122 ) THEN + SUBNAM( 1: 1 ) = CHAR( IC-32 ) + DO I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( IC.GE.97 .AND. IC.LE.122 ) + $ SUBNAM( I: I ) = CHAR( IC-32 ) + END DO + END IF +* + ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN +* +* EBCDIC character set +* + IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN + SUBNAM( 1: 1 ) = CHAR( IC+64 ) + DO I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) )SUBNAM( I: + $ I ) = CHAR( IC+64 ) + END DO + END IF +* + ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN +* +* Prime machines: ASCII+128 +* + IF( IC.GE.225 .AND. IC.LE.250 ) THEN + SUBNAM( 1: 1 ) = CHAR( IC-32 ) + DO I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( IC.GE.225 .AND. IC.LE.250 ) + $ SUBNAM( I: I ) = CHAR( IC-32 ) + END DO + END IF + END IF +* + IF( SUBNAM( 2:6 ).EQ.'GGHRD' .OR. + $ SUBNAM( 2:6 ).EQ.'GGHD3' ) THEN + IPARMQ = 1 + IF( NH.GE.K22MIN ) + $ IPARMQ = 2 + ELSE IF ( SUBNAM( 4:6 ).EQ.'EXC' ) THEN + IF( NH.GE.KACMIN ) + $ IPARMQ = 1 + IF( NH.GE.K22MIN ) + $ IPARMQ = 2 + ELSE IF ( SUBNAM( 2:6 ).EQ.'HSEQR' .OR. + $ SUBNAM( 2:5 ).EQ.'LAQR' ) THEN + IF( NS.GE.KACMIN ) + $ IPARMQ = 1 + IF( NS.GE.K22MIN ) + $ IPARMQ = 2 + END IF +* + ELSE IF( ISPEC.EQ.ICOST ) THEN +* +* === Relative cost of near-the-diagonal chase vs +* BLAS updates === +* + IPARMQ = RCOST + ELSE +* ===== invalid value of ispec ===== + IPARMQ = -1 +* + END IF +* +* ==== End of IPARMQ ==== +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/lapack_routine/izamax.f b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/izamax.f new file mode 100644 index 0000000..0fe4125 --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/izamax.f @@ -0,0 +1,127 @@ +*> \brief \b IZAMAX +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* INTEGER FUNCTION IZAMAX(N,ZX,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,N +* .. +* .. Array Arguments .. +* COMPLEX*16 ZX(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> IZAMAX finds the index of the first element having maximum |Re(.)| + |Im(.)| +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] ZX +*> \verbatim +*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of ZX +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup iamax +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, 1/15/85. +*> modified 3/93 to return if incx .le. 0. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + INTEGER FUNCTION IZAMAX(N,ZX,INCX) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,N +* .. +* .. Array Arguments .. + COMPLEX*16 ZX(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + DOUBLE PRECISION DMAX + INTEGER I,IX +* .. +* .. External Functions .. + DOUBLE PRECISION DCABS1 + EXTERNAL DCABS1 +* .. + IZAMAX = 0 + IF (N.LT.1 .OR. INCX.LE.0) RETURN + IZAMAX = 1 + IF (N.EQ.1) RETURN + IF (INCX.EQ.1) THEN +* +* code for increment equal to 1 +* + DMAX = DCABS1(ZX(1)) + DO I = 2,N + IF (DCABS1(ZX(I)).GT.DMAX) THEN + IZAMAX = I + DMAX = DCABS1(ZX(I)) + END IF + END DO + ELSE +* +* code for increment not equal to 1 +* + IX = 1 + DMAX = DCABS1(ZX(1)) + IX = IX + INCX + DO I = 2,N + IF (DCABS1(ZX(IX)).GT.DMAX) THEN + IZAMAX = I + DMAX = DCABS1(ZX(IX)) + END IF + IX = IX + INCX + END DO + END IF + RETURN +* +* End of IZAMAX +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/lapack_routine/lsame.f b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/lsame.f new file mode 100644 index 0000000..eef9ee5 --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/lsame.f @@ -0,0 +1,122 @@ +*> \brief \b LSAME +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* LOGICAL FUNCTION LSAME(CA,CB) +* +* .. Scalar Arguments .. +* CHARACTER CA,CB +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> LSAME returns .TRUE. if CA is the same letter as CB regardless of +*> case. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] CA +*> \verbatim +*> CA is CHARACTER*1 +*> \endverbatim +*> +*> \param[in] CB +*> \verbatim +*> CB is CHARACTER*1 +*> CA and CB specify the single characters to be compared. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup lsame +* +* ===================================================================== + LOGICAL FUNCTION LSAME(CA,CB) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER CA,CB +* .. +* +* ===================================================================== +* +* .. Intrinsic Functions .. + INTRINSIC ICHAR +* .. +* .. Local Scalars .. + INTEGER INTA,INTB,ZCODE +* .. +* +* Test if the characters are equal +* + LSAME = CA .EQ. CB + IF (LSAME) RETURN +* +* Now test for equivalence if both characters are alphabetic. +* + ZCODE = ICHAR('Z') +* +* Use 'Z' rather than 'A' so that ASCII can be detected on Prime +* machines, on which ICHAR returns a value with bit 8 set. +* ICHAR('A') on Prime machines returns 193 which is the same as +* ICHAR('A') on an EBCDIC machine. +* + INTA = ICHAR(CA) + INTB = ICHAR(CB) +* + IF (ZCODE.EQ.90 .OR. ZCODE.EQ.122) THEN +* +* ASCII is assumed - ZCODE is the ASCII code of either lower or +* upper case 'Z'. +* + IF (INTA.GE.97 .AND. INTA.LE.122) INTA = INTA - 32 + IF (INTB.GE.97 .AND. INTB.LE.122) INTB = INTB - 32 +* + ELSE IF (ZCODE.EQ.233 .OR. ZCODE.EQ.169) THEN +* +* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or +* upper case 'Z'. +* + IF (INTA.GE.129 .AND. INTA.LE.137 .OR. + + INTA.GE.145 .AND. INTA.LE.153 .OR. + + INTA.GE.162 .AND. INTA.LE.169) INTA = INTA + 64 + IF (INTB.GE.129 .AND. INTB.LE.137 .OR. + + INTB.GE.145 .AND. INTB.LE.153 .OR. + + INTB.GE.162 .AND. INTB.LE.169) INTB = INTB + 64 +* + ELSE IF (ZCODE.EQ.218 .OR. ZCODE.EQ.250) THEN +* +* ASCII is assumed, on Prime machines - ZCODE is the ASCII code +* plus 128 of either lower or upper case 'Z'. +* + IF (INTA.GE.225 .AND. INTA.LE.250) INTA = INTA - 32 + IF (INTB.GE.225 .AND. INTB.LE.250) INTB = INTB - 32 + END IF + LSAME = INTA .EQ. INTB +* +* RETURN +* +* End of LSAME +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/lapack_routine/zaxpy.f b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/zaxpy.f new file mode 100644 index 0000000..d39ccfc --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/zaxpy.f @@ -0,0 +1,139 @@ +*> \brief \b ZAXPY +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZAXPY(N,ZA,ZX,INCX,ZY,INCY) +* +* .. Scalar Arguments .. +* COMPLEX*16 ZA +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* COMPLEX*16 ZX(*),ZY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZAXPY constant times a vector plus a vector. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] ZA +*> \verbatim +*> ZA is COMPLEX*16 +*> On entry, ZA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] ZX +*> \verbatim +*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of ZX +*> \endverbatim +*> +*> \param[in,out] ZY +*> \verbatim +*> ZY is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of ZY +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup axpy +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, 3/11/78. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZAXPY(N,ZA,ZX,INCX,ZY,INCY) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX*16 ZA + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + COMPLEX*16 ZX(*),ZY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,IX,IY +* .. +* .. External Functions .. + DOUBLE PRECISION DCABS1 + EXTERNAL DCABS1 +* .. + IF (N.LE.0) RETURN + IF (DCABS1(ZA).EQ.0.0d0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* + DO I = 1,N + ZY(I) = ZY(I) + ZA*ZX(I) + END DO + ELSE +* +* code for unequal increments or equal increments +* not equal to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + ZY(IY) = ZY(IY) + ZA*ZX(IX) + IX = IX + INCX + IY = IY + INCY + END DO + END IF +* + RETURN +* +* End of ZAXPY +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/lapack_routine/zcopy.f b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/zcopy.f new file mode 100644 index 0000000..c1ea412 --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/zcopy.f @@ -0,0 +1,125 @@ +*> \brief \b ZCOPY +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZCOPY(N,ZX,INCX,ZY,INCY) +* +* .. Scalar Arguments .. +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* COMPLEX*16 ZX(*),ZY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZCOPY copies a vector, x, to a vector, y. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] ZX +*> \verbatim +*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of ZX +*> \endverbatim +*> +*> \param[out] ZY +*> \verbatim +*> ZY is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of ZY +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup copy +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, linpack, 4/11/78. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZCOPY(N,ZX,INCX,ZY,INCY) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + COMPLEX*16 ZX(*),ZY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,IX,IY +* .. + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* + DO I = 1,N + ZY(I) = ZX(I) + END DO + ELSE +* +* code for unequal increments or equal increments +* not equal to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + ZY(IY) = ZX(IX) + IX = IX + INCX + IY = IY + INCY + END DO + END IF + RETURN +* +* End of ZCOPY +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/lapack_routine/zdotc.f b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/zdotc.f new file mode 100644 index 0000000..96b957e --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/zdotc.f @@ -0,0 +1,134 @@ +*> \brief \b ZDOTC +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* COMPLEX*16 FUNCTION ZDOTC(N,ZX,INCX,ZY,INCY) +* +* .. Scalar Arguments .. +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* COMPLEX*16 ZX(*),ZY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZDOTC forms the dot product of two complex vectors +*> ZDOTC = X^H * Y +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] ZX +*> \verbatim +*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of ZX +*> \endverbatim +*> +*> \param[in] ZY +*> \verbatim +*> ZY is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of ZY +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup dot +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, 3/11/78. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + COMPLEX*16 FUNCTION ZDOTC(N,ZX,INCX,ZY,INCY) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + COMPLEX*16 ZX(*),ZY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + COMPLEX*16 ZTEMP + INTEGER I,IX,IY +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG +* .. + ZTEMP = (0.0d0,0.0d0) + ZDOTC = (0.0d0,0.0d0) + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* + DO I = 1,N + ZTEMP = ZTEMP + DCONJG(ZX(I))*ZY(I) + END DO + ELSE +* +* code for unequal increments or equal increments +* not equal to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + ZTEMP = ZTEMP + DCONJG(ZX(IX))*ZY(IY) + IX = IX + INCX + IY = IY + INCY + END DO + END IF + ZDOTC = ZTEMP + RETURN +* +* End of ZDOTC +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/lapack_routine/zdotu.f b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/zdotu.f new file mode 100644 index 0000000..82eed8b --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/zdotu.f @@ -0,0 +1,131 @@ +*> \brief \b ZDOTU +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* COMPLEX*16 FUNCTION ZDOTU(N,ZX,INCX,ZY,INCY) +* +* .. Scalar Arguments .. +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* COMPLEX*16 ZX(*),ZY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZDOTU forms the dot product of two complex vectors +*> ZDOTU = X^T * Y +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] ZX +*> \verbatim +*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of ZX +*> \endverbatim +*> +*> \param[in] ZY +*> \verbatim +*> ZY is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of ZY +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup dot +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, 3/11/78. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + COMPLEX*16 FUNCTION ZDOTU(N,ZX,INCX,ZY,INCY) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + COMPLEX*16 ZX(*),ZY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + COMPLEX*16 ZTEMP + INTEGER I,IX,IY +* .. + ZTEMP = (0.0d0,0.0d0) + ZDOTU = (0.0d0,0.0d0) + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* + DO I = 1,N + ZTEMP = ZTEMP + ZX(I)*ZY(I) + END DO + ELSE +* +* code for unequal increments or equal increments +* not equal to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + ZTEMP = ZTEMP + ZX(IX)*ZY(IY) + IX = IX + INCX + IY = IY + INCY + END DO + END IF + ZDOTU = ZTEMP + RETURN +* +* End of ZDOTU +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/lapack_routine/zdscal.f b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/zdscal.f new file mode 100644 index 0000000..28fa829 --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/zdscal.f @@ -0,0 +1,123 @@ +*> \brief \b ZDSCAL +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZDSCAL(N,DA,ZX,INCX) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION DA +* INTEGER INCX,N +* .. +* .. Array Arguments .. +* COMPLEX*16 ZX(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZDSCAL scales a vector by a constant. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] DA +*> \verbatim +*> DA is DOUBLE PRECISION +*> On entry, DA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in,out] ZX +*> \verbatim +*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of ZX +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup scal +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, 3/11/78. +*> modified 3/93 to return if incx .le. 0. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZDSCAL(N,DA,ZX,INCX) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + DOUBLE PRECISION DA + INTEGER INCX,N +* .. +* .. Array Arguments .. + COMPLEX*16 ZX(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,NINCX +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER (ONE=1.0D+0) +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, DCMPLX, DIMAG +* .. + IF (N.LE.0 .OR. INCX.LE.0 .OR. DA.EQ.ONE) RETURN + IF (INCX.EQ.1) THEN +* +* code for increment equal to 1 +* + DO I = 1,N + ZX(I) = DCMPLX(DA*DBLE(ZX(I)),DA*DIMAG(ZX(I))) + END DO + ELSE +* +* code for increment not equal to 1 +* + NINCX = N*INCX + DO I = 1,NINCX,INCX + ZX(I) = DCMPLX(DA*DBLE(ZX(I)),DA*DIMAG(ZX(I))) + END DO + END IF + RETURN +* +* End of ZDSCAL +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/lapack_routine/zgemm.f b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/zgemm.f new file mode 100644 index 0000000..3661195 --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/zgemm.f @@ -0,0 +1,478 @@ +*> \brief \b ZGEMM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA,BETA +* INTEGER K,LDA,LDB,LDC,M,N +* CHARACTER TRANSA,TRANSB +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGEMM performs one of the matrix-matrix operations +*> +*> C := alpha*op( A )*op( B ) + beta*C, +*> +*> where op( X ) is one of +*> +*> op( X ) = X or op( X ) = X**T or op( X ) = X**H, +*> +*> alpha and beta are scalars, and A, B and C are matrices, with op( A ) +*> an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANSA +*> \verbatim +*> TRANSA is CHARACTER*1 +*> On entry, TRANSA specifies the form of op( A ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSA = 'N' or 'n', op( A ) = A. +*> +*> TRANSA = 'T' or 't', op( A ) = A**T. +*> +*> TRANSA = 'C' or 'c', op( A ) = A**H. +*> \endverbatim +*> +*> \param[in] TRANSB +*> \verbatim +*> TRANSB is CHARACTER*1 +*> On entry, TRANSB specifies the form of op( B ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSB = 'N' or 'n', op( B ) = B. +*> +*> TRANSB = 'T' or 't', op( B ) = B**T. +*> +*> TRANSB = 'C' or 'c', op( B ) = B**H. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix +*> op( A ) and of the matrix C. M must be at least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of the matrix +*> op( B ) and the number of columns of the matrix C. N must be +*> at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry, K specifies the number of columns of the matrix +*> op( A ) and the number of rows of the matrix op( B ). K must +*> be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX*16 +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension ( LDA, ka ), where ka is +*> k when TRANSA = 'N' or 'n', and is m otherwise. +*> Before entry with TRANSA = 'N' or 'n', the leading m by k +*> part of the array A must contain the matrix A, otherwise +*> the leading k by m part of the array A must contain the +*> matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When TRANSA = 'N' or 'n' then +*> LDA must be at least max( 1, m ), otherwise LDA must be at +*> least max( 1, k ). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is COMPLEX*16 array, dimension ( LDB, kb ), where kb is +*> n when TRANSB = 'N' or 'n', and is k otherwise. +*> Before entry with TRANSB = 'N' or 'n', the leading k by n +*> part of the array B must contain the matrix B, otherwise +*> the leading n by k part of the array B must contain the +*> matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. When TRANSB = 'N' or 'n' then +*> LDB must be at least max( 1, k ), otherwise LDB must be at +*> least max( 1, n ). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is COMPLEX*16 +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then C need not be set on input. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX*16 array, dimension ( LDC, N ) +*> Before entry, the leading m by n part of the array C must +*> contain the matrix C, except when beta is zero, in which +*> case C need not be set on entry. +*> On exit, the array C is overwritten by the m by n matrix +*> ( alpha*op( A )*op( B ) + beta*C ). +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> On entry, LDC specifies the first dimension of C as declared +*> in the calling (sub) program. LDC must be at least +*> max( 1, m ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup gemm +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> -- Written on 8-February-1989. +*> Jack Dongarra, Argonne National Laboratory. +*> Iain Duff, AERE Harwell. +*> Jeremy Du Croz, Numerical Algorithms Group Ltd. +*> Sven Hammarling, Numerical Algorithms Group Ltd. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB, + + BETA,C,LDC) +* +* -- Reference BLAS level3 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX*16 ALPHA,BETA + INTEGER K,LDA,LDB,LDC,M,N + CHARACTER TRANSA,TRANSB +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG,MAX +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,J,L,NROWA,NROWB + LOGICAL CONJA,CONJB,NOTA,NOTB +* .. +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER (ONE= (1.0D+0,0.0D+0)) + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* +* Set NOTA and NOTB as true if A and B respectively are not +* conjugated or transposed, set CONJA and CONJB as true if A and +* B respectively are to be transposed but not conjugated and set +* NROWA and NROWB as the number of rows of A and B respectively. +* + NOTA = LSAME(TRANSA,'N') + NOTB = LSAME(TRANSB,'N') + CONJA = LSAME(TRANSA,'C') + CONJB = LSAME(TRANSB,'C') + IF (NOTA) THEN + NROWA = M + ELSE + NROWA = K + END IF + IF (NOTB) THEN + NROWB = K + ELSE + NROWB = N + END IF +* +* Test the input parameters. +* + INFO = 0 + IF ((.NOT.NOTA) .AND. (.NOT.CONJA) .AND. + + (.NOT.LSAME(TRANSA,'T'))) THEN + INFO = 1 + ELSE IF ((.NOT.NOTB) .AND. (.NOT.CONJB) .AND. + + (.NOT.LSAME(TRANSB,'T'))) THEN + INFO = 2 + ELSE IF (M.LT.0) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (K.LT.0) THEN + INFO = 5 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 8 + ELSE IF (LDB.LT.MAX(1,NROWB)) THEN + INFO = 10 + ELSE IF (LDC.LT.MAX(1,M)) THEN + INFO = 13 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('ZGEMM ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. + + (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + IF (BETA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,M + C(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1,N + DO 30 I = 1,M + C(I,J) = BETA*C(I,J) + 30 CONTINUE + 40 CONTINUE + END IF + RETURN + END IF +* +* Start the operations. +* + IF (NOTB) THEN + IF (NOTA) THEN +* +* Form C := alpha*A*B + beta*C. +* + DO 90 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 50 I = 1,M + C(I,J) = ZERO + 50 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 60 I = 1,M + C(I,J) = BETA*C(I,J) + 60 CONTINUE + END IF + DO 80 L = 1,K + TEMP = ALPHA*B(L,J) + DO 70 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + ELSE IF (CONJA) THEN +* +* Form C := alpha*A**H*B + beta*C. +* + DO 120 J = 1,N + DO 110 I = 1,M + TEMP = ZERO + DO 100 L = 1,K + TEMP = TEMP + DCONJG(A(L,I))*B(L,J) + 100 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 110 CONTINUE + 120 CONTINUE + ELSE +* +* Form C := alpha*A**T*B + beta*C +* + DO 150 J = 1,N + DO 140 I = 1,M + TEMP = ZERO + DO 130 L = 1,K + TEMP = TEMP + A(L,I)*B(L,J) + 130 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 140 CONTINUE + 150 CONTINUE + END IF + ELSE IF (NOTA) THEN + IF (CONJB) THEN +* +* Form C := alpha*A*B**H + beta*C. +* + DO 200 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 160 I = 1,M + C(I,J) = ZERO + 160 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 170 I = 1,M + C(I,J) = BETA*C(I,J) + 170 CONTINUE + END IF + DO 190 L = 1,K + TEMP = ALPHA*DCONJG(B(J,L)) + DO 180 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 180 CONTINUE + 190 CONTINUE + 200 CONTINUE + ELSE +* +* Form C := alpha*A*B**T + beta*C +* + DO 250 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 210 I = 1,M + C(I,J) = ZERO + 210 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 220 I = 1,M + C(I,J) = BETA*C(I,J) + 220 CONTINUE + END IF + DO 240 L = 1,K + TEMP = ALPHA*B(J,L) + DO 230 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 230 CONTINUE + 240 CONTINUE + 250 CONTINUE + END IF + ELSE IF (CONJA) THEN + IF (CONJB) THEN +* +* Form C := alpha*A**H*B**H + beta*C. +* + DO 280 J = 1,N + DO 270 I = 1,M + TEMP = ZERO + DO 260 L = 1,K + TEMP = TEMP + DCONJG(A(L,I))*DCONJG(B(J,L)) + 260 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 270 CONTINUE + 280 CONTINUE + ELSE +* +* Form C := alpha*A**H*B**T + beta*C +* + DO 310 J = 1,N + DO 300 I = 1,M + TEMP = ZERO + DO 290 L = 1,K + TEMP = TEMP + DCONJG(A(L,I))*B(J,L) + 290 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 300 CONTINUE + 310 CONTINUE + END IF + ELSE + IF (CONJB) THEN +* +* Form C := alpha*A**T*B**H + beta*C +* + DO 340 J = 1,N + DO 330 I = 1,M + TEMP = ZERO + DO 320 L = 1,K + TEMP = TEMP + A(L,I)*DCONJG(B(J,L)) + 320 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 330 CONTINUE + 340 CONTINUE + ELSE +* +* Form C := alpha*A**T*B**T + beta*C +* + DO 370 J = 1,N + DO 360 I = 1,M + TEMP = ZERO + DO 350 L = 1,K + TEMP = TEMP + A(L,I)*B(J,L) + 350 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 360 CONTINUE + 370 CONTINUE + END IF + END IF +* + RETURN +* +* End of ZGEMM +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/lapack_routine/zgemv.f b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/zgemv.f new file mode 100644 index 0000000..ccc256b --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/zgemv.f @@ -0,0 +1,349 @@ +*> \brief \b ZGEMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA,BETA +* INTEGER INCX,INCY,LDA,M,N +* CHARACTER TRANS +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGEMV performs one of the matrix-vector operations +*> +*> y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, or +*> +*> y := alpha*A**H*x + beta*y, +*> +*> where alpha and beta are scalars, x and y are vectors and A is an +*> m by n matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the operation to be performed as +*> follows: +*> +*> TRANS = 'N' or 'n' y := alpha*A*x + beta*y. +*> +*> TRANS = 'T' or 't' y := alpha*A**T*x + beta*y. +*> +*> TRANS = 'C' or 'c' y := alpha*A**H*x + beta*y. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix A. +*> M must be at least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX*16 +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension ( LDA, N ) +*> Before entry, the leading m by n part of the array A must +*> contain the matrix of coefficients. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> max( 1, m ). +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is COMPLEX*16 array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' +*> and at least +*> ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. +*> Before entry, the incremented array X must contain the +*> vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is COMPLEX*16 +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then Y need not be set on input. +*> \endverbatim +*> +*> \param[in,out] Y +*> \verbatim +*> Y is COMPLEX*16 array, dimension at least +*> ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' +*> and at least +*> ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. +*> Before entry with BETA non-zero, the incremented array Y +*> must contain the vector y. On exit, Y is overwritten by the +*> updated vector y. +*> If either m or n is zero, then Y not referenced and the function +*> performs a quick return. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> Y. INCY must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup gemv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> The vector and matrix arguments are not referenced when N = 0, or M = 0 +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX*16 ALPHA,BETA + INTEGER INCX,INCY,LDA,M,N + CHARACTER TRANS +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER (ONE= (1.0D+0,0.0D+0)) + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY,LENX,LENY + LOGICAL NOCONJ +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG,MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. + + .NOT.LSAME(TRANS,'C')) THEN + INFO = 1 + ELSE IF (M.LT.0) THEN + INFO = 2 + ELSE IF (N.LT.0) THEN + INFO = 3 + ELSE IF (LDA.LT.MAX(1,M)) THEN + INFO = 6 + ELSE IF (INCX.EQ.0) THEN + INFO = 8 + ELSE IF (INCY.EQ.0) THEN + INFO = 11 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('ZGEMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. + + ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN +* + NOCONJ = LSAME(TRANS,'T') +* +* Set LENX and LENY, the lengths of the vectors x and y, and set +* up the start points in X and Y. +* + IF (LSAME(TRANS,'N')) THEN + LENX = N + LENY = M + ELSE + LENX = M + LENY = N + END IF + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (LENX-1)*INCX + END IF + IF (INCY.GT.0) THEN + KY = 1 + ELSE + KY = 1 - (LENY-1)*INCY + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* +* First form y := beta*y. +* + IF (BETA.NE.ONE) THEN + IF (INCY.EQ.1) THEN + IF (BETA.EQ.ZERO) THEN + DO 10 I = 1,LENY + Y(I) = ZERO + 10 CONTINUE + ELSE + DO 20 I = 1,LENY + Y(I) = BETA*Y(I) + 20 CONTINUE + END IF + ELSE + IY = KY + IF (BETA.EQ.ZERO) THEN + DO 30 I = 1,LENY + Y(IY) = ZERO + IY = IY + INCY + 30 CONTINUE + ELSE + DO 40 I = 1,LENY + Y(IY) = BETA*Y(IY) + IY = IY + INCY + 40 CONTINUE + END IF + END IF + END IF + IF (ALPHA.EQ.ZERO) RETURN + IF (LSAME(TRANS,'N')) THEN +* +* Form y := alpha*A*x + y. +* + JX = KX + IF (INCY.EQ.1) THEN + DO 60 J = 1,N + TEMP = ALPHA*X(JX) + DO 50 I = 1,M + Y(I) = Y(I) + TEMP*A(I,J) + 50 CONTINUE + JX = JX + INCX + 60 CONTINUE + ELSE + DO 80 J = 1,N + TEMP = ALPHA*X(JX) + IY = KY + DO 70 I = 1,M + Y(IY) = Y(IY) + TEMP*A(I,J) + IY = IY + INCY + 70 CONTINUE + JX = JX + INCX + 80 CONTINUE + END IF + ELSE +* +* Form y := alpha*A**T*x + y or y := alpha*A**H*x + y. +* + JY = KY + IF (INCX.EQ.1) THEN + DO 110 J = 1,N + TEMP = ZERO + IF (NOCONJ) THEN + DO 90 I = 1,M + TEMP = TEMP + A(I,J)*X(I) + 90 CONTINUE + ELSE + DO 100 I = 1,M + TEMP = TEMP + DCONJG(A(I,J))*X(I) + 100 CONTINUE + END IF + Y(JY) = Y(JY) + ALPHA*TEMP + JY = JY + INCY + 110 CONTINUE + ELSE + DO 140 J = 1,N + TEMP = ZERO + IX = KX + IF (NOCONJ) THEN + DO 120 I = 1,M + TEMP = TEMP + A(I,J)*X(IX) + IX = IX + INCX + 120 CONTINUE + ELSE + DO 130 I = 1,M + TEMP = TEMP + DCONJG(A(I,J))*X(IX) + IX = IX + INCX + 130 CONTINUE + END IF + Y(JY) = Y(JY) + ALPHA*TEMP + JY = JY + INCY + 140 CONTINUE + END IF + END IF +* + RETURN +* +* End of ZGEMV +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/lapack_routine/zgerc.f b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/zgerc.f new file mode 100644 index 0000000..42060d3 --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/zgerc.f @@ -0,0 +1,224 @@ +*> \brief \b ZGERC +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZGERC(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA +* INTEGER INCX,INCY,LDA,M,N +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGERC performs the rank 1 operation +*> +*> A := alpha*x*y**H + A, +*> +*> where alpha is a scalar, x is an m element vector, y is an n element +*> vector and A is an m by n matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix A. +*> M must be at least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX*16 +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is COMPLEX*16 array, dimension at least +*> ( 1 + ( m - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the m +*> element vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in] Y +*> \verbatim +*> Y is COMPLEX*16 array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCY ) ). +*> Before entry, the incremented array Y must contain the n +*> element vector y. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> Y. INCY must not be zero. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension ( LDA, N ) +*> Before entry, the leading m by n part of the array A must +*> contain the matrix of coefficients. On exit, A is +*> overwritten by the updated matrix. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> max( 1, m ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup ger +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZGERC(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX*16 ALPHA + INTEGER INCX,INCY,LDA,M,N +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,IX,J,JY,KX +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG,MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (M.LT.0) THEN + INFO = 1 + ELSE IF (N.LT.0) THEN + INFO = 2 + ELSE IF (INCX.EQ.0) THEN + INFO = 5 + ELSE IF (INCY.EQ.0) THEN + INFO = 7 + ELSE IF (LDA.LT.MAX(1,M)) THEN + INFO = 9 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('ZGERC ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* + IF (INCY.GT.0) THEN + JY = 1 + ELSE + JY = 1 - (N-1)*INCY + END IF + IF (INCX.EQ.1) THEN + DO 20 J = 1,N + IF (Y(JY).NE.ZERO) THEN + TEMP = ALPHA*DCONJG(Y(JY)) + DO 10 I = 1,M + A(I,J) = A(I,J) + X(I)*TEMP + 10 CONTINUE + END IF + JY = JY + INCY + 20 CONTINUE + ELSE + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (M-1)*INCX + END IF + DO 40 J = 1,N + IF (Y(JY).NE.ZERO) THEN + TEMP = ALPHA*DCONJG(Y(JY)) + IX = KX + DO 30 I = 1,M + A(I,J) = A(I,J) + X(IX)*TEMP + IX = IX + INCX + 30 CONTINUE + END IF + JY = JY + INCY + 40 CONTINUE + END IF +* + RETURN +* +* End of ZGERC +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/lapack_routine/zscal.f b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/zscal.f new file mode 100644 index 0000000..8bbb4fd --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/zscal.f @@ -0,0 +1,121 @@ +*> \brief \b ZSCAL +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZSCAL(N,ZA,ZX,INCX) +* +* .. Scalar Arguments .. +* COMPLEX*16 ZA +* INTEGER INCX,N +* .. +* .. Array Arguments .. +* COMPLEX*16 ZX(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZSCAL scales a vector by a constant. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] ZA +*> \verbatim +*> ZA is COMPLEX*16 +*> On entry, ZA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in,out] ZX +*> \verbatim +*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of ZX +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup scal +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, 3/11/78. +*> modified 3/93 to return if incx .le. 0. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZSCAL(N,ZA,ZX,INCX) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX*16 ZA + INTEGER INCX,N +* .. +* .. Array Arguments .. + COMPLEX*16 ZX(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,NINCX +* .. +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER (ONE= (1.0D+0,0.0D+0)) +* .. + IF (N.LE.0 .OR. INCX.LE.0 .OR. ZA.EQ.ONE) RETURN + IF (INCX.EQ.1) THEN +* +* code for increment equal to 1 +* + DO I = 1,N + ZX(I) = ZA*ZX(I) + END DO + ELSE +* +* code for increment not equal to 1 +* + NINCX = N*INCX + DO I = 1,NINCX,INCX + ZX(I) = ZA*ZX(I) + END DO + END IF + RETURN +* +* End of ZSCAL +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/lapack_routine/zswap.f b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/zswap.f new file mode 100644 index 0000000..d27d432 --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/zswap.f @@ -0,0 +1,129 @@ +*> \brief \b ZSWAP +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZSWAP(N,ZX,INCX,ZY,INCY) +* +* .. Scalar Arguments .. +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* COMPLEX*16 ZX(*),ZY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZSWAP interchanges two vectors. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in,out] ZX +*> \verbatim +*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of ZX +*> \endverbatim +*> +*> \param[in,out] ZY +*> \verbatim +*> ZY is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of ZY +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup swap +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, 3/11/78. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZSWAP(N,ZX,INCX,ZY,INCY) +* +* -- Reference BLAS level1 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + COMPLEX*16 ZX(*),ZY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + COMPLEX*16 ZTEMP + INTEGER I,IX,IY +* .. + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 + DO I = 1,N + ZTEMP = ZX(I) + ZX(I) = ZY(I) + ZY(I) = ZTEMP + END DO + ELSE +* +* code for unequal increments or equal increments not equal +* to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + ZTEMP = ZX(IX) + ZX(IX) = ZY(IY) + ZY(IY) = ZTEMP + IX = IX + INCX + IY = IY + INCY + END DO + END IF + RETURN +* +* End of ZSWAP +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/lapack_routine/ztrmm.f b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/ztrmm.f new file mode 100644 index 0000000..e11313d --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/ztrmm.f @@ -0,0 +1,450 @@ +*> \brief \b ZTRMM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA +* INTEGER LDA,LDB,M,N +* CHARACTER DIAG,SIDE,TRANSA,UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),B(LDB,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZTRMM performs one of the matrix-matrix operations +*> +*> B := alpha*op( A )*B, or B := alpha*B*op( A ) +*> +*> where alpha is a scalar, B is an m by n matrix, A is a unit, or +*> non-unit, upper or lower triangular matrix and op( A ) is one of +*> +*> op( A ) = A or op( A ) = A**T or op( A ) = A**H. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> On entry, SIDE specifies whether op( A ) multiplies B from +*> the left or right as follows: +*> +*> SIDE = 'L' or 'l' B := alpha*op( A )*B. +*> +*> SIDE = 'R' or 'r' B := alpha*B*op( A ). +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the matrix A is an upper or +*> lower triangular matrix as follows: +*> +*> UPLO = 'U' or 'u' A is an upper triangular matrix. +*> +*> UPLO = 'L' or 'l' A is a lower triangular matrix. +*> \endverbatim +*> +*> \param[in] TRANSA +*> \verbatim +*> TRANSA is CHARACTER*1 +*> On entry, TRANSA specifies the form of op( A ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSA = 'N' or 'n' op( A ) = A. +*> +*> TRANSA = 'T' or 't' op( A ) = A**T. +*> +*> TRANSA = 'C' or 'c' op( A ) = A**H. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> On entry, DIAG specifies whether or not A is unit triangular +*> as follows: +*> +*> DIAG = 'U' or 'u' A is assumed to be unit triangular. +*> +*> DIAG = 'N' or 'n' A is not assumed to be unit +*> triangular. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of B. M must be at +*> least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of B. N must be +*> at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX*16 +*> On entry, ALPHA specifies the scalar alpha. When alpha is +*> zero then A is not referenced and B need not be set before +*> entry. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension ( LDA, k ), where k is m +*> when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. +*> Before entry with UPLO = 'U' or 'u', the leading k by k +*> upper triangular part of the array A must contain the upper +*> triangular matrix and the strictly lower triangular part of +*> A is not referenced. +*> Before entry with UPLO = 'L' or 'l', the leading k by k +*> lower triangular part of the array A must contain the lower +*> triangular matrix and the strictly upper triangular part of +*> A is not referenced. +*> Note that when DIAG = 'U' or 'u', the diagonal elements of +*> A are not referenced either, but are assumed to be unity. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When SIDE = 'L' or 'l' then +*> LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' +*> then LDA must be at least max( 1, n ). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX*16 array, dimension ( LDB, N ). +*> Before entry, the leading m by n part of the array B must +*> contain the matrix B, and on exit is overwritten by the +*> transformed matrix. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. LDB must be at least +*> max( 1, m ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup trmm +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> -- Written on 8-February-1989. +*> Jack Dongarra, Argonne National Laboratory. +*> Iain Duff, AERE Harwell. +*> Jeremy Du Croz, Numerical Algorithms Group Ltd. +*> Sven Hammarling, Numerical Algorithms Group Ltd. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +* +* -- Reference BLAS level3 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX*16 ALPHA + INTEGER LDA,LDB,M,N + CHARACTER DIAG,SIDE,TRANSA,UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),B(LDB,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG,MAX +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,J,K,NROWA + LOGICAL LSIDE,NOCONJ,NOUNIT,UPPER +* .. +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER (ONE= (1.0D+0,0.0D+0)) + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* +* Test the input parameters. +* + LSIDE = LSAME(SIDE,'L') + IF (LSIDE) THEN + NROWA = M + ELSE + NROWA = N + END IF + NOCONJ = LSAME(TRANSA,'T') + NOUNIT = LSAME(DIAG,'N') + UPPER = LSAME(UPLO,'U') +* + INFO = 0 + IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN + INFO = 1 + ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN + INFO = 2 + ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND. + + (.NOT.LSAME(TRANSA,'T')) .AND. + + (.NOT.LSAME(TRANSA,'C'))) THEN + INFO = 3 + ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. + + (.NOT.LSAME(DIAG,'N'))) THEN + INFO = 4 + ELSE IF (M.LT.0) THEN + INFO = 5 + ELSE IF (N.LT.0) THEN + INFO = 6 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 9 + ELSE IF (LDB.LT.MAX(1,M)) THEN + INFO = 11 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('ZTRMM ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (M.EQ.0 .OR. N.EQ.0) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,M + B(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + RETURN + END IF +* +* Start the operations. +* + IF (LSIDE) THEN + IF (LSAME(TRANSA,'N')) THEN +* +* Form B := alpha*A*B. +* + IF (UPPER) THEN + DO 50 J = 1,N + DO 40 K = 1,M + IF (B(K,J).NE.ZERO) THEN + TEMP = ALPHA*B(K,J) + DO 30 I = 1,K - 1 + B(I,J) = B(I,J) + TEMP*A(I,K) + 30 CONTINUE + IF (NOUNIT) TEMP = TEMP*A(K,K) + B(K,J) = TEMP + END IF + 40 CONTINUE + 50 CONTINUE + ELSE + DO 80 J = 1,N + DO 70 K = M,1,-1 + IF (B(K,J).NE.ZERO) THEN + TEMP = ALPHA*B(K,J) + B(K,J) = TEMP + IF (NOUNIT) B(K,J) = B(K,J)*A(K,K) + DO 60 I = K + 1,M + B(I,J) = B(I,J) + TEMP*A(I,K) + 60 CONTINUE + END IF + 70 CONTINUE + 80 CONTINUE + END IF + ELSE +* +* Form B := alpha*A**T*B or B := alpha*A**H*B. +* + IF (UPPER) THEN + DO 120 J = 1,N + DO 110 I = M,1,-1 + TEMP = B(I,J) + IF (NOCONJ) THEN + IF (NOUNIT) TEMP = TEMP*A(I,I) + DO 90 K = 1,I - 1 + TEMP = TEMP + A(K,I)*B(K,J) + 90 CONTINUE + ELSE + IF (NOUNIT) TEMP = TEMP*DCONJG(A(I,I)) + DO 100 K = 1,I - 1 + TEMP = TEMP + DCONJG(A(K,I))*B(K,J) + 100 CONTINUE + END IF + B(I,J) = ALPHA*TEMP + 110 CONTINUE + 120 CONTINUE + ELSE + DO 160 J = 1,N + DO 150 I = 1,M + TEMP = B(I,J) + IF (NOCONJ) THEN + IF (NOUNIT) TEMP = TEMP*A(I,I) + DO 130 K = I + 1,M + TEMP = TEMP + A(K,I)*B(K,J) + 130 CONTINUE + ELSE + IF (NOUNIT) TEMP = TEMP*DCONJG(A(I,I)) + DO 140 K = I + 1,M + TEMP = TEMP + DCONJG(A(K,I))*B(K,J) + 140 CONTINUE + END IF + B(I,J) = ALPHA*TEMP + 150 CONTINUE + 160 CONTINUE + END IF + END IF + ELSE + IF (LSAME(TRANSA,'N')) THEN +* +* Form B := alpha*B*A. +* + IF (UPPER) THEN + DO 200 J = N,1,-1 + TEMP = ALPHA + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 170 I = 1,M + B(I,J) = TEMP*B(I,J) + 170 CONTINUE + DO 190 K = 1,J - 1 + IF (A(K,J).NE.ZERO) THEN + TEMP = ALPHA*A(K,J) + DO 180 I = 1,M + B(I,J) = B(I,J) + TEMP*B(I,K) + 180 CONTINUE + END IF + 190 CONTINUE + 200 CONTINUE + ELSE + DO 240 J = 1,N + TEMP = ALPHA + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 210 I = 1,M + B(I,J) = TEMP*B(I,J) + 210 CONTINUE + DO 230 K = J + 1,N + IF (A(K,J).NE.ZERO) THEN + TEMP = ALPHA*A(K,J) + DO 220 I = 1,M + B(I,J) = B(I,J) + TEMP*B(I,K) + 220 CONTINUE + END IF + 230 CONTINUE + 240 CONTINUE + END IF + ELSE +* +* Form B := alpha*B*A**T or B := alpha*B*A**H. +* + IF (UPPER) THEN + DO 280 K = 1,N + DO 260 J = 1,K - 1 + IF (A(J,K).NE.ZERO) THEN + IF (NOCONJ) THEN + TEMP = ALPHA*A(J,K) + ELSE + TEMP = ALPHA*DCONJG(A(J,K)) + END IF + DO 250 I = 1,M + B(I,J) = B(I,J) + TEMP*B(I,K) + 250 CONTINUE + END IF + 260 CONTINUE + TEMP = ALPHA + IF (NOUNIT) THEN + IF (NOCONJ) THEN + TEMP = TEMP*A(K,K) + ELSE + TEMP = TEMP*DCONJG(A(K,K)) + END IF + END IF + IF (TEMP.NE.ONE) THEN + DO 270 I = 1,M + B(I,K) = TEMP*B(I,K) + 270 CONTINUE + END IF + 280 CONTINUE + ELSE + DO 320 K = N,1,-1 + DO 300 J = K + 1,N + IF (A(J,K).NE.ZERO) THEN + IF (NOCONJ) THEN + TEMP = ALPHA*A(J,K) + ELSE + TEMP = ALPHA*DCONJG(A(J,K)) + END IF + DO 290 I = 1,M + B(I,J) = B(I,J) + TEMP*B(I,K) + 290 CONTINUE + END IF + 300 CONTINUE + TEMP = ALPHA + IF (NOUNIT) THEN + IF (NOCONJ) THEN + TEMP = TEMP*A(K,K) + ELSE + TEMP = TEMP*DCONJG(A(K,K)) + END IF + END IF + IF (TEMP.NE.ONE) THEN + DO 310 I = 1,M + B(I,K) = TEMP*B(I,K) + 310 CONTINUE + END IF + 320 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of ZTRMM +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/lapack_routine/ztrmv.f b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/ztrmv.f new file mode 100644 index 0000000..f72def8 --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/ztrmv.f @@ -0,0 +1,372 @@ +*> \brief \b ZTRMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,LDA,N +* CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZTRMV performs one of the matrix-vector operations +*> +*> x := A*x, or x := A**T*x, or x := A**H*x, +*> +*> where x is an n element vector and A is an n by n unit, or non-unit, +*> upper or lower triangular matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the matrix is an upper or +*> lower triangular matrix as follows: +*> +*> UPLO = 'U' or 'u' A is an upper triangular matrix. +*> +*> UPLO = 'L' or 'l' A is a lower triangular matrix. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the operation to be performed as +*> follows: +*> +*> TRANS = 'N' or 'n' x := A*x. +*> +*> TRANS = 'T' or 't' x := A**T*x. +*> +*> TRANS = 'C' or 'c' x := A**H*x. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> On entry, DIAG specifies whether or not A is unit +*> triangular as follows: +*> +*> DIAG = 'U' or 'u' A is assumed to be unit triangular. +*> +*> DIAG = 'N' or 'n' A is not assumed to be unit +*> triangular. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension ( LDA, N ). +*> Before entry with UPLO = 'U' or 'u', the leading n by n +*> upper triangular part of the array A must contain the upper +*> triangular matrix and the strictly lower triangular part of +*> A is not referenced. +*> Before entry with UPLO = 'L' or 'l', the leading n by n +*> lower triangular part of the array A must contain the lower +*> triangular matrix and the strictly upper triangular part of +*> A is not referenced. +*> Note that when DIAG = 'U' or 'u', the diagonal elements of +*> A are not referenced either, but are assumed to be unity. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> max( 1, n ). +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is COMPLEX*16 array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element vector x. On exit, X is overwritten with the +*> transformed vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup trmv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> The vector and matrix arguments are not referenced when N = 0, or M = 0 +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,LDA,N + CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,IX,J,JX,KX + LOGICAL NOCONJ,NOUNIT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG,MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (.NOT.LSAME(TRANS,'N') .AND. + + .NOT.LSAME(TRANS,'T') .AND. + + .NOT.LSAME(TRANS,'C')) THEN + INFO = 2 + ELSE IF (.NOT.LSAME(DIAG,'U') .AND. + + .NOT.LSAME(DIAG,'N')) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (LDA.LT.MAX(1,N)) THEN + INFO = 6 + ELSE IF (INCX.EQ.0) THEN + INFO = 8 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('ZTRMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (N.EQ.0) RETURN +* + NOCONJ = LSAME(TRANS,'T') + NOUNIT = LSAME(DIAG,'N') +* +* Set up the start point in X if the increment is not unity. This +* will be ( N - 1 )*INCX too small for descending loops. +* + IF (INCX.LE.0) THEN + KX = 1 - (N-1)*INCX + ELSE IF (INCX.NE.1) THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* + IF (LSAME(TRANS,'N')) THEN +* +* Form x := A*x. +* + IF (LSAME(UPLO,'U')) THEN + IF (INCX.EQ.1) THEN + DO 20 J = 1,N + IF (X(J).NE.ZERO) THEN + TEMP = X(J) + DO 10 I = 1,J - 1 + X(I) = X(I) + TEMP*A(I,J) + 10 CONTINUE + IF (NOUNIT) X(J) = X(J)*A(J,J) + END IF + 20 CONTINUE + ELSE + JX = KX + DO 40 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = X(JX) + IX = KX + DO 30 I = 1,J - 1 + X(IX) = X(IX) + TEMP*A(I,J) + IX = IX + INCX + 30 CONTINUE + IF (NOUNIT) X(JX) = X(JX)*A(J,J) + END IF + JX = JX + INCX + 40 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 60 J = N,1,-1 + IF (X(J).NE.ZERO) THEN + TEMP = X(J) + DO 50 I = N,J + 1,-1 + X(I) = X(I) + TEMP*A(I,J) + 50 CONTINUE + IF (NOUNIT) X(J) = X(J)*A(J,J) + END IF + 60 CONTINUE + ELSE + KX = KX + (N-1)*INCX + JX = KX + DO 80 J = N,1,-1 + IF (X(JX).NE.ZERO) THEN + TEMP = X(JX) + IX = KX + DO 70 I = N,J + 1,-1 + X(IX) = X(IX) + TEMP*A(I,J) + IX = IX - INCX + 70 CONTINUE + IF (NOUNIT) X(JX) = X(JX)*A(J,J) + END IF + JX = JX - INCX + 80 CONTINUE + END IF + END IF + ELSE +* +* Form x := A**T*x or x := A**H*x. +* + IF (LSAME(UPLO,'U')) THEN + IF (INCX.EQ.1) THEN + DO 110 J = N,1,-1 + TEMP = X(J) + IF (NOCONJ) THEN + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 90 I = J - 1,1,-1 + TEMP = TEMP + A(I,J)*X(I) + 90 CONTINUE + ELSE + IF (NOUNIT) TEMP = TEMP*DCONJG(A(J,J)) + DO 100 I = J - 1,1,-1 + TEMP = TEMP + DCONJG(A(I,J))*X(I) + 100 CONTINUE + END IF + X(J) = TEMP + 110 CONTINUE + ELSE + JX = KX + (N-1)*INCX + DO 140 J = N,1,-1 + TEMP = X(JX) + IX = JX + IF (NOCONJ) THEN + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 120 I = J - 1,1,-1 + IX = IX - INCX + TEMP = TEMP + A(I,J)*X(IX) + 120 CONTINUE + ELSE + IF (NOUNIT) TEMP = TEMP*DCONJG(A(J,J)) + DO 130 I = J - 1,1,-1 + IX = IX - INCX + TEMP = TEMP + DCONJG(A(I,J))*X(IX) + 130 CONTINUE + END IF + X(JX) = TEMP + JX = JX - INCX + 140 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 170 J = 1,N + TEMP = X(J) + IF (NOCONJ) THEN + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 150 I = J + 1,N + TEMP = TEMP + A(I,J)*X(I) + 150 CONTINUE + ELSE + IF (NOUNIT) TEMP = TEMP*DCONJG(A(J,J)) + DO 160 I = J + 1,N + TEMP = TEMP + DCONJG(A(I,J))*X(I) + 160 CONTINUE + END IF + X(J) = TEMP + 170 CONTINUE + ELSE + JX = KX + DO 200 J = 1,N + TEMP = X(JX) + IX = JX + IF (NOCONJ) THEN + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 180 I = J + 1,N + IX = IX + INCX + TEMP = TEMP + A(I,J)*X(IX) + 180 CONTINUE + ELSE + IF (NOUNIT) TEMP = TEMP*DCONJG(A(J,J)) + DO 190 I = J + 1,N + IX = IX + INCX + TEMP = TEMP + DCONJG(A(I,J))*X(IX) + 190 CONTINUE + END IF + X(JX) = TEMP + JX = JX + INCX + 200 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of ZTRMV +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/lapack_routine/ztrsv.f b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/ztrsv.f new file mode 100644 index 0000000..6587355 --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/lapack_routine/ztrsv.f @@ -0,0 +1,374 @@ +*> \brief \b ZTRSV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,LDA,N +* CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZTRSV solves one of the systems of equations +*> +*> A*x = b, or A**T*x = b, or A**H*x = b, +*> +*> where b and x are n element vectors and A is an n by n unit, or +*> non-unit, upper or lower triangular matrix. +*> +*> No test for singularity or near-singularity is included in this +*> routine. Such tests must be performed before calling this routine. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the matrix is an upper or +*> lower triangular matrix as follows: +*> +*> UPLO = 'U' or 'u' A is an upper triangular matrix. +*> +*> UPLO = 'L' or 'l' A is a lower triangular matrix. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the equations to be solved as +*> follows: +*> +*> TRANS = 'N' or 'n' A*x = b. +*> +*> TRANS = 'T' or 't' A**T*x = b. +*> +*> TRANS = 'C' or 'c' A**H*x = b. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> On entry, DIAG specifies whether or not A is unit +*> triangular as follows: +*> +*> DIAG = 'U' or 'u' A is assumed to be unit triangular. +*> +*> DIAG = 'N' or 'n' A is not assumed to be unit +*> triangular. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension ( LDA, N ) +*> Before entry with UPLO = 'U' or 'u', the leading n by n +*> upper triangular part of the array A must contain the upper +*> triangular matrix and the strictly lower triangular part of +*> A is not referenced. +*> Before entry with UPLO = 'L' or 'l', the leading n by n +*> lower triangular part of the array A must contain the lower +*> triangular matrix and the strictly upper triangular part of +*> A is not referenced. +*> Note that when DIAG = 'U' or 'u', the diagonal elements of +*> A are not referenced either, but are assumed to be unity. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> max( 1, n ). +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is COMPLEX*16 array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element right-hand side vector b. On exit, X is overwritten +*> with the solution vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup trsv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INCX,LDA,N + CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,IX,J,JX,KX + LOGICAL NOCONJ,NOUNIT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG,MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (.NOT.LSAME(TRANS,'N') .AND. + + .NOT.LSAME(TRANS,'T') .AND. + + .NOT.LSAME(TRANS,'C')) THEN + INFO = 2 + ELSE IF (.NOT.LSAME(DIAG,'U') .AND. + + .NOT.LSAME(DIAG,'N')) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (LDA.LT.MAX(1,N)) THEN + INFO = 6 + ELSE IF (INCX.EQ.0) THEN + INFO = 8 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('ZTRSV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (N.EQ.0) RETURN +* + NOCONJ = LSAME(TRANS,'T') + NOUNIT = LSAME(DIAG,'N') +* +* Set up the start point in X if the increment is not unity. This +* will be ( N - 1 )*INCX too small for descending loops. +* + IF (INCX.LE.0) THEN + KX = 1 - (N-1)*INCX + ELSE IF (INCX.NE.1) THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* + IF (LSAME(TRANS,'N')) THEN +* +* Form x := inv( A )*x. +* + IF (LSAME(UPLO,'U')) THEN + IF (INCX.EQ.1) THEN + DO 20 J = N,1,-1 + IF (X(J).NE.ZERO) THEN + IF (NOUNIT) X(J) = X(J)/A(J,J) + TEMP = X(J) + DO 10 I = J - 1,1,-1 + X(I) = X(I) - TEMP*A(I,J) + 10 CONTINUE + END IF + 20 CONTINUE + ELSE + JX = KX + (N-1)*INCX + DO 40 J = N,1,-1 + IF (X(JX).NE.ZERO) THEN + IF (NOUNIT) X(JX) = X(JX)/A(J,J) + TEMP = X(JX) + IX = JX + DO 30 I = J - 1,1,-1 + IX = IX - INCX + X(IX) = X(IX) - TEMP*A(I,J) + 30 CONTINUE + END IF + JX = JX - INCX + 40 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 60 J = 1,N + IF (X(J).NE.ZERO) THEN + IF (NOUNIT) X(J) = X(J)/A(J,J) + TEMP = X(J) + DO 50 I = J + 1,N + X(I) = X(I) - TEMP*A(I,J) + 50 CONTINUE + END IF + 60 CONTINUE + ELSE + JX = KX + DO 80 J = 1,N + IF (X(JX).NE.ZERO) THEN + IF (NOUNIT) X(JX) = X(JX)/A(J,J) + TEMP = X(JX) + IX = JX + DO 70 I = J + 1,N + IX = IX + INCX + X(IX) = X(IX) - TEMP*A(I,J) + 70 CONTINUE + END IF + JX = JX + INCX + 80 CONTINUE + END IF + END IF + ELSE +* +* Form x := inv( A**T )*x or x := inv( A**H )*x. +* + IF (LSAME(UPLO,'U')) THEN + IF (INCX.EQ.1) THEN + DO 110 J = 1,N + TEMP = X(J) + IF (NOCONJ) THEN + DO 90 I = 1,J - 1 + TEMP = TEMP - A(I,J)*X(I) + 90 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(J,J) + ELSE + DO 100 I = 1,J - 1 + TEMP = TEMP - DCONJG(A(I,J))*X(I) + 100 CONTINUE + IF (NOUNIT) TEMP = TEMP/DCONJG(A(J,J)) + END IF + X(J) = TEMP + 110 CONTINUE + ELSE + JX = KX + DO 140 J = 1,N + IX = KX + TEMP = X(JX) + IF (NOCONJ) THEN + DO 120 I = 1,J - 1 + TEMP = TEMP - A(I,J)*X(IX) + IX = IX + INCX + 120 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(J,J) + ELSE + DO 130 I = 1,J - 1 + TEMP = TEMP - DCONJG(A(I,J))*X(IX) + IX = IX + INCX + 130 CONTINUE + IF (NOUNIT) TEMP = TEMP/DCONJG(A(J,J)) + END IF + X(JX) = TEMP + JX = JX + INCX + 140 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 170 J = N,1,-1 + TEMP = X(J) + IF (NOCONJ) THEN + DO 150 I = N,J + 1,-1 + TEMP = TEMP - A(I,J)*X(I) + 150 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(J,J) + ELSE + DO 160 I = N,J + 1,-1 + TEMP = TEMP - DCONJG(A(I,J))*X(I) + 160 CONTINUE + IF (NOUNIT) TEMP = TEMP/DCONJG(A(J,J)) + END IF + X(J) = TEMP + 170 CONTINUE + ELSE + KX = KX + (N-1)*INCX + JX = KX + DO 200 J = N,1,-1 + IX = KX + TEMP = X(JX) + IF (NOCONJ) THEN + DO 180 I = N,J + 1,-1 + TEMP = TEMP - A(I,J)*X(IX) + IX = IX - INCX + 180 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(J,J) + ELSE + DO 190 I = N,J + 1,-1 + TEMP = TEMP - DCONJG(A(I,J))*X(IX) + IX = IX - INCX + 190 CONTINUE + IF (NOUNIT) TEMP = TEMP/DCONJG(A(J,J)) + END IF + X(JX) = TEMP + JX = JX - INCX + 200 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of ZTRSV +* + END diff --git a/fortran_implementation/external_libraries/lapack_routines/util/dlamch.f b/fortran_implementation/external_libraries/lapack_routines/util/dlamch.f new file mode 100644 index 0000000..9073cd4 --- /dev/null +++ b/fortran_implementation/external_libraries/lapack_routines/util/dlamch.f @@ -0,0 +1,194 @@ +*> \brief \b DLAMCH +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) +* +* .. Scalar Arguments .. +* CHARACTER CMACH +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAMCH determines double precision machine parameters. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] CMACH +*> \verbatim +*> CMACH is CHARACTER*1 +*> Specifies the value to be returned by DLAMCH: +*> = 'E' or 'e', DLAMCH := eps +*> = 'S' or 's , DLAMCH := sfmin +*> = 'B' or 'b', DLAMCH := base +*> = 'P' or 'p', DLAMCH := eps*base +*> = 'N' or 'n', DLAMCH := t +*> = 'R' or 'r', DLAMCH := rnd +*> = 'M' or 'm', DLAMCH := emin +*> = 'U' or 'u', DLAMCH := rmin +*> = 'L' or 'l', DLAMCH := emax +*> = 'O' or 'o', DLAMCH := rmax +*> where +*> eps = relative machine precision +*> sfmin = safe minimum, such that 1/sfmin does not overflow +*> base = base of the machine +*> prec = eps*base +*> t = number of (base) digits in the mantissa +*> rnd = 1.0 when rounding occurs in addition, 0.0 otherwise +*> emin = minimum exponent before (gradual) underflow +*> rmin = underflow threshold - base**(emin-1) +*> emax = largest exponent before overflow +*> rmax = overflow threshold - (base**emax)*(1-eps) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup auxOTHERauxiliary +* +* ===================================================================== + DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER CMACH +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION RND, EPS, SFMIN, SMALL, RMACH +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC DIGITS, EPSILON, HUGE, MAXEXPONENT, + $ MINEXPONENT, RADIX, TINY +* .. +* .. Executable Statements .. +* +* +* Assume rounding, not chopping. Always. +* + RND = ONE +* + IF( ONE.EQ.RND ) THEN + EPS = EPSILON(ZERO) * 0.5 + ELSE + EPS = EPSILON(ZERO) + END IF +* + IF( LSAME( CMACH, 'E' ) ) THEN + RMACH = EPS + ELSE IF( LSAME( CMACH, 'S' ) ) THEN + SFMIN = TINY(ZERO) + SMALL = ONE / HUGE(ZERO) + IF( SMALL.GE.SFMIN ) THEN +* +* Use SMALL plus a bit, to avoid the possibility of rounding +* causing overflow when computing 1/sfmin. +* + SFMIN = SMALL*( ONE+EPS ) + END IF + RMACH = SFMIN + ELSE IF( LSAME( CMACH, 'B' ) ) THEN + RMACH = RADIX(ZERO) + ELSE IF( LSAME( CMACH, 'P' ) ) THEN + RMACH = EPS * RADIX(ZERO) + ELSE IF( LSAME( CMACH, 'N' ) ) THEN + RMACH = DIGITS(ZERO) + ELSE IF( LSAME( CMACH, 'R' ) ) THEN + RMACH = RND + ELSE IF( LSAME( CMACH, 'M' ) ) THEN + RMACH = MINEXPONENT(ZERO) + ELSE IF( LSAME( CMACH, 'U' ) ) THEN + RMACH = tiny(zero) + ELSE IF( LSAME( CMACH, 'L' ) ) THEN + RMACH = MAXEXPONENT(ZERO) + ELSE IF( LSAME( CMACH, 'O' ) ) THEN + RMACH = HUGE(ZERO) + ELSE + RMACH = ZERO + END IF +* + DLAMCH = RMACH + RETURN +* +* End of DLAMCH +* + END +************************************************************************ +*> \brief \b DLAMC3 +*> \details +*> \b Purpose: +*> \verbatim +*> DLAMC3 is intended to force A and B to be stored prior to doing +*> the addition of A and B , for use in situations where optimizers +*> might hold one of these in a register. +*> \endverbatim +*> \author LAPACK is a software package provided by Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. +*> \date December 2016 +*> \ingroup auxOTHERauxiliary +*> +*> \param[in] A +*> \verbatim +*> A is a DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is a DOUBLE PRECISION +*> The values A and B. +*> \endverbatim +*> + DOUBLE PRECISION FUNCTION DLAMC3( A, B ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2010 +* +* .. Scalar Arguments .. + DOUBLE PRECISION A, B +* .. +* ===================================================================== +* +* .. Executable Statements .. +* + DLAMC3 = A + B +* + RETURN +* +* End of DLAMC3 +* + END +* +************************************************************************ diff --git a/fortran_implementation/external_libraries/quadpack/quadpack.F90 b/fortran_implementation/external_libraries/quadpack/quadpack.F90 new file mode 100644 index 0000000..e7501d0 --- /dev/null +++ b/fortran_implementation/external_libraries/quadpack/quadpack.F90 @@ -0,0 +1,44 @@ +!******************************************************************************** +!> +! Main QUADPACK module. +! +! This module simply imports the specific modules for +! single, double, and quad precision. + + module quadpack + + use quadpack_single, only: qag => dqag, qage => dqage, qagi => dqagi, qagie => dqagie, qagp => dqagp, & + qagpe => dqagpe, qags => dqags, qagse => dqagse, qawc => dqawc, & + qawce => dqawce, qawf => dqawf, qawfe => dqawfe, qawo => dqawo, & + qawoe => dqawoe, qaws => dqaws, qawse => dqawse, qc25c => dqc25c, & + qc25f => dqc25f, qc25s => dqc25s, qcheb => dqcheb, qk15 => dqk15, & + qk15i => dqk15i, qk15w => dqk15w, qk21 => dqk21, qk31 => dqk31, & + qk41 => dqk41, qk51 => dqk51, qk61 => dqk61, qmomo => dqmomo, qng => dqng, & + quad => dquad, & + avint => davint, & + qnc79 => dqnc79, & + gauss8 => dgauss8, & + simpson => dsimpson, & + lobatto => dlobatto + + use quadpack_double + +#if !defined(NOQUAD) + use quadpack_quad, only: qqag => dqag, qqage => dqage, qqagi => dqagi, qqagie => dqagie, qqagp => dqagp, & + qqagpe => dqagpe, qqags => dqags, qqagse => dqagse, qqawc => dqawc, & + qqawce => dqawce, qqawf => dqawf, qqawfe => dqawfe, qqawo => dqawo, & + qqawoe => dqawoe, qqaws => dqaws, qqawse => dqawse, qqc25c => dqc25c, & + qqc25f => dqc25f, qqc25s => dqc25s, qqcheb => dqcheb, qqk15 => dqk15, & + qqk15i => dqk15i, qqk15w => dqk15w, qqk21 => dqk21, qqk31 => dqk31, & + qqk41 => dqk41, qqk51 => dqk51, qqk61 => dqk61, qqmomo => dqmomo, qqng => dqng, & + qquad => dquad, & + qavint => davint, & + qqnc79 => dqnc79, & + qgauss8 => dgauss8, & + qsimpson => dsimpson, & + qlobatto => dlobatto +#endif + +!******************************************************************************** + end module quadpack +!******************************************************************************** diff --git a/fortran_implementation/external_libraries/quadpack/quadpack_double.F90 b/fortran_implementation/external_libraries/quadpack/quadpack_double.F90 new file mode 100644 index 0000000..97430bc --- /dev/null +++ b/fortran_implementation/external_libraries/quadpack/quadpack_double.F90 @@ -0,0 +1,8 @@ +module quadpack_double + !! + !!@note For this module, `wp` is `real64` (double precision). + !! + use iso_fortran_env, only: wp => real64 +#define MOD_INCLUDE=1 +#include "quadpack_generic.F90" +end module quadpack_double diff --git a/fortran_implementation/external_libraries/quadpack/quadpack_generic.F90 b/fortran_implementation/external_libraries/quadpack/quadpack_generic.F90 new file mode 100644 index 0000000..431b23b --- /dev/null +++ b/fortran_implementation/external_libraries/quadpack/quadpack_generic.F90 @@ -0,0 +1,8560 @@ + +!******************************************************************************** +!> +! Modernized QUADPACK: a Fortran subroutine package for the numerical +! computation of definite one-dimensional integrals +! +!### References +! * Original version on [Netlib](http://www.netlib.org/quadpack/) +! +!### Authors +! * Piessens, Robert. Applied Mathematics and Programming Division, K. U. Leuven +! * de Doncker, Elise. Applied Mathematics and Programming Division, K. U. Leuven +! * Kahaner, D. K., (NBS) +! * Jacob Williams, Dec 2021. Modernized the Fortran 77 code from Netlib. + +#ifndef MOD_INCLUDE +module quadpack_generic + use iso_fortran_env, only: wp => real64 ! double precision by default +#endif + + implicit none + + private + + integer, parameter, public :: quadpack_RK = wp !! the real kind used in this module + + real(wp), dimension(5), parameter, private :: d1mach = [tiny(1.0_wp), & + huge(1.0_wp), & + real(radix(1.0_wp),kind(1.0_wp))**(-digits(1.0_wp)), & + epsilon(1.0_wp), & + log10(real(radix(1.0_wp), kind(1.0_wp)))] !! machine constants + integer,parameter :: i1mach10 = radix(1.0_wp) + integer,parameter :: i1mach14 = digits(1.0_wp) + + real(wp), parameter, private :: uflow = d1mach(1) !! the smallest positive magnitude. + real(wp), parameter, private :: oflow = d1mach(2) !! the largest positive magnitude. + real(wp), parameter, private :: epmach = d1mach(4) !! the largest relative spacing. + real(wp), parameter, private :: pi = acos(-1.0_wp) !! pi + + integer, parameter, private :: limexp = 50 !! `limexp` is the maximum number of elements the epsilon + !! table can contain. if this number is reached, the upper + !! diagonal of the epsilon table is deleted. + !! originally defined in [[dqelg]]. Was moved to be a module + !! variable since various dimensions in other routines + !! depend on the value + + abstract interface + + real(wp) function func(x) + !! interface for user-supplied function. + import :: wp + implicit none + real(wp), intent(in) :: x + end function func + + real(wp) function weight_func(x, a, b, c, d, i) + !! weight function interface for [[dqk15w]] + import :: wp + implicit none + real(wp), intent(in) :: x + real(wp), intent(in) :: a + real(wp), intent(in) :: b + real(wp), intent(in) :: c + real(wp), intent(in) :: d + integer, intent(in) :: i + end function weight_func + + end interface + + ! by default, the double precision names are exported (dqag, etc.) + public :: dqag, dqage, dqagi, dqagie, dqagp, dqagpe, dqags, & + dqagse, dqawc, dqawce, dqawf, dqawfe, dqawo, dqawoe, dqaws, & + dqawse, dqc25c, dqc25f, dqc25s, dqcheb, dqk15, dqk15i, & + dqk15w, dqk21, dqk31, dqk41, dqk51, dqk61, dqmomo, dqng + public :: dquad + public :: davint + public :: dqnc79 + public :: dgauss8 + public :: dsimpson, dlobatto + + contains +!******************************************************************************** + +!******************************************************************************** +!> +! 1D globally adaptive integrator using Gauss-Kronrod quadrature, oscillating integrand +! +! the routine calculates an approximation result to a given +! definite integral i = integral of `f` over `(a,b)`, +! hopefully satisfying following claim for accuracy +! `abs(i-result)<=max(epsabs,epsrel*abs(i))`. +! +!### History +! * QUADPACK: date written 800101, revision date 830518 (yymmdd) + + subroutine dqag(f, a, b, Epsabs, Epsrel, Key, Result, Abserr, Neval, Ier, & + Limit, Lenw, Last, Iwork, Work) + + implicit none + + procedure(func) :: f !! function subprogram defining the integrand function `f(x)`. + real(wp), intent(in) :: a !! lower limit of integration + real(wp), intent(out) :: Abserr !! estimate of the modulus of the absolute error, + !! which should equal or exceed `abs(i-result)` + real(wp), intent(in) :: b !! upper limit of integration + real(wp), intent(in) :: Epsabs !! absolute accuracy requested + real(wp), intent(in) :: Epsrel !! relative accuracy requested + !! if epsabs<=0 + !! and epsrel=1. + !! if limit<1, the routine will end with ier = 6. + real(wp) :: Work(Lenw) !! vector of dimension at least `lenw` + !! on return + !! work(1), ..., work(last) contain the left end + !! points of the subintervals in the partition of + !! (a,b), + !! `work(limit+1), ..., work(limit+last)` contain the + !! right end points, + !! `work(limit*2+1), ..., work(limit*2+last)` contain + !! the integral approximations over the subintervals, + !! work(limit*3+1), ..., work(limit*3+last) contain + !! the error estimates. + integer :: Iwork(Limit) !! vector of dimension at least `limit`, the first `k` + !! elements of which contain pointers to the error + !! estimates over the subintervals, such that + !! work(limit*3+iwork(1)),... , work(limit*3+iwork(k)) + !! form a decreasing sequence with k = last if + !! last<=(limit/2+2), and k = limit+1-last otherwise + integer, intent(out) :: Ier !! * ier = 0 normal and reliable termination of the + !! routine. it is assumed that the requested + !! accuracy has been achieved. + !! * ier>0 abnormal termination of the routine + !! the estimates for result and error are + !! less reliable. it is assumed that the + !! requested accuracy has not been achieved. + !! + !! error messages: + !! + !! * ier = 1 maximum number of subdivisions allowed + !! has been achieved. one can allow more + !! subdivisions by increasing the value of + !! limit (and taking the according dimension + !! adjustments into account). however, if + !! this yield no improvement it is advised + !! to analyze the integrand in order to + !! determine the integration difficulties. + !! if the position of a local difficulty can + !! be determined (i.e.singularity, + !! discontinuity within the interval) one + !! will probably gain from splitting up the + !! interval at this point and calling the + !! integrator on the subranges. if possible, + !! an appropriate special-purpose integrator + !! should be used which is designed for + !! handling the type of difficulty involved. + !! * ier = 2 the occurrence of roundoff error is + !! detected, which prevents the requested + !! tolerance from being achieved. + !! * ier = 3 extremely bad integrand behaviour occurs + !! at some points of the integration + !! interval. + !! * ier = 6 the input is invalid, because + !! `(epsabs<=0 and epsrel5. + integer, intent(out) :: Last !! on return, `last` equals the number of subintervals + !! produced in the subdivision process, which + !! determines the number of significant elements + !! actually in the work arrays. + integer, intent(out) :: Neval !! number of integrand evaluations + + integer :: lvl, l1, l2, l3 + + ! check validity of lenw. + Ier = 6 + Neval = 0 + Last = 0 + Result = 0.0_wp + Abserr = 0.0_wp + if (Limit >= 1 .and. Lenw >= Limit*4) then + + ! prepare call for dqage. + + l1 = Limit + 1 + l2 = Limit + l1 + l3 = Limit + l2 + + call dqage(f, a, b, Epsabs, Epsrel, Key, Limit, Result, Abserr, Neval, & + Ier, Work(1), Work(l1), Work(l2), Work(l3), Iwork, Last) + + ! call error handler if necessary. + lvl = 0 + end if + if (Ier == 6) lvl = 1 + if (Ier /= 0) call xerror('abnormal return from dqag ', Ier, lvl) + + end subroutine dqag +!******************************************************************************** + +!******************************************************************************** +!> +! same as [[dqag]] but provides more information and control +! +! the routine calculates an approximation result to a given +! definite integral i = integral of `f` over `(a,b)`, +! hopefully satisfying following claim for accuracy +! `abs(i-reslt)<=max(epsabs,epsrel*abs(i))`. +! +!### History +! * QUADPACK: date written 800101, revision date 830518 (yymmdd) + + subroutine dqage(f, a, b, Epsabs, Epsrel, Key, Limit, Result, Abserr, & + Neval, Ier, Alist, Blist, Rlist, Elist, Iord, Last) + implicit none + + procedure(func) :: f !! function subprogram defining the integrand function `f(x)`. + real(wp), intent(in) :: a !! lower limit of integration + real(wp), intent(in) :: b !! upper limit of integration + real(wp), intent(in) :: Epsabs !! absolute accuracy requested + real(wp), intent(in) :: Epsrel !! relative accuracy requested + !! if `epsabs<=0` + !! and epsrel5. + integer, intent(in) :: Limit !! gives an upperbound on the number of subintervals + !! in the partition of `(a,b)`, `limit>=1`. + real(wp), intent(out) :: Result !! approximation to the integral + real(wp), intent(out) :: Abserr !! estimate of the modulus of the absolute error, + !! which should equal or exceed `abs(i-result)` + integer, intent(out) :: Neval !! number of integrand evaluations + integer, intent(out) :: Ier !! * ier = 0 normal and reliable termination of the + !! routine. it is assumed that the requested + !! accuracy has been achieved. + !! * ier>0 abnormal termination of the routine + !! the estimates for result and error are + !! less reliable. it is assumed that the + !! requested accuracy has not been achieved. + !! + !! error messages: + !! + !! * ier = 1 maximum number of subdivisions allowed + !! has been achieved. one can allow more + !! subdivisions by increasing the value + !! of limit. + !! however, if this yields no improvement it + !! is rather advised to analyze the integrand + !! in order to determine the integration + !! difficulties. if the position of a local + !! difficulty can be determined(e.g. + !! singularity, discontinuity within the + !! interval) one will probably gain from + !! splitting up the interval at this point + !! and calling the integrator on the + !! subranges. if possible, an appropriate + !! special-purpose integrator should be used + !! which is designed for handling the type of + !! difficulty involved. + !! * ier = 2 the occurrence of roundoff error is + !! detected, which prevents the requested + !! tolerance from being achieved. + !! * ier = 3 extremely bad integrand behaviour occurs + !! at some points of the integration + !! interval. + !! * ier = 6 the input is invalid, because + !! (epsabs<=0 and + !! epsrel= 7) keyf = 6 + Neval = 0 + select case (keyf) + case (1); call dqk15(f, a, b, Result, Abserr, defabs, resabs) + case (2); call dqk21(f, a, b, Result, Abserr, defabs, resabs) + case (3); call dqk31(f, a, b, Result, Abserr, defabs, resabs) + case (4); call dqk41(f, a, b, Result, Abserr, defabs, resabs) + case (5); call dqk51(f, a, b, Result, Abserr, defabs, resabs) + case (6); call dqk61(f, a, b, Result, Abserr, defabs, resabs) + end select + Last = 1 + Rlist(1) = Result + Elist(1) = Abserr + Iord(1) = 1 + + ! test on accuracy. + + errbnd = max(Epsabs, Epsrel*abs(Result)) + if (Abserr <= 50.0_wp*epmach*defabs .and. Abserr > errbnd) Ier = 2 + if (Limit == 1) Ier = 1 + + if (.not. (Ier /= 0 .or. (Abserr <= errbnd .and. Abserr /= resabs) & + .or. Abserr == 0.0_wp)) then + + ! initialization + errmax = Abserr + maxerr = 1 + area = Result + errsum = Abserr + nrmax = 1 + iroff1 = 0 + iroff2 = 0 + + ! main do-loop + + do Last = 2, Limit + + ! bisect the subinterval with the largest error estimate. + + a1 = Alist(maxerr) + b1 = 0.5_wp*(Alist(maxerr) + Blist(maxerr)) + a2 = b1 + b2 = Blist(maxerr) + select case (keyf) + case (1) + call dqk15(f, a1, b1, area1, error1, resabs, defab1) + call dqk15(f, a2, b2, area2, error2, resabs, defab2) + case (2) + call dqk21(f, a1, b1, area1, error1, resabs, defab1) + call dqk21(f, a2, b2, area2, error2, resabs, defab2) + case (3) + call dqk31(f, a1, b1, area1, error1, resabs, defab1) + call dqk31(f, a2, b2, area2, error2, resabs, defab2) + case (4) + call dqk41(f, a1, b1, area1, error1, resabs, defab1) + call dqk41(f, a2, b2, area2, error2, resabs, defab2) + case (5) + call dqk51(f, a1, b1, area1, error1, resabs, defab1) + call dqk51(f, a2, b2, area2, error2, resabs, defab2) + case (6) + call dqk61(f, a1, b1, area1, error1, resabs, defab1) + call dqk61(f, a2, b2, area2, error2, resabs, defab2) + end select + + ! improve previous approximations to integral + ! and error and test for accuracy. + + Neval = Neval + 1 + area12 = area1 + area2 + erro12 = error1 + error2 + errsum = errsum + erro12 - errmax + area = area + area12 - Rlist(maxerr) + if (defab1 /= error1 .and. defab2 /= error2) then + if (abs(Rlist(maxerr) - area12) <= 0.1e-4_wp*abs(area12) & + .and. erro12 >= 0.99_wp*errmax) iroff1 = iroff1 + 1 + if (Last > 10 .and. erro12 > errmax) iroff2 = iroff2 + 1 + end if + Rlist(maxerr) = area1 + Rlist(Last) = area2 + errbnd = max(Epsabs, Epsrel*abs(area)) + if (errsum > errbnd) then + + ! test for roundoff error and eventually set error flag. + + if (iroff1 >= 6 .or. iroff2 >= 20) Ier = 2 + + ! set error flag in the case that the number of subintervals + ! equals limit. + + if (Last == Limit) Ier = 1 + + ! set error flag in the case of bad integrand behaviour + ! at a point of the integration range. + + if (max(abs(a1), abs(b2)) & + <= (1.0_wp + 100.0_wp*epmach) & + *(abs(a2) + 1000.0_wp*uflow)) Ier = 3 + end if + + ! append the newly-created intervals to the list. + + if (error2 > error1) then + Alist(maxerr) = a2 + Alist(Last) = a1 + Blist(Last) = b1 + Rlist(maxerr) = area2 + Rlist(Last) = area1 + Elist(maxerr) = error2 + Elist(Last) = error1 + else + Alist(Last) = a2 + Blist(maxerr) = b1 + Blist(Last) = b2 + Elist(maxerr) = error1 + Elist(Last) = error2 + end if + + ! call subroutine dqpsrt to maintain the descending ordering + ! in the list of error estimates and select the subinterval + ! with the largest error estimate (to be bisected next). + + call dqpsrt(Limit, Last, maxerr, errmax, Elist, Iord, nrmax) + if (Ier /= 0 .or. errsum <= errbnd) exit ! jump out of do-loop + end do + + ! compute final result. + + Result = 0.0_wp + do k = 1, Last + Result = Result + Rlist(k) + end do + Abserr = errsum + end if + if (keyf /= 1) Neval = (10*keyf + 1)*(2*Neval + 1) + if (keyf == 1) Neval = 30*Neval + 15 + end if + + end subroutine dqage +!******************************************************************************** + +!******************************************************************************** +!> +! 1D globally adaptive integrator, infinite intervals +! +! the routine calculates an approximation result to a given +! integral with one of the following forms: +! +! * i = integral of `f` over `(bound, +infinity)` +! * i = integral of `f` over `(-infinity, bound)` +! * i = integral of `f` over `(-infinity, +infinity)` +! +! hopefully satisfying following claim for accuracy +! `abs(i-result)<=max(epsabs,epsrel*abs(i))`. +! +!### History +! * QUADPACK: date written 800101, revision date 830518 (yymmdd) + + subroutine dqagi(f, Bound, Inf, Epsabs, Epsrel, Result, Abserr, Neval, & + Ier, Limit, Lenw, Last, Iwork, Work) + implicit none + + procedure(func) :: f !! function subprogram defining the integrand function `f(x)`. + real(wp), intent(out) :: Abserr !! estimate of the modulus of the absolute error, + !! which should equal or exceed `abs(i-result)` + real(wp), intent(in) :: Bound !! finite bound of integration range + !! (has no meaning if interval is doubly-infinite) + real(wp), intent(in) :: Epsabs !! absolute accuracy requested + real(wp), intent(in) :: Epsrel !! relative accuracy requested + !! if `epsabs<=0` + !! and `epsrel=1`. + !! if `limit<1`, the routine will end with ier = 6. + real(wp) :: Work(Lenw) !! vector of dimension at least `lenw` + !! on return: + !! * `work(1), ..., work(last)` contain the left + !! end points of the subintervals in the + !! partition of `(a,b)`, + !! * `work(limit+1), ..., work(limit+last)` contain + !! the right end points, + !! * `work(limit*2+1), ...,work(limit*2+last)` contain the + !! integral approximations over the subintervals, + !! * `work(limit*3+1), ..., work(limit*3)` + !! contain the error estimates. + integer, intent(out) :: Ier !! * ier = 0 normal and reliable termination of the + !! routine. it is assumed that the requested + !! accuracy has been achieved. + !! * ier>0 abnormal termination of the routine. the + !! estimates for result and error are less + !! reliable. it is assumed that the requested + !! accuracy has not been achieved. + !! + !! error messages: + !! + !! * ier = 1 maximum number of subdivisions allowed + !! has been achieved. one can allow more + !! subdivisions by increasing the value of + !! limit (and taking the according dimension + !! adjustments into account). however, if + !! this yields no improvement it is advised + !! to analyze the integrand in order to + !! determine the integration difficulties. if + !! the position of a local difficulty can be + !! determined (e.g. singularity, + !! discontinuity within the interval) one + !! will probably gain from splitting up the + !! interval at this point and calling the + !! integrator on the subranges. if possible, + !! an appropriate special-purpose integrator + !! should be used, which is designed for + !! handling the type of difficulty involved. + !! * ier = 2 the occurrence of roundoff error is + !! detected, which prevents the requested + !! tolerance from being achieved. + !! the error may be under-estimated. + !! * ier = 3 extremely bad integrand behaviour occurs + !! at some points of the integration + !! interval. + !! * ier = 4 the algorithm does not converge. + !! roundoff error is detected in the + !! extrapolation table. + !! it is assumed that the requested tolerance + !! cannot be achieved, and that the returned + !! result is the best which can be obtained. + !! * ier = 5 the integral is probably divergent, or + !! slowly convergent. it must be noted that + !! divergence can occur with any other value + !! of ier. + !! * ier = 6 the input is invalid, because + !! `(epsabs<=0 and epsrel= 1 .and. Lenw >= Limit*4) then + + ! prepare call for dqagie. + l1 = Limit + 1 + l2 = Limit + l1 + l3 = Limit + l2 + + call dqagie(f, Bound, Inf, Epsabs, Epsrel, Limit, Result, Abserr, & + Neval, Ier, Work(1), Work(l1), Work(l2), Work(l3), Iwork, & + Last) + + ! call error handler if necessary. + lvl = 0 + end if + if (Ier == 6) lvl = 1 + if (Ier /= 0) call xerror('abnormal return from dqagi', Ier, lvl) + + end subroutine dqagi +!******************************************************************************** + +!******************************************************************************** +!> +! same as [[dqagi]] but provides more information and control +! +! the routine calculates an approximation result to a given +! integral with one of the following forms: +! +! * i = integral of `f` over `(bound, +infinity)` +! * i = integral of `f` over `(-infinity, bound)` +! * i = integral of `f` over `(-infinity, +infinity)` +! +! hopefully satisfying following claim for accuracy +! `abs(i-result)<=max(epsabs,epsrel*abs(i))`. +! +!### History +! * QUADPACK: date written 800101, revision date 830518 (yymmdd) + + subroutine dqagie(f, Bound, Inf, Epsabs, Epsrel, Limit, Result, Abserr, & + Neval, Ier, Alist, Blist, Rlist, Elist, Iord, Last) + implicit none + + procedure(func) :: f !! function subprogram defining the integrand function `f(x)`. + integer, intent(in) :: Limit !! gives an upper bound on the number of subintervals + !! in the partition of `(a,b)`, `limit>=1` + real(wp), intent(out) :: Abserr !! estimate of the modulus of the absolute error, + !! which should equal or exceed `abs(i-result)` + real(wp), intent(out) :: Alist(Limit) !! vector of dimension at least `limit`, the first + !! `last` elements of which are the left + !! end points of the subintervals in the partition + !! of the transformed integration range (0,1). + real(wp), intent(out) :: Blist(Limit) !! vector of dimension at least `limit`, the first + !! `last` elements of which are the right + !! end points of the subintervals in the partition + !! of the transformed integration range (0,1). + real(wp), intent(out) :: Elist(Limit) !! vector of dimension at least `limit`, the first + !! `last` elements of which are the moduli of the + !! absolute error estimates on the subintervals + real(wp), intent(out) :: Rlist(Limit) !! vector of dimension at least `limit`, the first + !! `last` elements of which are the integral + !! approximations on the subintervals + real(wp), intent(in) :: Epsabs !! absolute accuracy requested + real(wp), intent(in) :: Epsrel !! relative accuracy requested + !! if `epsabs<=0` + !! and `epsrel0 abnormal termination of the routine. the + !! estimates for result and error are less + !! reliable. it is assumed that the requested + !! accuracy has not been achieved. + !! + !! error messages: + !! + !! * ier = 1 maximum number of subdivisions allowed + !! has been achieved. one can allow more + !! subdivisions by increasing the value of + !! limit (and taking the according dimension + !! adjustments into account). however,if + !! this yields no improvement it is advised + !! to analyze the integrand in order to + !! determine the integration difficulties. + !! if the position of a local difficulty can + !! be determined (e.g. singularity, + !! discontinuity within the interval) one + !! will probably gain from splitting up the + !! interval at this point and calling the + !! integrator on the subranges. if possible, + !! an appropriate special-purpose integrator + !! should be used, which is designed for + !! handling the type of difficulty involved. + !! * ier = 2 the occurrence of roundoff error is + !! detected, which prevents the requested + !! tolerance from being achieved. + !! the error may be under-estimated. + !! * ier = 3 extremely bad integrand behaviour occurs + !! at some points of the integration + !! interval. + !! * ier = 4 the algorithm does not converge. + !! roundoff error is detected in the + !! extrapolation table. + !! it is assumed that the requested tolerance + !! cannot be achieved, and that the returned + !! result is the best which can be obtained. + !! * ier = 5 the integral is probably divergent, or + !! slowly convergent. it must be noted that + !! divergence can occur with any other value + !! of ier. + !! * ier = 6 the input is invalid, because + !! `(epsabs<=0 and epsrel errbnd) Ier = 2 + if (Limit == 1) Ier = 1 + if (Ier /= 0 .or. (Abserr <= errbnd .and. Abserr /= resabs) .or. & + Abserr == 0.0_wp) exit main + + ! initialization + + rlist2(1) = Result + errmax = Abserr + maxerr = 1 + area = Result + errsum = Abserr + Abserr = oflow + nrmax = 1 + nres = 0 + ktmin = 0 + numrl2 = 2 + extrap = .false. + noext = .false. + ierro = 0 + iroff1 = 0 + iroff2 = 0 + iroff3 = 0 + ksgn = -1 + if (dres >= (1.0_wp - 50.0_wp*epmach)*defabs) ksgn = 1 + + ! main do-loop + + loop: do Last = 2, Limit + + ! bisect the subinterval with nrmax-th largest error estimate. + + a1 = Alist(maxerr) + b1 = 0.5_wp*(Alist(maxerr) + Blist(maxerr)) + a2 = b1 + b2 = Blist(maxerr) + erlast = errmax + call dqk15i(f, boun, Inf, a1, b1, area1, error1, resabs, defab1) + call dqk15i(f, boun, Inf, a2, b2, area2, error2, resabs, defab2) + + ! improve previous approximations to integral + ! and error and test for accuracy. + + area12 = area1 + area2 + erro12 = error1 + error2 + errsum = errsum + erro12 - errmax + area = area + area12 - Rlist(maxerr) + if (defab1 /= error1 .and. defab2 /= error2) then + if (abs(Rlist(maxerr) - area12) <= 0.1e-4_wp*abs(area12) .and. & + erro12 >= 0.99_wp*errmax) then + if (extrap) iroff2 = iroff2 + 1 + if (.not. extrap) iroff1 = iroff1 + 1 + end if + if (Last > 10 .and. erro12 > errmax) iroff3 = iroff3 + 1 + end if + Rlist(maxerr) = area1 + Rlist(Last) = area2 + errbnd = max(Epsabs, Epsrel*abs(area)) + + ! test for roundoff error and eventually set error flag. + + if (iroff1 + iroff2 >= 10 .or. iroff3 >= 20) Ier = 2 + if (iroff2 >= 5) ierro = 3 + + ! set error flag in the case that the number of + ! subintervals equals limit. + + if (Last == Limit) Ier = 1 + + ! set error flag in the case of bad integrand behaviour + ! at some points of the integration range. + + if (max(abs(a1), abs(b2)) <= (1.0_wp + 100.0_wp*epmach) & + *(abs(a2) + 1000.0_wp*uflow)) Ier = 4 + + ! append the newly-created intervals to the list. + + if (error2 > error1) then + Alist(maxerr) = a2 + Alist(Last) = a1 + Blist(Last) = b1 + Rlist(maxerr) = area2 + Rlist(Last) = area1 + Elist(maxerr) = error2 + Elist(Last) = error1 + else + Alist(Last) = a2 + Blist(maxerr) = b1 + Blist(Last) = b2 + Elist(maxerr) = error1 + Elist(Last) = error2 + end if + + ! call subroutine dqpsrt to maintain the descending ordering + ! in the list of error estimates and select the subinterval + ! with nrmax-th largest error estimate (to be bisected next). + + call dqpsrt(Limit, Last, maxerr, errmax, Elist, Iord, nrmax) + if (errsum <= errbnd) then + ! compute global integral sum. + Result = sum(Rlist(1:Last)) + Abserr = errsum + exit main + end if + if (Ier /= 0) exit + if (Last == 2) then + small = 0.375_wp + erlarg = errsum + ertest = errbnd + rlist2(2) = area + elseif (.not. (noext)) then + erlarg = erlarg - erlast + if (abs(b1 - a1) > small) erlarg = erlarg + erro12 + if (.not. (extrap)) then + ! test whether the interval to be bisected next is the + ! smallest interval. + if (abs(Blist(maxerr) - Alist(maxerr)) > small) cycle loop + extrap = .true. + nrmax = 2 + end if + if (ierro /= 3 .and. erlarg > ertest) then + + ! the smallest interval has the largest error. + ! before bisecting decrease the sum of the errors over the + ! larger intervals (erlarg) and perform extrapolation. + + id = nrmax + jupbnd = Last + if (Last > (2 + Limit/2)) jupbnd = Limit + 3 - Last + do k = id, jupbnd + maxerr = Iord(nrmax) + errmax = Elist(maxerr) + if (abs(Blist(maxerr) - Alist(maxerr)) > small) cycle loop + nrmax = nrmax + 1 + end do + end if + + ! perform extrapolation. + + numrl2 = numrl2 + 1 + rlist2(numrl2) = area + call dqelg(numrl2, rlist2, reseps, abseps, res3la, nres) + ktmin = ktmin + 1 + if (ktmin > 5 .and. Abserr < 0.1e-02_wp*errsum) Ier = 5 + if (abseps < Abserr) then + ktmin = 0 + Abserr = abseps + Result = reseps + correc = erlarg + ertest = max(Epsabs, Epsrel*abs(reseps)) + if (Abserr <= ertest) exit + end if + + ! prepare bisection of the smallest interval. + + if (numrl2 == 1) noext = .true. + if (Ier == 5) exit + maxerr = Iord(1) + errmax = Elist(maxerr) + nrmax = 1 + extrap = .false. + small = small*0.5_wp + erlarg = errsum + end if + + end do loop + + ! set final result and error estimate. + + if (Abserr /= oflow) then + if ((Ier + ierro) /= 0) then + if (ierro == 3) Abserr = Abserr + correc + if (Ier == 0) Ier = 3 + if (Result == 0.0_wp .or. area == 0.0_wp) then + if (Abserr > errsum) then + ! compute global integral sum. + Result = sum(Rlist(1:Last)) + Abserr = errsum + exit main + end if + if (area == 0.0_wp) exit main + elseif (Abserr/abs(Result) > errsum/abs(area)) then + ! compute global integral sum. + Result = sum(Rlist(1:Last)) + Abserr = errsum + exit main + end if + end if + + ! test on divergence + + if (ksgn /= (-1) .or. max(abs(Result), abs(area)) > defabs*0.01_wp) then + if (0.01_wp > (Result/area) .or. & + (Result/area) > 100.0_wp .or. & + errsum > abs(area)) Ier = 6 + end if + + else + ! compute global integral sum. + Result = sum(Rlist(1:Last)) + Abserr = errsum + end if + + end block main + + Neval = 30*Last - 15 + if (Inf == 2) Neval = 2*Neval + if (Ier > 2) Ier = Ier - 1 + + end subroutine dqagie +!******************************************************************************** + +!******************************************************************************** +!> +! 1D globally adaptive integrator, singularities or discontinuities +! +! the routine calculates an approximation result to a given +! definite integral i = integral of `f` over `(a,b)`, +! hopefully satisfying following claim for accuracy +! break points of the integration interval, where local +! difficulties of the integrand may occur (e.g. +! singularities, discontinuities), are provided by the user. +! +!### History +! * QUADPACK: date written 800101, revision date 830518 (yymmdd) + + subroutine dqagp(f, a, b, Npts2, Points, Epsabs, Epsrel, Result, Abserr, & + Neval, Ier, Leniw, Lenw, Last, Iwork, Work) + implicit none + + procedure(func) :: f !! function subprogram defining the integrand function `f(x)`. + real(wp), intent(in) :: a !! lower limit of integration + real(wp), intent(in) :: b !! upper limit of integration + integer, intent(in) :: Npts2 !! number equal to two more than the number of + !! user-supplied break points within the integration + !! range, `npts>=2`. + !! if `npts2<2`, the routine will end with ier = 6. + real(wp), intent(in) :: Points(Npts2) !! vector of dimension npts2, the first `(npts2-2)` + !! elements of which are the user provided break + !! points. if these points do not constitute an + !! ascending sequence there will be an automatic + !! sorting. + real(wp), intent(in) :: Epsabs !! absolute accuracy requested + real(wp), intent(in) :: Epsrel !! relative accuracy requested + !! if `epsabs<=0` + !! and `epsrel0 abnormal termination of the routine. + !! the estimates for integral and error are + !! less reliable. it is assumed that the + !! requested accuracy has not been achieved. + !! + !! error messages: + !! + !! * ier = 1 maximum number of subdivisions allowed + !! has been achieved. one can allow more + !! subdivisions by increasing the value of + !! limit (and taking the according dimension + !! adjustments into account). however, if + !! this yields no improvement it is advised + !! to analyze the integrand in order to + !! determine the integration difficulties. if + !! the position of a local difficulty can be + !! determined (i.e. singularity, + !! discontinuity within the interval), it + !! should be supplied to the routine as an + !! element of the vector points. if necessary + !! an appropriate special-purpose integrator + !! must be used, which is designed for + !! handling the type of difficulty involved. + !! * ier = 2 the occurrence of roundoff error is + !! detected, which prevents the requested + !! tolerance from being achieved. + !! the error may be under-estimated. + !! * ier = 3 extremely bad integrand behaviour occurs + !! at some points of the integration + !! interval. + !! * ier = 4 the algorithm does not converge. + !! roundoff error is detected in the + !! extrapolation table. + !! it is presumed that the requested + !! tolerance cannot be achieved, and that + !! the returned result is the best which + !! can be obtained. + !! * ier = 5 the integral is probably divergent, or + !! slowly convergent. it must be noted that + !! divergence can occur with any other value + !! of ier>0. + !! * ier = 6 the input is invalid because + !! `npts2<2` or + !! break points are specified outside + !! the integration range or + !! `(epsabs<=0 and epsrel=(3*npts2-2)`. + !! if `leniw<(3*npts2-2)`, the routine will end with + !! ier = 6. + integer, intent(in) :: Lenw !! dimensioning parameter for `work`. + !! `lenw` must be at least `leniw*2-npts2`. + !! if `lenw= (3*Npts2 - 2) .and. Lenw >= (Leniw*2 - Npts2) .and. Npts2 >= 2) then + + ! prepare call for dqagpe. + limit = (Leniw - Npts2)/2 + l1 = limit + 1 + l2 = limit + l1 + l3 = limit + l2 + l4 = limit + l3 + + call dqagpe(f, a, b, Npts2, Points, Epsabs, Epsrel, limit, Result, & + Abserr, Neval, Ier, Work(1), Work(l1), Work(l2), Work(l3), & + Work(l4), Iwork(1), Iwork(l1), Iwork(l2), Last) + + ! call error handler if necessary. + lvl = 0 + end if + if (Ier == 6) lvl = 1 + if (Ier /= 0) call xerror('abnormal return from dqagp', Ier, lvl) + + end subroutine dqagp +!******************************************************************************** + +!******************************************************************************** +!> +! same as [[dqagp]] but provides more information and control +! +! the routine calculates an approximation result to a given +! definite integral i = integral of `f` over `(a,b)`, hopefully +! satisfying following claim for accuracy `abs(i-result)<=max(epsabs,epsrel*abs(i))`. +! break points of the integration interval, where local difficulties +! of the integrand may occur (e.g. singularities, discontinuities),provided by user. +! +!### History +! * QUADPACK: date written 800101, revision date 830518 (yymmdd) + + subroutine dqagpe(f, a, b, Npts2, Points, Epsabs, Epsrel, Limit, Result, & + Abserr, Neval, Ier, Alist, Blist, Rlist, Elist, Pts, & + Iord, Level, Ndin, Last) + implicit none + + procedure(func) :: f + real(wp), intent(out) :: Abserr !! estimate of the modulus of the absolute error, + !! which should equal or exceed `abs(i-result)` + real(wp), intent(out) :: Alist(Limit) !! vector of dimension at least `limit`, the first + !! `last` elements of which are the left end points + !! of the subintervals in the partition of the given + !! integration range (a,b) + real(wp), intent(out) :: Blist(Limit) !! vector of dimension at least `limit`, the first + !! `last` elements of which are the right end points + !! of the subintervals in the partition of the given + !! integration range (a,b) + real(wp), intent(out) :: Elist(Limit) !! vector of dimension at least `limit`, the first + !! `last` elements of which are the moduli of the + !! absolute error estimates on the subintervals + real(wp), intent(out) :: Rlist(Limit) !! vector of dimension at least `limit`, the first + !! `last` elements of which are the integral + !! approximations on the subintervals + real(wp), intent(in) :: Epsabs !! absolute accuracy requested + real(wp), intent(in) :: Epsrel !! relative accuracy requested + !! if `epsabs<=0` + !! and `epsrel0 abnormal termination of the routine. + !! the estimates for integral and error are + !! less reliable. it is assumed that the + !! requested accuracy has not been achieved. + !! + !! error messages: + !! + !! * ier = 1 maximum number of subdivisions allowed + !! has been achieved. one can allow more + !! subdivisions by increasing the value of + !! limit (and taking the according dimension + !! adjustments into account). however, if + !! this yields no improvement it is advised + !! to analyze the integrand in order to + !! determine the integration difficulties. if + !! the position of a local difficulty can be + !! determined (i.e. singularity, + !! discontinuity within the interval), it + !! should be supplied to the routine as an + !! element of the vector points. if necessary + !! an appropriate special-purpose integrator + !! must be used, which is designed for + !! handling the type of difficulty involved. + !! * ier = 2 the occurrence of roundoff error is + !! detected, which prevents the requested + !! tolerance from being achieved. + !! the error may be under-estimated. + !! * ier = 3 extremely bad integrand behaviour occurs + !! at some points of the integration + !! interval. + !! * ier = 4 the algorithm does not converge. + !! roundoff error is detected in the + !! extrapolation table. it is presumed that + !! the requested tolerance cannot be + !! achieved, and that the returned result is + !! the best which can be obtained. + !! * ier = 5 the integral is probably divergent, or + !! slowly convergent. it must be noted that + !! divergence can occur with any other value + !! of ier>0. + !! * ier = 6 the input is invalid because + !! `npts2<2` or + !! break points are specified outside + !! the integration range or + !! `(epsabs<=0 and epsrel=npts2` + !! if `limit=2`. + !! if `npts2<2`, the routine will end with ier = 6. + integer, intent(out) :: Ndin(Npts2) !! vector of dimension at least npts2, after first + !! integration over the intervals `(pts(i)),pts(i+1)`, + !! `i = 0,1, ..., npts2-2`, the error estimates over + !! some of the intervals may have been increased + !! artificially, in order to put their subdivision + !! forward. if this happens for the subinterval + !! numbered `k`, `ndin(k)` is put to 1, otherwise + !! `ndin(k) = 0`. + integer, intent(out) :: Neval !! number of integrand evaluations + integer, intent(out) :: Level(Limit) !! vector of dimension at least `limit`, containing the + !! subdivision levels of the subinterval, i.e. if + !! `(aa,bb)` is a subinterval of `(p1,p2)` where `p1` as + !! well as `p2` is a user-provided break point or + !! integration limit, then `(aa,bb)` has level `l` if + !! `abs(bb-aa) = abs(p2-p1)*2**(-l)`. + + real(wp) :: a, abseps, b, correc, defabs, & + dres, ertest, resa, reseps, Result, & + res3la(3), sign, temp, resabs + integer :: i, id, ierro, ind1, ind2, ip1, iroff1, & + iroff2, iroff3, j, jlow, jupbnd, k, ksgn, ktmin, & + levcur, levmax, nint, nintp1, npts, nrmax + real(wp) :: area1, a1, b1, defab1, error1 !! variable for the left subinterval + real(wp) :: area2, a2, b2, defab2, error2 !! variable for the right subinterval + real(wp) :: area12 !! `area1 + area2` + real(wp) :: erro12 !! `error1 + error2` + real(wp) :: rlist2(limexp + 2) !! array of dimension at least `limexp+2` + !! containing the part of the epsilon table which + !! is still needed for further computations. + real(wp) :: erlast !! error on the interval currently subdivided + !! (before that subdivision has taken place) + real(wp) :: errsum !! sum of the errors over the subintervals + real(wp) :: errbnd !! requested accuracy `max(epsabs,epsrel*abs(result))` + real(wp) :: area !! sum of the integrals over the subintervals + real(wp) :: erlarg !! sum of the errors over the intervals larger + !! than the smallest interval considered up to now + real(wp) :: errmax !! `elist(maxerr)` + logical :: extrap !! logical variable denoting that the routine + !! is attempting to perform extrapolation. i.e. + !! before subdividing the smallest interval we + !! try to decrease the value of `erlarg`. + logical :: noext !! logical variable denoting that extrapolation is + !! no longer allowed (true-value) + integer :: maxerr !! pointer to the interval with largest error estimate + integer :: nres !! number of calls to the extrapolation routine + integer :: numrl2 !! number of elements in `rlist2`. if an appropriate + !! approximation to the compounded integral has + !! been obtained, it is put in `rlist2(numrl2)` after + !! `numrl2` has been increased by one. + + ! test on validity of parameters + + Ier = 0 + Neval = 0 + Last = 0 + Result = 0.0_wp + Abserr = 0.0_wp + Alist(1) = a + Blist(1) = b + Rlist(1) = 0.0_wp + Elist(1) = 0.0_wp + Iord(1) = 0 + Level(1) = 0 + npts = Npts2 - 2 + if (Npts2 < 2 .or. Limit <= npts .or. & + (Epsabs <= 0.0_wp .and. Epsrel < max(50.0_wp*epmach, 0.5e-28_wp))) & + Ier = 6 + if (Ier == 6) return + + ! if any break points are provided, sort them into an + ! ascending sequence. + + sign = 1.0_wp + if (a > b) sign = -1.0_wp + Pts(1) = min(a, b) + if (npts /= 0) then + do i = 1, npts + Pts(i + 1) = Points(i) + end do + end if + Pts(npts + 2) = max(a, b) + nint = npts + 1 + a1 = Pts(1) + if (npts /= 0) then + nintp1 = nint + 1 + do i = 1, nint + ip1 = i + 1 + do j = ip1, nintp1 + if (Pts(i) > Pts(j)) then + temp = Pts(i) + Pts(i) = Pts(j) + Pts(j) = temp + end if + end do + end do + if (Pts(1) /= min(a, b) .or. Pts(nintp1) /= max(a, b)) Ier = 6 + if (Ier == 6) return + end if + + main : block + + ! compute first integral and error approximations. + + resabs = 0.0_wp + do i = 1, nint + b1 = Pts(i + 1) + call dqk21(f, a1, b1, area1, error1, defabs, resa) + Abserr = Abserr + error1 + Result = Result + area1 + Ndin(i) = 0 + if (error1 == resa .and. error1 /= 0.0_wp) Ndin(i) = 1 + resabs = resabs + defabs + Level(i) = 0 + Elist(i) = error1 + Alist(i) = a1 + Blist(i) = b1 + Rlist(i) = area1 + Iord(i) = i + a1 = b1 + end do + errsum = 0.0_wp + do i = 1, nint + if (Ndin(i) == 1) Elist(i) = Abserr + errsum = errsum + Elist(i) + end do + + ! test on accuracy. + + Last = nint + Neval = 21*nint + dres = abs(Result) + errbnd = max(Epsabs, Epsrel*dres) + if (Abserr <= 100.0_wp*epmach*resabs .and. Abserr > errbnd) Ier = 2 + if (nint /= 1) then + do i = 1, npts + jlow = i + 1 + ind1 = Iord(i) + do j = jlow, nint + ind2 = Iord(j) + if (Elist(ind1) <= Elist(ind2)) then + ind1 = ind2 + k = j + end if + end do + if (ind1 /= Iord(i)) then + Iord(k) = Iord(i) + Iord(i) = ind1 + end if + end do + if (Limit < Npts2) Ier = 1 + end if + if (Ier /= 0 .or. Abserr <= errbnd) exit main + + ! initialization + + rlist2(1) = Result + maxerr = Iord(1) + errmax = Elist(maxerr) + area = Result + nrmax = 1 + nres = 0 + numrl2 = 1 + ktmin = 0 + extrap = .false. + noext = .false. + erlarg = errsum + ertest = errbnd + levmax = 1 + iroff1 = 0 + iroff2 = 0 + iroff3 = 0 + ierro = 0 + Abserr = oflow + ksgn = -1 + if (dres >= (1.0_wp - 50.0_wp*epmach)*resabs) ksgn = 1 + + ! main do-loop + + loop: do Last = Npts2, Limit + + ! bisect the subinterval with the nrmax-th largest error + ! estimate. + + levcur = Level(maxerr) + 1 + a1 = Alist(maxerr) + b1 = 0.5_wp*(Alist(maxerr) + Blist(maxerr)) + a2 = b1 + b2 = Blist(maxerr) + erlast = errmax + call dqk21(f, a1, b1, area1, error1, resa, defab1) + call dqk21(f, a2, b2, area2, error2, resa, defab2) + + ! improve previous approximations to integral + ! and error and test for accuracy. + + Neval = Neval + 42 + area12 = area1 + area2 + erro12 = error1 + error2 + errsum = errsum + erro12 - errmax + area = area + area12 - Rlist(maxerr) + if (defab1 /= error1 .and. defab2 /= error2) then + if (abs(Rlist(maxerr) - area12) <= 0.1e-4_wp*abs(area12) .and. & + erro12 >= 0.99_wp*errmax) then + if (extrap) iroff2 = iroff2 + 1 + if (.not. extrap) iroff1 = iroff1 + 1 + end if + if (Last > 10 .and. erro12 > errmax) iroff3 = iroff3 + 1 + end if + Level(maxerr) = levcur + Level(Last) = levcur + Rlist(maxerr) = area1 + Rlist(Last) = area2 + errbnd = max(Epsabs, Epsrel*abs(area)) + + ! test for roundoff error and eventually set error flag. + + if (iroff1 + iroff2 >= 10 .or. iroff3 >= 20) Ier = 2 + if (iroff2 >= 5) ierro = 3 + + ! set error flag in the case that the number of + ! subintervals equals limit. + + if (Last == Limit) Ier = 1 + + ! set error flag in the case of bad integrand behaviour + ! at a point of the integration range + + if (max(abs(a1), abs(b2)) <= (1.0_wp + 100.0_wp*epmach) & + *(abs(a2) + 1000.0_wp*uflow)) Ier = 4 + + ! append the newly-created intervals to the list. + + if (error2 > error1) then + Alist(maxerr) = a2 + Alist(Last) = a1 + Blist(Last) = b1 + Rlist(maxerr) = area2 + Rlist(Last) = area1 + Elist(maxerr) = error2 + Elist(Last) = error1 + else + Alist(Last) = a2 + Blist(maxerr) = b1 + Blist(Last) = b2 + Elist(maxerr) = error1 + Elist(Last) = error2 + end if + + ! call subroutine dqpsrt to maintain the descending ordering + ! in the list of error estimates and select the subinterval + ! with nrmax-th largest error estimate (to be bisected next). + + call dqpsrt(Limit, Last, maxerr, errmax, Elist, Iord, nrmax) + ! ***jump out of do-loop + if (errsum <= errbnd) then + ! compute global integral sum. + Result = sum(Rlist(1:Last)) + Abserr = errsum + exit main + end if + ! ***jump out of do-loop + if (Ier /= 0) exit loop + if (.not. (noext)) then + erlarg = erlarg - erlast + if (levcur + 1 <= levmax) erlarg = erlarg + erro12 + if (.not. (extrap)) then + ! test whether the interval to be bisected next is the + ! smallest interval. + if (Level(maxerr) + 1 <= levmax) cycle loop + extrap = .true. + nrmax = 2 + end if + if (ierro /= 3 .and. erlarg > ertest) then + ! the smallest interval has the largest error. + ! before bisecting decrease the sum of the errors over + ! the larger intervals (erlarg) and perform extrapolation. + id = nrmax + jupbnd = Last + if (Last > (2 + Limit/2)) jupbnd = Limit + 3 - Last + do k = id, jupbnd + maxerr = Iord(nrmax) + errmax = Elist(maxerr) + ! ***jump out of do-loop + if (Level(maxerr) + 1 <= levmax) cycle loop + nrmax = nrmax + 1 + end do + end if + + ! perform extrapolation. + + numrl2 = numrl2 + 1 + rlist2(numrl2) = area + if (numrl2 > 2) then + call dqelg(numrl2, rlist2, reseps, abseps, res3la, nres) + ktmin = ktmin + 1 + if (ktmin > 5 .and. Abserr < 0.1e-02_wp*errsum) Ier = 5 + if (abseps < Abserr) then + ktmin = 0 + Abserr = abseps + Result = reseps + correc = erlarg + ertest = max(Epsabs, Epsrel*abs(reseps)) + ! ***jump out of do-loop + if (Abserr < ertest) exit loop + end if + ! prepare bisection of the smallest interval. + if (numrl2 == 1) noext = .true. + if (Ier >= 5) exit loop + end if + maxerr = Iord(1) + errmax = Elist(maxerr) + nrmax = 1 + extrap = .false. + levmax = levmax + 1 + erlarg = errsum + end if + + end do loop + + ! set the final result. + + if (Abserr /= oflow) then + if ((Ier + ierro) /= 0) then + if (ierro == 3) Abserr = Abserr + correc + if (Ier == 0) Ier = 3 + if (Result == 0.0_wp .or. area == 0.0_wp) then + if (Abserr > errsum) then + ! compute global integral sum. + Result = sum(Rlist(1:Last)) + Abserr = errsum + exit main + end if + if (area == 0.0_wp) exit main + elseif (Abserr/abs(Result) > errsum/abs(area)) then + ! compute global integral sum. + Result = sum(Rlist(1:Last)) + Abserr = errsum + exit main + end if + end if + + ! test on divergence. + + if (ksgn /= (-1) .or. max(abs(Result), abs(area)) & + > resabs*0.01_wp) then + if (0.01_wp > (Result/area) .or. (Result/area) > 100.0_wp .or. & + errsum > abs(area)) Ier = 6 + end if + + else + ! compute global integral sum. + Result = sum(Rlist(1:Last)) + Abserr = errsum + end if + + end block main + + if (Ier > 2) Ier = Ier - 1 + Result = Result*sign + + end subroutine dqagpe +!******************************************************************************** + +!******************************************************************************** +!> +! 1D globally adaptive integrator using interval subdivision and extrapolation +! +! the routine calculates an approximation result to a given +! definite integral i = integral of `f` over `(a,b)`, +! hopefully satisfying following claim for accuracy +! `abs(i-result)<=max(epsabs,epsrel*abs(i))`. +! +!### History +! * QUADPACK: date written 800101, revision date 830518 (yymmdd) + + subroutine dqags(f, a, b, Epsabs, Epsrel, Result, Abserr, Neval, Ier, & + Limit, Lenw, Last, Iwork, Work) + implicit none + + procedure(func) :: f !! function subprogram defining the integrand + !! function `f(x)`. + real(wp), intent(in) :: a !! lower limit of integration + real(wp), intent(in) :: b !! upper limit of integration + real(wp), intent(in) :: Epsabs !! absolute accuracy requested + real(wp), intent(in) :: Epsrel !! relative accuracy requested + !! if `epsabs<=0` + !! and `epsrel0 abnormal termination of the routine + !! the estimates for integral and error are + !! less reliable. it is assumed that the + !! requested accuracy has not been achieved. + !! + !! error messages: + !! + !! * ier = 1 maximum number of subdivisions allowed + !! has been achieved. one can allow more sub- + !! divisions by increasing the value of limit + !! (and taking the according dimension + !! adjustments into account). however, if + !! this yields no improvement it is advised + !! to analyze the integrand in order to + !! determine the integration difficulties. if + !! the position of a local difficulty can be + !! determined (e.g. singularity, + !! discontinuity within the interval) one + !! will probably gain from splitting up the + !! interval at this point and calling the + !! integrator on the subranges. if possible, + !! an appropriate special-purpose integrator + !! should be used, which is designed for + !! handling the type of difficulty involved. + !! * ier = 2 the occurrence of roundoff error is detected, + !! which prevents the requested + !! tolerance from being achieved. + !! the error may be under-estimated. + !! * ier = 3 extremely bad integrand behaviour + !! occurs at some points of the integration + !! interval. + !! * ier = 4 the algorithm does not converge. + !! roundoff error is detected in the + !! extrapolation table. it is presumed that + !! the requested tolerance cannot be + !! achieved, and that the returned result is + !! the best which can be obtained. + !! * ier = 5 the integral is probably divergent, or + !! slowly convergent. it must be noted that + !! divergence can occur with any other value + !! of ier. + !! * ier = 6 the input is invalid, because + !! `(epsabs<=0` and + !! `epsrel=1`. + !! if `limit<1`, the routine will end with ier = 6. + integer, intent(in) :: Lenw !! dimensioning parameter for `work`. + !! `lenw` must be at least `limit*4`. + !! if `lenw= 1 .and. Lenw >= Limit*4) then + + ! prepare call for dqagse. + l1 = Limit + 1 + l2 = Limit + l1 + l3 = Limit + l2 + + call dqagse(f, a, b, Epsabs, Epsrel, Limit, Result, Abserr, Neval, Ier, & + Work(1), Work(l1), Work(l2), Work(l3), Iwork, Last) + + ! call error handler if necessary. + lvl = 0 + end if + if (Ier == 6) lvl = 1 + if (Ier /= 0) call xerror('abnormal return from dqags', Ier, lvl) + + end subroutine dqags +!******************************************************************************** + +!******************************************************************************** +!> +! same as [[dqags]] but provides more information and control +! +! the routine calculates an approximation result to a given +! definite integral i = integral of `f` over `(a,b)`, +! hopefully satisfying following claim for accuracy +! `abs(i-result)<=max(epsabs,epsrel*abs(i))`. +! +!### History +! * QUADPACK: date written 800101, revision date 830518 (yymmdd) + + subroutine dqagse(f, a, b, Epsabs, Epsrel, Limit, Result, Abserr, Neval, & + Ier, Alist, Blist, Rlist, Elist, Iord, Last) + implicit none + + procedure(func) :: f !! function subprogram defining the integrand + !! function `f(x)`. + real(wp), intent(in) :: a !! lower limit of integration + real(wp), intent(in) :: b !! upper limit of integration + real(wp), intent(in) :: Epsabs !! absolute accuracy requested + real(wp), intent(in) :: Epsrel !! relative accuracy requested + !! if `epsabs<=0` + !! and `epsrel0 abnormal termination of the routine + !! the estimates for integral and error are + !! less reliable. it is assumed that the + !! requested accuracy has not been achieved. + !! + !! error messages: + !! * ier = 1 maximum number of subdivisions allowed + !! has been achieved. one can allow more sub- + !! divisions by increasing the value of limit + !! (and taking the according dimension + !! adjustments into account). however, if + !! this yields no improvement it is advised + !! to analyze the integrand in order to + !! determine the integration difficulties. if + !! the position of a local difficulty can be + !! determined (e.g. singularity, + !! discontinuity within the interval) one + !! will probably gain from splitting up the + !! interval at this point and calling the + !! integrator on the subranges. if possible, + !! an appropriate special-purpose integrator + !! should be used, which is designed for + !! handling the type of difficulty involved. + !! * ier = 2 the occurrence of roundoff error is + !! detected, which prevents the requested + !! tolerance from being achieved. + !! the error may be under-estimated. + !! * ier = 3 extremely bad integrand behaviour + !! occurs at some points of the integration + !! interval. + !! * ier = 4 the algorithm does not converge. + !! roundoff error is detected in the + !! extrapolation table. + !! it is presumed that the requested + !! tolerance cannot be achieved, and that the + !! returned result is the best which can be + !! obtained. + !! * ier = 5 the integral is probably divergent, or + !! slowly convergent. it must be noted that + !! divergence can occur with any other value + !! of ier. + !! * ier = 6 the input is invalid, because + !! `epsabs<=0` and + !! `epsrel errbnd) & + Ier = 2 + if (Limit == 1) Ier = 1 + if (Ier /= 0 .or. (Abserr <= errbnd .and. Abserr /= resabs) .or. & + Abserr == 0.0_wp) then + Neval = 42*Last - 21 + return + end if + + ! initialization + + rlist2(1) = Result + errmax = Abserr + maxerr = 1 + area = Result + errsum = Abserr + Abserr = oflow + nrmax = 1 + nres = 0 + numrl2 = 2 + ktmin = 0 + extrap = .false. + noext = .false. + iroff1 = 0 + iroff2 = 0 + iroff3 = 0 + ksgn = -1 + if (dres >= (1.0_wp - 50.0_wp*epmach)*defabs) ksgn = 1 + + ! main do-loop + + loop: do Last = 2, Limit + + ! bisect the subinterval with the nrmax-th largest error + ! estimate. + + a1 = Alist(maxerr) + b1 = 0.5_wp*(Alist(maxerr) + Blist(maxerr)) + a2 = b1 + b2 = Blist(maxerr) + erlast = errmax + call dqk21(f, a1, b1, area1, error1, resabs, defab1) + call dqk21(f, a2, b2, area2, error2, resabs, defab2) + + ! improve previous approximations to integral + ! and error and test for accuracy. + + area12 = area1 + area2 + erro12 = error1 + error2 + errsum = errsum + erro12 - errmax + area = area + area12 - Rlist(maxerr) + if (defab1 /= error1 .and. defab2 /= error2) then + if (abs(Rlist(maxerr) - area12) <= 0.1e-4_wp*abs(area12) & + .and. erro12 >= 0.99_wp*errmax) then + if (extrap) iroff2 = iroff2 + 1 + if (.not. extrap) iroff1 = iroff1 + 1 + end if + if (Last > 10 .and. erro12 > errmax) iroff3 = iroff3 + 1 + end if + Rlist(maxerr) = area1 + Rlist(Last) = area2 + errbnd = max(Epsabs, Epsrel*abs(area)) + + ! test for roundoff error and eventually set error flag. + + if (iroff1 + iroff2 >= 10 .or. iroff3 >= 20) Ier = 2 + if (iroff2 >= 5) ierro = 3 + + ! set error flag in the case that the number of subintervals + ! equals limit. + + if (Last == Limit) Ier = 1 + + ! set error flag in the case of bad integrand behaviour + ! at a point of the integration range. + + if (max(abs(a1), abs(b2)) <= (1.0_wp + 100.0_wp*epmach) & + *(abs(a2) + 1000.0_wp*uflow)) Ier = 4 + + ! append the newly-created intervals to the list. + + if (error2 > error1) then + Alist(maxerr) = a2 + Alist(Last) = a1 + Blist(Last) = b1 + Rlist(maxerr) = area2 + Rlist(Last) = area1 + Elist(maxerr) = error2 + Elist(Last) = error1 + else + Alist(Last) = a2 + Blist(maxerr) = b1 + Blist(Last) = b2 + Elist(maxerr) = error1 + Elist(Last) = error2 + end if + + ! call subroutine dqpsrt to maintain the descending ordering + ! in the list of error estimates and select the subinterval + ! with nrmax-th largest error estimate (to be bisected next). + + call dqpsrt(Limit, Last, maxerr, errmax, Elist, Iord, nrmax) + ! ***jump out of do-loop + if (errsum <= errbnd) exit main + ! ***jump out of do-loop + if (Ier /= 0) exit loop + if (Last == 2) then + small = abs(b - a)*0.375_wp + erlarg = errsum + ertest = errbnd + rlist2(2) = area + elseif (.not. (noext)) then + erlarg = erlarg - erlast + if (abs(b1 - a1) > small) erlarg = erlarg + erro12 + if (.not. (extrap)) then + ! test whether the interval to be bisected next is the + ! smallest interval. + if (abs(Blist(maxerr) - Alist(maxerr)) > small) cycle loop + extrap = .true. + nrmax = 2 + end if + if (ierro /= 3 .and. erlarg > ertest) then + ! the smallest interval has the largest error. + ! before bisecting decrease the sum of the errors over the + ! larger intervals (erlarg) and perform extrapolation. + id = nrmax + jupbnd = Last + if (Last > (2 + Limit/2)) jupbnd = Limit + 3 - Last + do k = id, jupbnd + maxerr = Iord(nrmax) + errmax = Elist(maxerr) + ! ***jump out of do-loop + if (abs(Blist(maxerr) - Alist(maxerr)) > small) cycle loop + nrmax = nrmax + 1 + end do + end if + + ! perform extrapolation. + + numrl2 = numrl2 + 1 + rlist2(numrl2) = area + call dqelg(numrl2, rlist2, reseps, abseps, res3la, nres) + ktmin = ktmin + 1 + if (ktmin > 5 .and. Abserr < 0.1e-02_wp*errsum) Ier = 5 + if (abseps < Abserr) then + ktmin = 0 + Abserr = abseps + Result = reseps + correc = erlarg + ertest = max(Epsabs, Epsrel*abs(reseps)) + ! ***jump out of do-loop + if (Abserr <= ertest) exit loop + end if + + ! prepare bisection of the smallest interval. + + if (numrl2 == 1) noext = .true. + if (Ier == 5) exit loop + maxerr = Iord(1) + errmax = Elist(maxerr) + nrmax = 1 + extrap = .false. + small = small*0.5_wp + erlarg = errsum + end if + end do loop + + ! set final result and error estimate. + + if (Abserr /= oflow) then + if (Ier + ierro /= 0) then + if (ierro == 3) Abserr = Abserr + correc + if (Ier == 0) Ier = 3 + if (Result == 0.0_wp .or. area == 0.0_wp) then + if (Abserr > errsum) exit main + if (area == 0.0_wp) then + if (Ier > 2) Ier = Ier - 1 + Neval = 42*Last - 21 + return + end if + elseif (Abserr/abs(Result) > errsum/abs(area)) then + exit main + end if + end if + + ! test on divergence. + + if (ksgn /= (-1) .or. max(abs(Result), abs(area)) & + > defabs*0.01_wp) then + if (0.01_wp > (Result/area) .or. (Result/area) & + > 100.0_wp .or. errsum > abs(area)) Ier = 6 + end if + if (Ier > 2) Ier = Ier - 1 + Neval = 42*Last - 21 + return + end if + + end block main + + ! compute global integral sum. + + Result = sum(Rlist(1:Last)) + Abserr = errsum + if (Ier > 2) Ier = Ier - 1 + Neval = 42*Last - 21 + + end subroutine dqagse +!******************************************************************************** + +!******************************************************************************** +!> +! compute Cauchy principal value of `f(x)/(x-c)` over a finite interval +! +! the routine calculates an approximation result to a +! cauchy principal value i = integral of `f*w` over `(a,b)` +! `(w(x) = 1/((x-c), c/=a, c/=b)`, hopefully satisfying +! following claim for accuracy +! `abs(i-result)<=max(epsabe,epsrel*abs(i))`. +! +!### History +! * QUADPACK: date written 800101, revision date 830518 (yymmdd) + + subroutine dqawc(f, a, b, c, Epsabs, Epsrel, Result, Abserr, Neval, Ier, & + Limit, Lenw, Last, Iwork, Work) + implicit none + + procedure(func) :: f !! function subprogram defining the integrand function `f(x)`. + real(wp), intent(in) :: a !! under limit of integration + real(wp), intent(in) :: b !! upper limit of integration + real(wp), intent(in) :: c !! parameter in the weight function, `c/=a`, `c/=b`. + !! if `c = a` or `c = b`, the routine will end with + !! ier = 6 . + real(wp), intent(in) :: Epsabs !! absolute accuracy requested + real(wp), intent(in) :: Epsrel !! relative accuracy requested + !! if `epsabs<=0` + !! and `epsrel0 abnormal termination of the routine + !! the estimates for integral and error are + !! less reliable. it is assumed that the + !! requested accuracy has not been achieved. + !! + !! error messages: + !! * ier = 1 maximum number of subdivisions allowed + !! has been achieved. one can allow more sub- + !! divisions by increasing the value of limit + !! (and taking the according dimension + !! adjustments into account). however, if + !! this yields no improvement it is advised + !! to analyze the integrand in order to + !! determine the integration difficulties. + !! if the position of a local difficulty + !! can be determined (e.g. singularity, + !! discontinuity within the interval) one + !! will probably gain from splitting up the + !! interval at this point and calling + !! appropriate integrators on the subranges. + !! * ier = 2 the occurrence of roundoff error is + !! detected, which prevents the requested + !! tolerance from being achieved. + !! * ier = 3 extremely bad integrand behaviour occurs + !! at some points of the integration + !! interval. + !! * ier = 6 the input is invalid, because + !! `c = a` or `c = b` or + !! (`epsabs<=0` and `epsrel=1`. + !! if `limit<1`, the routine will end with ier = 6. + integer, intent(in) :: Lenw !! dimensioning parameter for `work`. + !! `lenw` must be at least `limit*4`. + !! if `lenw= 1 .and. Lenw >= Limit*4) then + + ! prepare call for dqawce. + l1 = Limit + 1 + l2 = Limit + l1 + l3 = Limit + l2 + call dqawce(f, a, b, c, Epsabs, Epsrel, Limit, Result, Abserr, Neval, & + Ier, Work(1), Work(l1), Work(l2), Work(l3), Iwork, Last) + + ! call error handler if necessary. + lvl = 0 + end if + if (Ier == 6) lvl = 1 + if (Ier /= 0) call xerror('abnormal return from dqawc', Ier, lvl) + + end subroutine dqawc +!******************************************************************************** + +!******************************************************************************** +!> +! same as [[dqawc]] but provides more information and control +! +! the routine calculates an approximation result to a +! cauchy principal value i = integral of `f*w` over `(a,b)` +! `(w(x) = 1/(x-c), (c/=a, c/=b)`, hopefully satisfying +! following claim for accuracy +! `abs(i-result)<=max(epsabs,epsrel*abs(i))` +! +!### History +! * QUADPACK: date written 800101, revision date 830518 (yymmdd) + + subroutine dqawce(f, a, b, c, Epsabs, Epsrel, Limit, Result, Abserr, Neval, & + Ier, Alist, Blist, Rlist, Elist, Iord, Last) + implicit none + + procedure(func) :: f !! function subprogram defining the integrand function `f(x)`. + real(wp), intent(in) :: a !! lower limit of integration + real(wp), intent(in) :: b !! upper limit of integration + real(wp), intent(in) :: Epsabs !! absolute accuracy requested + real(wp), intent(in) :: Epsrel !! relative accuracy requested + !! if `epsabs<=0` + !! and `epsrel=1` + real(wp), intent(out) :: Result !! approximation to the integral + real(wp), intent(out) :: Abserr !! estimate of the modulus of the absolute error, + !! which should equal or exceed `abs(i-result)` + integer, intent(out) :: Neval !! number of integrand evaluations + integer, intent(out) :: Ier !! * ier = 0 normal and reliable termination of the + !! routine. it is assumed that the requested + !! accuracy has been achieved. + !! * ier>0 abnormal termination of the routine + !! the estimates for integral and error are + !! less reliable. it is assumed that the + !! requested accuracy has not been achieved. + !! + !! error messages: + !! + !! * ier = 1 maximum number of subdivisions allowed + !! has been achieved. one can allow more sub- + !! divisions by increasing the value of + !! limit. however, if this yields no + !! improvement it is advised to analyze the + !! the integrand, in order to determine the + !! the integration difficulties. if the + !! position of a local difficulty can be + !! determined (e.g. singularity, + !! discontinuity within the interval) one + !! will probably gain from splitting up the + !! interval at this point and calling + !! appropriate integrators on the subranges. + !! * ier = 2 the occurrence of roundoff error is + !! detected, which prevents the requested + !! tolerance from being achieved. + !! * ier = 3 extremely bad integrand behaviour + !! occurs at some interior points of + !! the integration interval. + !! * ier = 6 the input is invalid, because + !! `c = a` or `c = b` or + !! `(epsabs<=0 and epsrel b) then + aa = b + bb = a + end if + Ier = 0 + krule = 1 + call dqc25c(f, aa, bb, c, Result, Abserr, krule, Neval) + Last = 1 + Rlist(1) = Result + Elist(1) = Abserr + Iord(1) = 1 + Alist(1) = a + Blist(1) = b + + ! test on accuracy + + errbnd = max(Epsabs, Epsrel*abs(Result)) + if (Limit == 1) Ier = 1 + if (Abserr >= min(0.01_wp*abs(Result), errbnd) .and. Ier /= 1) then + + ! initialization + + Alist(1) = aa + Blist(1) = bb + Rlist(1) = Result + errmax = Abserr + maxerr = 1 + area = Result + errsum = Abserr + nrmax = 1 + iroff1 = 0 + iroff2 = 0 + + ! main do-loop + + do Last = 2, Limit + + ! bisect the subinterval with nrmax-th largest + ! error estimate. + + a1 = Alist(maxerr) + b1 = 0.5_wp*(Alist(maxerr) + Blist(maxerr)) + b2 = Blist(maxerr) + if (c <= b1 .and. c > a1) b1 = 0.5_wp*(c + b2) + if (c > b1 .and. c < b2) b1 = 0.5_wp*(a1 + c) + a2 = b1 + krule = 2 + call dqc25c(f, a1, b1, c, area1, error1, krule, nev) + Neval = Neval + nev + call dqc25c(f, a2, b2, c, area2, error2, krule, nev) + Neval = Neval + nev + + ! improve previous approximations to integral + ! and error and test for accuracy. + + area12 = area1 + area2 + erro12 = error1 + error2 + errsum = errsum + erro12 - errmax + area = area + area12 - Rlist(maxerr) + if (abs(Rlist(maxerr) - area12) < 0.1e-4_wp*abs(area12) & + .and. erro12 >= 0.99_wp*errmax .and. krule == 0) & + iroff1 = iroff1 + 1 + if (Last > 10 .and. erro12 > errmax .and. krule == 0) & + iroff2 = iroff2 + 1 + Rlist(maxerr) = area1 + Rlist(Last) = area2 + errbnd = max(Epsabs, Epsrel*abs(area)) + if (errsum > errbnd) then + + ! test for roundoff error and eventually set error flag. + + if (iroff1 >= 6 .and. iroff2 > 20) Ier = 2 + + ! set error flag in the case that number of interval + ! bisections exceeds limit. + + if (Last == Limit) Ier = 1 + + ! set error flag in the case of bad integrand behaviour + ! at a point of the integration range. + + if (max(abs(a1), abs(b2)) & + <= (1.0_wp + 100.0_wp*epmach) & + *(abs(a2) + 1000.0_wp*uflow)) Ier = 3 + end if + + ! append the newly-created intervals to the list. + + if (error2 > error1) then + Alist(maxerr) = a2 + Alist(Last) = a1 + Blist(Last) = b1 + Rlist(maxerr) = area2 + Rlist(Last) = area1 + Elist(maxerr) = error2 + Elist(Last) = error1 + else + Alist(Last) = a2 + Blist(maxerr) = b1 + Blist(Last) = b2 + Elist(maxerr) = error1 + Elist(Last) = error2 + end if + + ! call subroutine dqpsrt to maintain the descending ordering + ! in the list of error estimates and select the subinterval + ! with nrmax-th largest error estimate (to be bisected next). + + call dqpsrt(Limit, Last, maxerr, errmax, Elist, Iord, nrmax) + ! ***jump out of do-loop + if (Ier /= 0 .or. errsum <= errbnd) exit + end do + + ! compute final result. + Result = 0.0_wp + do k = 1, Last + Result = Result + Rlist(k) + end do + Abserr = errsum + end if + if (aa == b) Result = -Result + end if + + end subroutine dqawce +!******************************************************************************** + +!******************************************************************************** +!> +! Fourier sine/cosine transform for user supplied interval `a` to `infinity` +! +! the routine calculates an approximation result to a given +! fourier integral i=integral of `f(x)*w(x)` over `(a,infinity)` +! where `w(x) = cos(omega*x)` or `w(x) = sin(omega*x)`. +! hopefully satisfying following claim for accuracy +! `abs(i-result)<=epsabs`. +! +!### History +! * QUADPACK: date written 800101, revision date 830518 (yymmdd) + + subroutine dqawf(f, a, Omega, Integr, Epsabs, Result, Abserr, Neval, Ier, & + Limlst, Lst, Leniw, Maxp1, Lenw, Iwork, Work) + implicit none + + procedure(func) :: f !! function subprogram defining the integrand function `f(x)`. + real(wp), intent(in) :: a !! lower limit of integration + real(wp), intent(in) :: Omega !! parameter in the integrand weight function + integer, intent(in) :: Integr !! indicates which of the weight functions is used: + !! + !! * integr = 1 `w(x) = cos(omega*x)` + !! * integr = 2 `w(x) = sin(omega*x)` + !! + !! if `integr/=1 .and. integr/=2`, the routine + !! will end with ier = 6. + real(wp), intent(in) :: Epsabs !! absolute accuracy requested, `epsabs>0`. + !! if `epsabs<=0`, the routine will end with ier = 6. + real(wp), intent(out) :: Result !! approximation to the integral + real(wp), intent(out) :: Abserr !! estimate of the modulus of the absolute error, + !! which should equal or exceed `abs(i-result)` + integer, intent(out) :: Neval !! number of integrand evaluations + integer, intent(out):: Ier !! * ier = 0 normal and reliable termination of the + !! routine. it is assumed that the requested + !! accuracy has been achieved. + !! * ier>0 abnormal termination of the routine. + !! the estimates for integral and error are + !! less reliable. it is assumed that the + !! requested accuracy has not been achieved. + !! + !! error messages: + !! + !! `if omega/=0`: + !! + !! * ier = 1 maximum number of cycles allowed + !! has been achieved, i.e. of subintervals + !! `(a+(k-1)c,a+kc)` where + !! `c = (2*int(abs(omega))+1)*pi/abs(omega)`, + !! for `k = 1, 2, ..., lst`. + !! one can allow more cycles by increasing + !! the value of limlst (and taking the + !! according dimension adjustments into + !! account). examine the array iwork which + !! contains the error flags on the cycles, in + !! order to look for eventual local + !! integration difficulties. + !! if the position of a local difficulty + !! can be determined (e.g. singularity, + !! discontinuity within the interval) one + !! will probably gain from splitting up the + !! interval at this point and calling + !! appropriate integrators on the subranges. + !! * ier = 4 the extrapolation table constructed for + !! convergence acceleration of the series + !! formed by the integral contributions over + !! the cycles, does not converge to within + !! the requested accuracy. + !! as in the case of ier = 1, it is advised + !! to examine the array iwork which contains + !! the error flags on the cycles. + !! * ier = 6 the input is invalid because + !! `(integr/=1 and integr/=2)` or + !! `epsabs<=0` or `limlst<1` or + !! `leniw<(limlst+2)` or `maxp1<1` or + !! `lenw<(leniw*2+maxp1*25)`. + !! `result`, `abserr`, `neval`, `lst` are set to + !! zero. + !! * ier = 7 bad integrand behaviour occurs within + !! one or more of the cycles. location and + !! type of the difficulty involved can be + !! determined from the first `lst` elements of + !! vector `iwork`. here `lst` is the number of + !! cycles actually needed (see below): + !! + !! * iwork(k) = 1 the maximum number of + !! subdivisions `(=(leniw-limlst)/2)` has + !! been achieved on the `k`th cycle. + !! * iwork(k) = 2 occurrence of roundoff error + !! is detected and prevents the + !! tolerance imposed on the `k`th + !! cycle, from being achieved + !! on this cycle. + !! * iwork(k) = 3 extremely bad integrand + !! behaviour occurs at some + !! points of the `k`th cycle. + !! * iwork(k) = 4 the integration procedure + !! over the `k`th cycle does + !! not converge (to within the + !! required accuracy) due to + !! roundoff in the extrapolation + !! procedure invoked on this + !! cycle. it is assumed that the + !! result on this interval is + !! the best which can be + !! obtained. + !! * iwork(k) = 5 the integral over the `k`th + !! cycle is probably divergent + !! or slowly convergent. it must + !! be noted that divergence can + !! occur with any other value of + !! `iwork(k)`. + !! + !! if `omega = 0` and `integr = 1`, + !! the integral is calculated by means of [[dqagie]], + !! and `ier = iwork(1)` (with meaning as described + !! for `iwork(k),k = 1`). + integer, intent(in) :: Limlst !! limlst gives an upper bound on the number of + !! cycles, `limlst>=3`. + !! if `limlst<3`, the routine will end with ier = 6. + integer, intent(out) :: Lst !! on return, lst indicates the number of cycles + !! actually needed for the integration. + !! if `omega = 0`, then lst is set to 1. + integer, intent(in) :: Leniw !! dimensioning parameter for `iwork`. on entry, + !! `(leniw-limlst)/2` equals the maximum number of + !! subintervals allowed in the partition of each + !! cycle, `leniw>=(limlst+2)`. + !! if `leniw<(limlst+2)`, the routine will end with + !! ier = 6. + integer, intent(in) :: Maxp1 !! maxp1 gives an upper bound on the number of + !! chebyshev moments which can be stored, i.e. for + !! the intervals of lengths `abs(b-a)*2**(-l)`, + !! `l = 0,1, ..., maxp1-2, maxp1>=1`. + !! if `maxp1<1`, the routine will end with ier = 6. + integer, intent(in) :: Lenw !! dimensioning parameter for `work`. + !! `lenw` must be at least `leniw*2+maxp1*25`. + !! if `lenw<(leniw*2+maxp1*25)`, the routine will + !! end with ier = 6. + integer :: Iwork(Leniw) !! vector of dimension at least `leniw` + !! on return, `iwork(k)` for `k = 1, 2, ..., lst` + !! contain the error flags on the cycles. + real(wp) :: Work(Lenw) !! vector of dimension at least `lenw` + !! on return: + !! + !! * `work(1), ..., work(lst)` contain the integral + !! approximations over the cycles, + !! * `work(limlst+1), ..., work(limlst+lst)` contain + !! the error estimates over the cycles. + !! + !! further elements of work have no specific + !! meaning for the user. + + integer :: last, limit, ll2, lvl, l1, l2, l3, l4, l5, l6 + + ! check validity of limlst, leniw, maxp1 and lenw. + Ier = 6 + Neval = 0 + last = 0 + Result = 0.0_wp + Abserr = 0.0_wp + if (Limlst >= 3 .and. Leniw >= (Limlst + 2) .and. Maxp1 >= 1 .and. & + Lenw >= (Leniw*2 + Maxp1*25)) then + + ! prepare call for dqawfe + limit = (Leniw - Limlst)/2 + l1 = Limlst + 1 + l2 = Limlst + l1 + l3 = limit + l2 + l4 = limit + l3 + l5 = limit + l4 + l6 = limit + l5 + ll2 = limit + l1 + call dqawfe(f, a, Omega, Integr, Epsabs, Limlst, limit, Maxp1, Result, & + Abserr, Neval, Ier, Work(1), Work(l1), Iwork(1), Lst, & + Work(l2), Work(l3), Work(l4), Work(l5), Iwork(l1), & + Iwork(ll2), Work(l6)) + + ! call error handler if necessary + lvl = 0 + end if + if (Ier == 6) lvl = 1 + if (Ier /= 0) call xerror('abnormal return from dqawf', Ier, lvl) + + end subroutine dqawf +!******************************************************************************** + +!******************************************************************************** +!> +! same as [[dqawf]] but provides more information and control +! +! the routine calculates an approximation result to a +! given fourier integral +! i = integral of `f(x)*w(x)` over `(a,infinity)` +! where `w(x)=cos(omega*x)` or `w(x)=sin(omega*x)`, +! hopefully satisfying following claim for accuracy +! `abs(i-result)<=epsabs`. +! +!### History +! * QUADPACK: date written 800101, revision date 830518 (yymmdd) + + subroutine dqawfe(f, a, Omega, Integr, Epsabs, Limlst, Limit, Maxp1, & + Result, Abserr, Neval, Ier, Rslst, Erlst, Ierlst, Lst, & + Alist, Blist, Rlist, Elist, Iord, Nnlog, Chebmo) + implicit none + + procedure(func) :: f !! function subprogram defining the integrand function `f(x)`. + real(wp), intent(in) :: a !! lower limit of integration + real(wp), intent(in) :: Omega !! parameter in the weight function + integer, intent(in) :: Integr !! indicates which weight function is used: + !! + !! * integr = 1 `w(x) = cos(omega*x)` + !! * integr = 2 `w(x) = sin(omega*x)` + !! + !! if `integr/=1.and.integr/=2`, the routine will + !! end with ier = 6. + real(wp), intent(in) :: Epsabs !! absolute accuracy requested, `epsabs>0` + !! if `epsabs<=0`, the routine will end with ier = 6. + integer, intent(in) :: Limlst !! limlst gives an upper bound on the number of + !! cycles, `limlst>=1`. + !! if `limlst<3`, the routine will end with ier = 6. + integer, intent(in) :: Limit !! gives an upper bound on the number of subintervals + !! allowed in the partition of each cycle, `limit>=1` + !! each cycle, `limit>=1`. + integer, intent(in) :: Maxp1 !! gives an upper bound on the number of + !! chebyshev moments which can be stored, i.e. + !! for the intervals of lengths + !! `abs(b-a)*2**(-l), `l=0,1, ..., maxp1-2, maxp1>=1`` + real(wp), intent(out) :: Result !! approximation to the integral `x` + real(wp), intent(out) :: Abserr !! estimate of the modulus of the absolute error, + !! which should equal or exceed `abs(i-result)` + integer, intent(out) :: Neval !! number of integrand evaluations + integer, intent(out) :: Ier !! * ier = 0 normal and reliable termination of + !! the routine. it is assumed that the + !! requested accuracy has been achieved. + !! * ier>0 abnormal termination of the routine. the + !! estimates for integral and error are less + !! reliable. it is assumed that the requested + !! accuracy has not been achieved. + !! + !! error messages: + !! + !! if `omega/=0`: + !! + !! * ier = 1 maximum number of `cycles` allowed + !! has been achieved., i.e. of subintervals + !! `(a+(k-1)c,a+kc)` where + !! `c = (2*int(abs(omega))+1)*pi/abs(omega)`, + !! for `k = 1, 2, ..., lst`. + !! one can allow more cycles by increasing + !! the value of limlst (and taking the + !! according dimension adjustments into + !! account). + !! examine the array `iwork` which contains + !! the error flags on the cycles, in order to + !! look for eventual local integration + !! difficulties. if the position of a local + !! difficulty can be determined (e.g. + !! singularity, discontinuity within the + !! interval) one will probably gain from + !! splitting up the interval at this point + !! and calling appropriate integrators on + !! the subranges. + !! * ier = 4 the extrapolation table constructed for + !! convergence acceleration of the series + !! formed by the integral contributions over + !! the cycles, does not converge to within + !! the requested accuracy. as in the case of + !! ier = 1, it is advised to examine the + !! array `iwork` which contains the error + !! flags on the cycles. + !! * ier = 6 the input is invalid because + !! (`integr/=1` and `integr/=2`) or + !! `epsabs<=0` or `limlst<3`. + !! `result`, `abserr`, `neval`, `lst` are set + !! to zero. + !! * ier = 7 bad integrand behaviour occurs within one + !! or more of the cycles. location and type + !! of the difficulty involved can be + !! determined from the vector `ierlst`. here + !! `lst` is the number of cycles actually + !! needed (see below): + !! + !! * ierlst(k) = 1 the maximum number of + !! subdivisions (= `limit`) has + !! been achieved on the `k`th + !! cycle. + !! * ierlst(k) = 2 occurrence of roundoff error + !! is detected and prevents the + !! tolerance imposed on the + !! `k`th cycle, from being + !! achieved. + !! * ierlst(k) = 3 extremely bad integrand + !! behaviour occurs at some + !! points of the `k`th cycle. + !! * ierlst(k) = 4 the integration procedure + !! over the `k`th cycle does + !! not converge (to within the + !! required accuracy) due to + !! roundoff in the + !! extrapolation procedure + !! invoked on this cycle. it + !! is assumed that the result + !! on this interval is the + !! best which can be obtained. + !! * ierlst(k) = 5 the integral over the `k`th + !! cycle is probably divergent + !! or slowly convergent. it + !! must be noted that + !! divergence can occur with + !! any other value of + !! `ierlst(k)`. + !! + !! if `omega = 0` and `integr = 1`, + !! the integral is calculated by means of [[dqagie]] + !! and `ier = ierlst(1)` (with meaning as described + !! for `ierlst(k), k = 1`). + real(wp), intent(out) :: Rslst(Limlst) !! vector of dimension at least `limlst` + !! `rslst(k)` contains the integral contribution + !! over the interval `(a+(k-1)c,a+kc)` where + !! `c = (2*int(abs(omega))+1)*pi/abs(omega)`, + !! `k = 1, 2, ..., lst`. + !! note that, if `omega = 0`, `rslst(1)` contains + !! the value of the integral over `(a,infinity)`. + real(wp), intent(out) :: Erlst(Limlst) !! vector of dimension at least `limlst` + !! `erlst(k)` contains the error estimate corresponding + !! with `rslst(k)`. + integer, intent(out) :: Ierlst(Limlst) !! vector of dimension at least `limlst` + !! `ierlst(k)` contains the error flag corresponding + !! with `rslst(k)`. for the meaning of the local error + !! flags see description of output parameter `ier`. + integer, intent(out) :: Lst !! number of subintervals needed for the integration + !! if `omega = 0` then lst is set to 1. + real(wp), intent(out) :: Alist(Limit) !! vector of dimension at least `limit` + real(wp), intent(out) :: Blist(Limit) !! vector of dimension at least `limit` + real(wp), intent(out) :: Rlist(Limit) !! vector of dimension at least `limit` + real(wp), intent(out) :: Elist(Limit) !! vector of dimension at least `limit` + integer, intent(out) :: Iord(Limit) !! vector of dimension at least `limit`, providing + !! space for the quantities needed in the subdivision + !! process of each cycle + integer, intent(out) :: Nnlog(Limit) !! vector of dimension at least `limit`, providing + !! space for the quantities needed in the subdivision + !! process of each cycle + real(wp), intent(out) :: Chebmo(Maxp1, 25) !! array of dimension at least `(maxp1,25)`, providing + !! space for the chebyshev moments needed within the + !! cycles (see also routine [[dqc25f]]) + + real(wp) :: abseps, correc, dl, dla, drl, ep, eps, fact, p1, reseps, res3la(3) + integer :: ktmin, l, last, ll, momcom, nev, nres, numrl2 + real(wp) :: psum(limexp + 2) !! `psum` contains the part of the epsilon table + !! which is still needed for further computations. + !! each element of `psum` is a partial sum of the + !! series which should sum to the value of the + !! integral. + real(wp) :: c1, c2 !! end points of subinterval (of length cycle) + real(wp) :: cycle !! `(2*int(abs(omega))+1)*pi/abs(omega)` + real(wp) :: errsum !! sum of error estimates over the subintervals, + !! calculated cumulatively + real(wp) :: epsa !! absolute tolerance requested over current + !! subinterval + + real(wp), parameter :: p = 0.9_wp + + ! test on validity of parameters + + Result = 0.0_wp + Abserr = 0.0_wp + Neval = 0 + Lst = 0 + Ier = 0 + if ((Integr /= 1 .and. Integr /= 2) .or. Epsabs <= 0.0_wp .or. & + Limlst < 3) Ier = 6 + if (Ier == 6) return + + if (Omega == 0.0_wp) then + ! integration by dqagie if omega is zero + if (Integr == 1) call dqagie(f, 0.0_wp, 1, Epsabs, 0.0_wp, & + Limit, Result, Abserr, Neval, & + Ier, Alist, Blist, Rlist, Elist, & + Iord, last) + Rslst(1) = Result + Erlst(1) = Abserr + Ierlst(1) = Ier + Lst = 1 + return + end if + + main : block + + ! initializations + + l = abs(Omega) + dl = 2*l + 1 + cycle = dl*pi/abs(Omega) + Ier = 0 + ktmin = 0 + Neval = 0 + numrl2 = 0 + nres = 0 + c1 = a + c2 = cycle + a + p1 = 1.0_wp - p + eps = Epsabs + if (Epsabs > uflow/p1) eps = Epsabs*p1 + ep = eps + fact = 1.0_wp + correc = 0.0_wp + Abserr = 0.0_wp + errsum = 0.0_wp + + ! main do-loop + + do Lst = 1, Limlst + + ! integrate over current subinterval. + + dla = Lst + epsa = eps*fact + call dqawoe(f, c1, c2, Omega, Integr, epsa, 0.0_wp, Limit, Lst, & + Maxp1, Rslst(Lst), Erlst(Lst), nev, Ierlst(Lst), & + last, Alist, Blist, Rlist, Elist, Iord, Nnlog, & + momcom, Chebmo) + Neval = Neval + nev + fact = fact*p + errsum = errsum + Erlst(Lst) + drl = 50.0_wp*abs(Rslst(Lst)) + + ! test on accuracy with partial sum + + if ((errsum + drl) <= Epsabs .and. Lst >= 6) exit main + correc = max(correc, Erlst(Lst)) + if (Ierlst(Lst) /= 0) eps = max(ep, correc*p1) + if (Ierlst(Lst) /= 0) Ier = 7 + if (Ier == 7 .and. (errsum + drl) <= correc*10.0_wp .and. & + Lst > 5) exit main + numrl2 = numrl2 + 1 + if (Lst > 1) then + psum(numrl2) = psum(ll) + Rslst(Lst) + if (Lst /= 2) then + + ! test on maximum number of subintervals + + if (Lst == Limlst) Ier = 1 + + ! perform new extrapolation + + call dqelg(numrl2, psum, reseps, abseps, res3la, nres) + + ! test whether extrapolated result is influenced by roundoff + + ktmin = ktmin + 1 + if (ktmin >= 15 .and. Abserr <= 0.1e-02_wp*(errsum + drl)) & + Ier = 4 + if (abseps <= Abserr .or. Lst == 3) then + Abserr = abseps + Result = reseps + ktmin = 0 + + ! if ier is not 0, check whether direct result (partial sum) + ! or extrapolated result yields the best integral + ! approximation + + if ((Abserr + 10.0_wp*correc) <= Epsabs .or. & + (Abserr <= Epsabs .and. & + 10.0_wp*correc >= Epsabs)) exit + end if + if (Ier /= 0 .and. Ier /= 7) exit + end if + else + psum(1) = Rslst(1) + end if + ll = numrl2 + c1 = c2 + c2 = c2 + cycle + end do + + ! set final result and error estimate + + Abserr = Abserr + 10.0_wp*correc + if (Ier == 0) return + if (Result == 0.0_wp .or. psum(numrl2) == 0.0_wp) then + if (Abserr > errsum) exit main + if (psum(numrl2) == 0.0_wp) return + end if + if (Abserr/abs(Result) <= (errsum + drl)/abs(psum(numrl2))) & + then + if (Ier >= 1 .and. Ier /= 7) Abserr = Abserr + drl + return + end if + + end block main + + Result = psum(numrl2) + Abserr = errsum + drl + + end subroutine dqawfe +!******************************************************************************** + +!******************************************************************************** +!> +! 1D integration of `cos(omega*x)*f(x)` or `sin(omega*x)*f(x)` +! over a finite interval, adaptive subdivision with extrapolation +! +! the routine calculates an approximation result to a given +! definite integral i=integral of `f(x)*w(x)` over `(a,b)` +! where `w(x) = cos(omega*x)` or `w(x) = sin(omega*x)`, +! hopefully satisfying following claim for accuracy +! `abs(i-result)<=max(epsabs,epsrel*abs(i))`. +! +!### History +! * QUADPACK: date written 800101, revision date 830518 (yymmdd) + + subroutine dqawo(f, a, b, Omega, Integr, Epsabs, Epsrel, Result, Abserr, & + Neval, Ier, Leniw, Maxp1, Lenw, Last, Iwork, Work) + implicit none + + procedure(func) :: f !! function subprogram defining the function `f(x)`. + real(wp), intent(in) :: a !! lower limit of integration + real(wp), intent(in) :: b !! upper limit of integration + real(wp), intent(in) :: Omega !! parameter in the integrand weight function + integer, intent(in) :: Integr !! indicates which of the weight functions is used + !! + !! * integr = 1 `w(x) = cos(omega*x)` + !! * integr = 2 `w(x) = sin(omega*x)` + !! + !! if `integr/=1.and.integr/=2`, the routine will + !! end with ier = 6. + real(wp), intent(in) :: Epsabs !! absolute accuracy requested + real(wp), intent(in) :: Epsrel !! relative accuracy requested + !! if `epsabs<=0` and + !! `epsrel0 abnormal termination of the routine. + !! the estimates for integral and error are + !! less reliable. it is assumed that the + !! requested accuracy has not been achieved. + !! + !! error messages: + !! + !! * ier = 1 maximum number of subdivisions allowed + !! `(= leniw/2)` has been achieved. one can + !! allow more subdivisions by increasing the + !! value of leniw (and taking the according + !! dimension adjustments into account). + !! however, if this yields no improvement it + !! is advised to analyze the integrand in + !! order to determine the integration + !! difficulties. if the position of a local + !! difficulty can be determined (e.g. + !! singularity, discontinuity within the + !! interval) one will probably gain from + !! splitting up the interval at this point + !! and calling the integrator on the + !! subranges. if possible, an appropriate + !! special-purpose integrator should be used + !! which is designed for handling the type of + !! difficulty involved. + !! * ier = 2 the occurrence of roundoff error is + !! detected, which prevents the requested + !! tolerance from being achieved. + !! the error may be under-estimated. + !! * ier = 3 extremely bad integrand behaviour occurs + !! at some interior points of the + !! integration interval. + !! * ier = 4 the algorithm does not converge. + !! roundoff error is detected in the + !! extrapolation table. it is presumed that + !! the requested tolerance cannot be achieved + !! due to roundoff in the extrapolation + !! table, and that the returned result is + !! the best which can be obtained. + !! * ier = 5 the integral is probably divergent, or + !! slowly convergent. it must be noted that + !! divergence can occur with any other value + !! of `ier`. + !! * ier = 6 the input is invalid, because + !! `(epsabs<=0 and epsrel=2`. + !! if `leniw<2`, the routine will end with ier = 6. + integer, intent(in) :: Maxp1 !! gives an upper bound on the number of chebyshev + !! moments which can be stored, i.e. for the + !! intervals of lengths `abs(b-a)*2**(-l)`, + !! `l=0,1, ..., maxp1-2, maxp1>=1` + !! if `maxp1<1`, the routine will end with ier = 6. + integer, intent(in) :: Lenw !! dimensioning parameter for `work` + !! `lenw` must be at least `leniw*2+maxp1*25`. + !! if `lenw<(leniw*2+maxp1*25)`, the routine will + !! end with ier = 6. + integer, intent(out) :: Last !! on return, `last` equals the number of subintervals + !! produced in the subdivision process, which + !! determines the number of significant elements + !! actually in the work arrays. + integer :: Iwork(Leniw) !! vector of dimension at least leniw + !! on return, the first `k` elements of which contain + !! pointers to the error estimates over the + !! subintervals, such that + !! `work(limit*3+iwork(1)), .., work(limit*3+iwork(k))` + !! form a decreasing + !! sequence, with `limit = lenw/2` , and `k = last` + !! if `last<=(limit/2+2)`, and `k = limit+1-last` + !! otherwise. + !! furthermore, `iwork(limit+1), ..., iwork(limit+last)` + !! indicate the subdivision levels of the + !! subintervals, such that `iwork(limit+i) = l` means + !! that the subinterval numbered `i` is of length + !! `abs(b-a)*2**(1-l)`. + real(wp) :: Work(Lenw) !! vector of dimension at least `lenw`. + !! on return: + !! + !! * `work(1), ..., work(last)` contain the left + !! end points of the subintervals in the + !! partition of `(a,b)`, + !! * `work(limit+1), ..., work(limit+last)` contain + !! the right end points, + !! * `work(limit*2+1), ..., work(limit*2+last)` contain + !! the integral approximations over the + !! subintervals, + !! * `work(limit*3+1), ..., work(limit*3+last)` + !! contain the error estimates. + !! * `work(limit*4+1), ..., work(limit*4+maxp1*25)` + !! provide space for storing the chebyshev moments. + !! + !! note that `limit = lenw/2`. + + integer :: limit, lvl, l1, l2, l3, l4, momcom + + ! check validity of leniw, maxp1 and lenw. + Ier = 6 + Neval = 0 + Last = 0 + Result = 0.0_wp + Abserr = 0.0_wp + if (Leniw >= 2 .and. Maxp1 >= 1 .and. Lenw >= (Leniw*2 + Maxp1*25)) then + ! prepare call for dqawoe + limit = Leniw/2 + l1 = limit + 1 + l2 = limit + l1 + l3 = limit + l2 + l4 = limit + l3 + call dqawoe(f, a, b, Omega, Integr, Epsabs, Epsrel, limit, 1, Maxp1, & + Result, Abserr, Neval, Ier, Last, Work(1), Work(l1), & + Work(l2), Work(l3), Iwork(1), Iwork(l1), momcom, & + Work(l4)) + ! call error handler if necessary + lvl = 0 + end if + if (Ier == 6) lvl = 1 + if (Ier /= 0) call xerror('abnormal return from dqawo', Ier, lvl) + + end subroutine dqawo +!******************************************************************************** + +!******************************************************************************** +!> +! same as [[dqawo]] but provides more information and control +! +! the routine calculates an approximation result to a given +! definite integral +! i = integral of `f(x)*w(x)` over `(a,b)` +! where `w(x) = cos(omega*x)` or `w(x)=sin(omega*x)`, +! hopefully satisfying following claim for accuracy +! `abs(i-result)<=max(epsabs,epsrel*abs(i))`. +! +!### History +! * QUADPACK: date written 800101, revision date 830518 (yymmdd) + + subroutine dqawoe(f, a, b, Omega, Integr, Epsabs, Epsrel, Limit, Icall, & + Maxp1, Result, Abserr, Neval, Ier, Last, Alist, Blist, & + Rlist, Elist, Iord, Nnlog, Momcom, Chebmo) + implicit none + + procedure(func) :: f !! function subprogram defining the integrand function `f(x)`. + real(wp), intent(in) :: a !! lower limit of integration + real(wp), intent(in) :: b !! upper limit of integration + real(wp), intent(in) :: Omega !! parameter in the integrand weight function + integer, intent(in) :: Integr !! indicates which of the weight functions is to be + !! used: + !! + !! * integr = 1 `w(x) = cos(omega*x)` + !! * integr = 2 `w(x) = sin(omega*x)` + !! + !! if `integr/=1` and `integr/=2`, the routine + !! will end with ier = 6. + real(wp), intent(in) :: Epsabs !! absolute accuracy requested + real(wp), intent(in) :: Epsrel !! relative accuracy requested. + !! if `epsabs<=0` + !! and `epsrel=1`. + integer, intent(in) :: Icall !! if dqawoe is to be used only once, icall must + !! be set to 1. assume that during this call, the + !! chebyshev moments (for clenshaw-curtis integration + !! of degree 24) have been computed for intervals of + !! lengths `(abs(b-a))*2**(-l), l=0,1,2,...momcom-1`. + !! if `icall>1` this means that dqawoe has been + !! called twice or more on intervals of the same + !! length `abs(b-a)`. the chebyshev moments already + !! computed are then re-used in subsequent calls. + !! if `icall<1`, the routine will end with ier = 6. + integer, intent(in) :: Maxp1 !! gives an upper bound on the number of chebyshev + !! moments which can be stored, i.e. for the + !! intervals of lengths `abs(b-a)*2**(-l)`, + !! `l=0,1, ..., maxp1-2, maxp1>=1`. + !! if `maxp1<1`, the routine will end with ier = 6. + real(wp), intent(out) :: Result !! approximation to the integral + real(wp), intent(out) :: Abserr !! estimate of the modulus of the absolute error, + !! which should equal or exceed `abs(i-result)` + integer, intent(out) :: Neval !! number of integrand evaluations + integer, intent(out) :: Ier !! * ier = 0 normal and reliable termination of the + !! routine. it is assumed that the + !! requested accuracy has been achieved. + !! * ier>0 abnormal termination of the routine. + !! the estimates for integral and error are + !! less reliable. it is assumed that the + !! requested accuracy has not been achieved. + !! + !! error messages: + !! + !! * ier = 1 maximum number of subdivisions allowed + !! has been achieved. one can allow more + !! subdivisions by increasing the value of + !! limit (and taking according dimension + !! adjustments into account). however, if + !! this yields no improvement it is advised + !! to analyze the integrand, in order to + !! determine the integration difficulties. + !! if the position of a local difficulty can + !! be determined (e.g. singularity, + !! discontinuity within the interval) one + !! will probably gain from splitting up the + !! interval at this point and calling the + !! integrator on the subranges. if possible, + !! an appropriate special-purpose integrator + !! should be used which is designed for + !! handling the type of difficulty involved. + !! * ier = 2 the occurrence of roundoff error is + !! detected, which prevents the requested + !! tolerance from being achieved. + !! the error may be under-estimated. + !! * ier = 3 extremely bad integrand behaviour occurs + !! at some points of the integration + !! interval. + !! * ier = 4 the algorithm does not converge. + !! roundoff error is detected in the + !! extrapolation table. + !! it is presumed that the requested + !! tolerance cannot be achieved due to + !! roundoff in the extrapolation table, + !! and that the returned result is the + !! best which can be obtained. + !! * ier = 5 the integral is probably divergent, or + !! slowly convergent. it must be noted that + !! divergence can occur with any other value + !! of ier>0. + !! * ier = 6 the input is invalid, because + !! `(epsabs<=0 and epsrel errbnd) & + Ier = 2 + if (Limit == 1) Ier = 1 + if (Ier /= 0 .or. Abserr <= errbnd) then + if (Integr == 2 .and. Omega < 0.0_wp) Result = -Result + return + end if + + ! initializations + + errmax = Abserr + maxerr = 1 + area = Result + errsum = Abserr + Abserr = oflow + nrmax = 1 + extrap = .false. + noext = .false. + ierro = 0 + iroff1 = 0 + iroff2 = 0 + iroff3 = 0 + ktmin = 0 + small = abs(b - a)*0.75_wp + nres = 0 + numrl2 = 0 + extall = .false. + if (0.5_wp*abs(b - a)*domega <= 2.0_wp) then + numrl2 = 1 + extall = .true. + rlist2(1) = Result + end if + if (0.25_wp*abs(b - a)*domega <= 2.0_wp) extall = .true. + ksgn = -1 + if (dres >= (1.0_wp - 50.0_wp*epmach)*defabs) ksgn = 1 + + ! main do-loop + + do Last = 2, Limit + + ! bisect the subinterval with the nrmax-th largest + ! error estimate. + + nrmom = Nnlog(maxerr) + 1 + a1 = Alist(maxerr) + b1 = 0.5_wp*(Alist(maxerr) + Blist(maxerr)) + a2 = b1 + b2 = Blist(maxerr) + erlast = errmax + call dqc25f(f, a1, b1, domega, Integr, nrmom, Maxp1, 0, area1, & + error1, nev, resabs, defab1, Momcom, Chebmo) + Neval = Neval + nev + call dqc25f(f, a2, b2, domega, Integr, nrmom, Maxp1, 1, area2, & + error2, nev, resabs, defab2, Momcom, Chebmo) + Neval = Neval + nev + + ! improve previous approximations to integral + ! and error and test for accuracy. + + area12 = area1 + area2 + erro12 = error1 + error2 + errsum = errsum + erro12 - errmax + area = area + area12 - Rlist(maxerr) + if (defab1 /= error1 .and. defab2 /= error2) then + if (abs(Rlist(maxerr) - area12) <= 0.1e-4_wp*abs(area12) & + .and. erro12 >= 0.99_wp*errmax) then + if (extrap) iroff2 = iroff2 + 1 + if (.not. extrap) iroff1 = iroff1 + 1 + end if + if (Last > 10 .and. erro12 > errmax) iroff3 = iroff3 + 1 + end if + Rlist(maxerr) = area1 + Rlist(Last) = area2 + Nnlog(maxerr) = nrmom + Nnlog(Last) = nrmom + errbnd = max(Epsabs, Epsrel*abs(area)) + + ! test for roundoff error and eventually set error flag. + + if (iroff1 + iroff2 >= 10 .or. iroff3 >= 20) Ier = 2 + if (iroff2 >= 5) ierro = 3 + + ! set error flag in the case that the number of + ! subintervals equals limit. + + if (Last == Limit) Ier = 1 + + ! set error flag in the case of bad integrand behaviour + ! at a point of the integration range. + + if (max(abs(a1), abs(b2)) <= (1.0_wp + 100.0_wp*epmach) & + *(abs(a2) + 1000.0_wp*uflow)) Ier = 4 + + ! append the newly-created intervals to the list. + + if (error2 > error1) then + Alist(maxerr) = a2 + Alist(Last) = a1 + Blist(Last) = b1 + Rlist(maxerr) = area2 + Rlist(Last) = area1 + Elist(maxerr) = error2 + Elist(Last) = error1 + else + Alist(Last) = a2 + Blist(maxerr) = b1 + Blist(Last) = b2 + Elist(maxerr) = error1 + Elist(Last) = error2 + end if + + ! call subroutine dqpsrt to maintain the descending ordering + ! in the list of error estimates and select the subinterval + ! with nrmax-th largest error estimate (to bisected next). + + call dqpsrt(Limit, Last, maxerr, errmax, Elist, Iord, nrmax) + if (errsum <= errbnd) then + ! ***jump out of do-loop + done = .true. + exit + end if + if (Ier /= 0) exit + if (Last == 2 .and. extall) then + small = small*0.5_wp + numrl2 = numrl2 + 1 + rlist2(numrl2) = area + else + if (noext) cycle + test = .true. + if (extall) then + erlarg = erlarg - erlast + if (abs(b1 - a1) > small) erlarg = erlarg + erro12 + if (extrap) test = .false. + end if + + if (test) then + ! test whether the interval to be bisected next is the + ! smallest interval. + + width = abs(Blist(maxerr) - Alist(maxerr)) + if (width > small) cycle + if (extall) then + extrap = .true. + nrmax = 2 + else + ! test whether we can start with the extrapolation procedure + ! (we do this if we integrate over the next interval with + ! use of a gauss-kronrod rule - see subroutine dqc25f). + small = small*0.5_wp + if (0.25_wp*width*domega > 2.0_wp) cycle + extall = .true. + ertest = errbnd + erlarg = errsum + cycle + end if + end if + + if (ierro /= 3 .and. erlarg > ertest) then + + ! the smallest interval has the largest error. + ! before bisecting decrease the sum of the errors over + ! the larger intervals (erlarg) and perform extrapolation. + + jupbnd = Last + if (Last > (Limit/2 + 2)) jupbnd = Limit + 3 - Last + id = nrmax + do k = id, jupbnd + maxerr = Iord(nrmax) + errmax = Elist(maxerr) + if (abs(Blist(maxerr) - Alist(maxerr)) > small) & + cycle + nrmax = nrmax + 1 + end do + end if + + ! perform extrapolation. + + numrl2 = numrl2 + 1 + rlist2(numrl2) = area + if (numrl2 >= 3) then + call dqelg(numrl2, rlist2, reseps, abseps, res3la, nres) + ktmin = ktmin + 1 + if (ktmin > 5 .and. Abserr < 0.1e-02_wp*errsum) Ier = 5 + if (abseps < Abserr) then + ktmin = 0 + Abserr = abseps + Result = reseps + correc = erlarg + ertest = max(Epsabs, Epsrel*abs(reseps)) + ! ***jump out of do-loop + if (Abserr <= ertest) exit + end if + + ! prepare bisection of the smallest interval. + + if (numrl2 == 1) noext = .true. + if (Ier == 5) exit + end if + maxerr = Iord(1) + errmax = Elist(maxerr) + nrmax = 1 + extrap = .false. + small = small*0.5_wp + erlarg = errsum + cycle + end if + ertest = errbnd + erlarg = errsum + end do + + final : block + + if (done) exit final + + ! set the final result. + + if (Abserr /= oflow .and. nres /= 0) then + if (Ier + ierro /= 0) then + if (ierro == 3) Abserr = Abserr + correc + if (Ier == 0) Ier = 3 + if (Result == 0.0_wp .or. area == 0.0_wp) then + if (Abserr > errsum) exit final + if (area == 0.0_wp) then + if (Ier > 2) Ier = Ier - 1 + if (Integr == 2 .and. Omega < 0.0_wp) Result = -Result + return + end if + elseif (Abserr/abs(Result) > errsum/abs(area)) then + exit final + end if + end if + + ! test on divergence. + + if (ksgn /= (-1) .or. max(abs(Result), abs(area)) & + > defabs*0.01_wp) then + if (0.01_wp > (Result/area) .or. (Result/area) & + > 100.0_wp .or. errsum >= abs(area)) Ier = 6 + end if + if (Ier > 2) Ier = Ier - 1 + if (Integr == 2 .and. Omega < 0.0_wp) Result = -Result + return + end if + + end block final + + ! compute global integral sum. + + Result = 0.0_wp + do k = 1, Last + Result = Result + Rlist(k) + end do + Abserr = errsum + if (Ier > 2) Ier = Ier - 1 + if (Integr == 2 .and. Omega < 0.0_wp) Result = -Result + + end subroutine dqawoe +!******************************************************************************** + +!******************************************************************************** +!> +! 1D integration of functions with powers and or logs over a finite interval +! +! the routine calculates an approximation result to a given +! definite integral i = integral of `f*w` over `(a,b)`, +! (where `w` shows a singular behaviour at the end points +! see parameter `integr`). +! hopefully satisfying following claim for accuracy +! `abs(i-result)<=max(epsabs,epsrel*abs(i))`. +! +!### History +! * QUADPACK: date written 800101, revision date 830518 (yymmdd) + + subroutine dqaws(f, a, b, alfa, beta, integr, epsabs, epsrel, result, & + abserr, neval, ier, limit, lenw, last, iwork, work) + implicit none + + procedure(func) :: f !! function subprogram defining the integrand function `f(x)`. + real(wp), intent(in) :: a !! lower limit of integration + real(wp), intent(in) :: b !! upper limit of integration, b>a + !! if b<=a, the routine will end with ier = 6. + real(wp), intent(in) :: alfa !! parameter in the integrand function, `alfa>(-1)` + !! if `alfa<=(-1)`, the routine will end with + !! ier = 6. + real(wp), intent(in) :: beta !! parameter in the integrand function, `beta>(-1)` + !! if `beta<=(-1)`, the routine will end with + !! ier = 6. + integer, intent(in) :: integr !! indicates which weight function is to be used: + !! + !! * = 1 `(x-a)**alfa*(b-x)**beta` + !! * = 2 `(x-a)**alfa*(b-x)**beta*log(x-a)` + !! * = 3 `(x-a)**alfa*(b-x)**beta*log(b-x)` + !! * = 4 `(x-a)**alfa*(b-x)**beta*log(x-a)*log(b-x)` + !! + !! if `integr<1` or `integr>4`, the routine + !! will end with ier = 6. + real(wp), intent(in) :: epsabs !! absolute accuracy requested + real(wp), intent(in) :: epsrel !! relative accuracy requested. + !! if `epsabs<=0` + !! and `epsrel0 abnormal termination of the routine + !! the estimates for the integral and error + !! are less reliable. it is assumed that the + !! requested accuracy has not been achieved. + !! + !! error messages: + !! + !! * ier = 1 maximum number of subdivisions allowed + !! has been achieved. one can allow more + !! subdivisions by increasing the value of + !! limit (and taking the according dimension + !! adjustments into account). however, if + !! this yields no improvement it is advised + !! to analyze the integrand, in order to + !! determine the integration difficulties + !! which prevent the requested tolerance from + !! being achieved. in case of a jump + !! discontinuity or a local singularity + !! of algebraico-logarithmic type at one or + !! more interior points of the integration + !! range, one should proceed by splitting up + !! the interval at these points and calling + !! the integrator on the subranges. + !! * ier = 2 the occurrence of roundoff error is + !! detected, which prevents the requested + !! tolerance from being achieved. + !! * ier = 3 extremely bad integrand behaviour occurs + !! at some points of the integration + !! interval. + !! * ier = 6 the input is invalid, because + !! `b<=a` or `alfa<=(-1)` or `beta<=(-1)` or + !! or `integr<1` or `integr>4` or + !! `(epsabs<=0 and epsrel=2`. + !! if `limit<2`, the routine will end with ier = 6. + integer, intent(in) :: lenw !! dimensioning parameter for `work` + !! `lenw` must be at least `limit*4`. + !! if `lenw= 2 .and. lenw >= limit*4) then + + ! prepare call for dqawse. + + l1 = limit + 1 + l2 = limit + l1 + l3 = limit + l2 + + call dqawse(f, a, b, alfa, beta, integr, epsabs, epsrel, limit, result, & + abserr, neval, ier, work(1), work(l1), work(l2), work(l3), iwork, last) + + ! call error handler if necessary. + lvl = 0 + end if + if (ier == 6) lvl = 1 + if (ier /= 0) call xerror('abnormal return from dqaws', ier, lvl) + + end subroutine dqaws +!******************************************************************************** + +!******************************************************************************** +!> +! same as [[dqaws]] but provides more information and control +! +! the routine calculates an approximation result to a given +! definite integral i = integral of f*w over `(a,b)`, +! (where `w` shows a singular behaviour at the end points, +! see parameter integr). +! hopefully satisfying following claim for accuracy +! `abs(i-result)<=max(epsabs,epsrel*abs(i))`. +! +!### History +! * QUADPACK: date written 800101, revision date 830518 (yymmdd) + + subroutine dqawse(f, a, b, Alfa, Beta, Integr, Epsabs, Epsrel, Limit, & + Result, Abserr, Neval, Ier, Alist, Blist, Rlist, Elist, & + Iord, Last) + implicit none + + procedure(func) :: f !! function subprogram defining the integrand function `f(x)`. + real(wp), intent(in) :: a !! lower limit of integration + real(wp), intent(in) :: b !! upper limit of integration, `b>a`. + !! if `b<=a`, the routine will end with ier = 6. + real(wp), intent(in) :: Alfa !! parameter in the weight function, `alfa>(-1)` + !! if `alfa<=(-1)`, the routine will end with + !! ier = 6. + real(wp), intent(in) :: Beta !! parameter in the weight function, `beta>(-1)` + !! if `beta<=(-1)`, the routine will end with + !! ier = 6. + integer, intent(in) :: Integr !! indicates which weight function is to be used: + !! + !! * = 1 `(x-a)**alfa*(b-x)**beta` + !! * = 2 `(x-a)**alfa*(b-x)**beta*log(x-a)` + !! * = 3 `(x-a)**alfa*(b-x)**beta*log(b-x)` + !! * = 4 `(x-a)**alfa*(b-x)**beta*log(x-a)*log(b-x)` + !! + !! if `integr<1` or `integr>4`, the routine + !! will end with ier = 6. + real(wp), intent(in) :: Epsabs !! absolute accuracy requested + real(wp), intent(in) :: Epsrel !! relative accuracy requested. + !! if `epsabs<=0` + !! and `epsrel=2` + !! if `limit<2`, the routine will end with ier = 6. + real(wp), intent(out) :: Result !! approximation to the integral + real(wp), intent(out) :: Abserr !! estimate of the modulus of the absolute error, + !! which should equal or exceed `abs(i-result)` + integer, intent(out) :: Neval !! number of integrand evaluations + integer, intent(out) :: Ier !! * ier = 0 normal and reliable termination of the + !! routine. it is assumed that the requested + !! accuracy has been achieved. + !! * ier>0 abnormal termination of the routine + !! the estimates for the integral and error + !! are less reliable. it is assumed that the + !! requested accuracy has not been achieved. + !! error messages + !! * ier = 1 maximum number of subdivisions allowed + !! has been achieved. one can allow more + !! subdivisions by increasing the value of + !! limit. however, if this yields no + !! improvement, it is advised to analyze the + !! integrand in order to determine the + !! integration difficulties which prevent the + !! requested tolerance from being achieved. + !! in case of a jump discontinuity or a local + !! singularity of algebraico-logarithmic type + !! at one or more interior points of the + !! integration range, one should proceed by + !! splitting up the interval at these + !! points and calling the integrator on the + !! subranges. + !! * ier = 2 the occurrence of roundoff error is + !! detected, which prevents the requested + !! tolerance from being achieved. + !! * ier = 3 extremely bad integrand behaviour occurs + !! at some points of the integration + !! interval. + !! * ier = 6 the input is invalid, because + !! `b<=a` or `alfa<=(-1)` or `beta<=(-1)`, or + !! `integr<1` or `integr>4`, or + !! `epsabs<=0` and + !! `epsrel 4 .or. Limit < 2)) then + Ier = 0 + + ! compute the modified chebyshev moments. + + call dqmomo(Alfa, Beta, ri, rj, rg, rh, Integr) + + ! integrate over the intervals (a,(a+b)/2) and ((a+b)/2,b). + + centre = 0.5_wp*(b + a) + call dqc25s(f, a, b, a, centre, Alfa, Beta, ri, rj, rg, rh, area1, error1, & + resas1, Integr, nev) + Neval = nev + call dqc25s(f, a, b, centre, b, Alfa, Beta, ri, rj, rg, rh, area2, error2, & + resas2, Integr, nev) + Last = 2 + Neval = Neval + nev + Result = area1 + area2 + Abserr = error1 + error2 + + ! test on accuracy. + + errbnd = max(Epsabs, Epsrel*abs(Result)) + + ! initialization + + if (error2 > error1) then + Alist(1) = centre + Alist(2) = a + Blist(1) = b + Blist(2) = centre + Rlist(1) = area2 + Rlist(2) = area1 + Elist(1) = error2 + Elist(2) = error1 + else + Alist(1) = a + Alist(2) = centre + Blist(1) = centre + Blist(2) = b + Rlist(1) = area1 + Rlist(2) = area2 + Elist(1) = error1 + Elist(2) = error2 + end if + Iord(1) = 1 + Iord(2) = 2 + if (Limit == 2) Ier = 1 + if (Abserr > errbnd .and. Ier /= 1) then + errmax = Elist(1) + maxerr = 1 + nrmax = 1 + area = Result + errsum = Abserr + iroff1 = 0 + iroff2 = 0 + + ! main do-loop + + do Last = 3, Limit + + ! bisect the subinterval with largest error estimate. + + a1 = Alist(maxerr) + b1 = 0.5_wp*(Alist(maxerr) + Blist(maxerr)) + a2 = b1 + b2 = Blist(maxerr) + + call dqc25s(f, a, b, a1, b1, Alfa, Beta, ri, rj, rg, rh, area1, & + error1, resas1, Integr, nev) + Neval = Neval + nev + call dqc25s(f, a, b, a2, b2, Alfa, Beta, ri, rj, rg, rh, area2, & + error2, resas2, Integr, nev) + Neval = Neval + nev + + ! improve previous approximations integral and error + ! and test for accuracy. + + area12 = area1 + area2 + erro12 = error1 + error2 + errsum = errsum + erro12 - errmax + area = area + area12 - Rlist(maxerr) + if (a /= a1 .and. b /= b2) then + if (resas1 /= error1 .and. resas2 /= error2) then + ! test for roundoff error. + if (abs(Rlist(maxerr) - area12) & + < 0.1e-4_wp*abs(area12) .and. & + erro12 >= 0.99_wp*errmax) iroff1 = iroff1 + 1 + if (Last > 10 .and. erro12 > errmax) & + iroff2 = iroff2 + 1 + end if + end if + Rlist(maxerr) = area1 + Rlist(Last) = area2 + + ! test on accuracy. + + errbnd = max(Epsabs, Epsrel*abs(area)) + if (errsum > errbnd) then + + ! set error flag in the case that the number of interval + ! bisections exceeds limit. + + if (Last == Limit) Ier = 1 + + ! set error flag in the case of roundoff error. + + if (iroff1 >= 6 .or. iroff2 >= 20) Ier = 2 + + ! set error flag in the case of bad integrand behaviour + ! at interior points of integration range. + + if (max(abs(a1), abs(b2)) & + <= (1.0_wp + 100.0_wp*epmach) & + *(abs(a2) + 1000.0_wp*uflow)) Ier = 3 + end if + + ! append the newly-created intervals to the list. + + if (error2 > error1) then + Alist(maxerr) = a2 + Alist(Last) = a1 + Blist(Last) = b1 + Rlist(maxerr) = area2 + Rlist(Last) = area1 + Elist(maxerr) = error2 + Elist(Last) = error1 + else + Alist(Last) = a2 + Blist(maxerr) = b1 + Blist(Last) = b2 + Elist(maxerr) = error1 + Elist(Last) = error2 + end if + + ! call subroutine dqpsrt to maintain the descending ordering + ! in the list of error estimates and select the subinterval + ! with largest error estimate (to be bisected next). + + call dqpsrt(Limit, Last, maxerr, errmax, Elist, Iord, nrmax) + ! ***jump out of do-loop + if (Ier /= 0 .or. errsum <= errbnd) exit + end do + + ! compute final result. + Result = 0.0_wp + do k = 1, Last + Result = Result + Rlist(k) + end do + Abserr = errsum + end if + end if + + end subroutine dqawse +!******************************************************************************** + +!******************************************************************************** +!> +! 1D integral for Cauchy principal values using a 25 point quadrature rule +! +! to compute i = integral of `f*w` over `(a,b)` with +! error estimate, where `w(x) = 1/(x-c)` +! +!### History +! * QUADPACK: date written 810101, revision date 830518 (yymmdd) + + subroutine dqc25c(f, a, b, c, Result, Abserr, Krul, Neval) + implicit none + + procedure(func) :: f !! function subprogram defining the integrand function `f(x)`. + real(wp), intent(in) :: a !! left end point of the integration interval + real(wp), intent(in) :: b !! right end point of the integration interval, `b>a` + real(wp), intent(in) :: c !! parameter in the weight function + real(wp), intent(out) :: Result !! approximation to the integral. + !! `result` is computed by using a generalized + !! clenshaw-curtis method if `c` lies within ten percent + !! of the integration interval. in the other case the + !! 15-point kronrod rule obtained by optimal addition + !! of abscissae to the 7-point gauss rule, is applied. + real(wp), intent(out) :: Abserr !! estimate of the modulus of the absolute error, + !! which should equal or exceed `abs(i-result)` + integer, intent(inout) :: Krul !! key which is decreased by 1 if the 15-point + !! gauss-kronrod scheme has been used + integer, intent(out) :: Neval !! number of integrand evaluations + + real(wp) :: ak22, amom0, amom1, amom2, cc, & + p2, p3, p4, resabs, resasc, u + integer :: i, isym, k + real(wp) :: fval(25) !! value of the function `f` at the points + !! `cos(k*pi/24)`, `k = 0, ..., 24` + real(wp) :: cheb12(13) !! chebyshev series expansion coefficients, + !! for the function `f`, of degree 12 + real(wp) :: cheb24(25) !! chebyshev series expansion coefficients, + !! for the function `f`, of degree 24 + real(wp) :: res12 !! approximation to the integral corresponding + !! to the use of cheb12 + real(wp) :: res24 !! approximation to the integral corresponding + !! to the use of cheb24 + real(wp) :: hlgth !! half-length of the interval + real(wp) :: centr !! mid point of the interval + + integer,parameter :: kp = 0 !! unused variable for [[dqwgtc]] + + real(wp), dimension(11), parameter :: x = [(cos(k*pi/24.0_wp), k=1, 11)] + !! the vector x contains the values `cos(k*pi/24)`, + !! `k = 1, ..., 11`, to be used for the chebyshev series + !! expansion of `f` + + ! check the position of c. + + cc = (2.0_wp*c - b - a)/(b - a) + if (abs(cc) < 1.1_wp) then + + ! use the generalized clenshaw-curtis method. + + hlgth = 0.5_wp*(b - a) + centr = 0.5_wp*(b + a) + Neval = 25 + fval(1) = 0.5_wp*f(hlgth + centr) + fval(13) = f(centr) + fval(25) = 0.5_wp*f(centr - hlgth) + do i = 2, 12 + u = hlgth*x(i - 1) + isym = 26 - i + fval(i) = f(u + centr) + fval(isym) = f(centr - u) + end do + + ! compute the chebyshev series expansion. + + call dqcheb(x, fval, cheb12, cheb24) + + ! the modified chebyshev moments are computed by forward + ! recursion, using amom0 and amom1 as starting values. + + amom0 = log(abs((1.0_wp - cc)/(1.0_wp + cc))) + amom1 = 2.0_wp + cc*amom0 + res12 = cheb12(1)*amom0 + cheb12(2)*amom1 + res24 = cheb24(1)*amom0 + cheb24(2)*amom1 + do k = 3, 13 + amom2 = 2.0_wp*cc*amom1 - amom0 + ak22 = (k - 2)*(k - 2) + if ((k/2)*2 == k) amom2 = amom2 - 4.0_wp/(ak22 - 1.0_wp) + res12 = res12 + cheb12(k)*amom2 + res24 = res24 + cheb24(k)*amom2 + amom0 = amom1 + amom1 = amom2 + end do + do k = 14, 25 + amom2 = 2.0_wp*cc*amom1 - amom0 + ak22 = (k - 2)*(k - 2) + if ((k/2)*2 == k) amom2 = amom2 - 4.0_wp/(ak22 - 1.0_wp) + res24 = res24 + cheb24(k)*amom2 + amom0 = amom1 + amom1 = amom2 + end do + Result = res24 + Abserr = abs(res24 - res12) + else + + ! apply the 15-point gauss-kronrod scheme. + + ! dqwgtc - external function subprogram defining the weight function + + Krul = Krul - 1 + call dqk15w(f, dqwgtc, c, p2, p3, p4, kp, a, b, Result, Abserr, resabs, & + resasc) + Neval = 15 + if (resasc == Abserr) Krul = Krul + 1 + end if + + end subroutine dqc25c +!******************************************************************************** + +!******************************************************************************** +!> +! 1D integral for sin/cos integrand using a 25 point quadrature rule +! +! to compute the integral i=integral of `f(x)` over `(a,b)` +! where `w(x) = cos(omega*x)` or `w(x)=sin(omega*x)` and to +! compute j = integral of `abs(f)` over `(a,b)`. for small value +! of `omega` or small intervals `(a,b)` the 15-point gauss-kronrod +! rule is used. otherwise a generalized clenshaw-curtis +! method is used. +! +!### History +! * QUADPACK: date written 810101, revision date 211011 (yymmdd) + + subroutine dqc25f(f, a, b, Omega, Integr, Nrmom, Maxp1, Ksave, Result, & + Abserr, Neval, Resabs, Resasc, Momcom, Chebmo) + implicit none + + procedure(func) :: f !! function subprogram defining the integrand + !! function `f(x)`. + real(wp), intent(in) :: a !! lower limit of integration + real(wp), intent(in) :: b !! upper limit of integration + real(wp), intent(in) :: Omega !! parameter in the weight function + integer, intent(in) :: Integr !! indicates which weight function is to be used + !! + !! * integr = 1 `w(x) = cos(omega*x)` + !! * integr = 2 `w(x) = sin(omega*x)` + integer, intent(in) :: Nrmom !! the length of interval `(a,b)` is equal to the length + !! of the original integration interval divided by + !! `2**nrmom` (we suppose that the routine is used in an + !! adaptive integration process, otherwise set + !! nrmom = 0). `nrmom` must be zero at the first call. + integer, intent(in) :: Maxp1 !! gives an upper bound on the number of chebyshev + !! moments which can be stored, i.e. for the + !! intervals of lengths `abs(bb-aa)*2**(-l)`, + !! `l = 0,1,2, ..., maxp1-2`. + integer, intent(in) :: Ksave !! key which is one when the moments for the + !! current interval have been computed + real(wp), intent(out) :: Result !! approximation to the integral i + real(wp), intent(out) :: Abserr !! estimate of the modulus of the absolute + !! error, which should equal or exceed `abs(i-result)` + integer, intent(out) :: Neval !! number of integrand evaluations + real(wp), intent(out) :: Resabs !! approximation to the integral j + real(wp), intent(out) :: Resasc !! approximation to the integral of `abs(f-i/(b-a))` + integer, intent(inout) :: Momcom !! for each interval length we need to compute the + !! chebyshev moments. momcom counts the number of + !! intervals for which these moments have already been + !! computed. if `nrmom 2.0_wp) then + + ! compute the integral using the generalized clenshaw- + ! curtis method. + + conc = hlgth*cos(centr*Omega) + cons = hlgth*sin(centr*Omega) + Resasc = oflow + Neval = 25 + + ! check whether the chebyshev moments for this interval + ! have already been computed. + + if (Nrmom >= Momcom .and. Ksave /= 1) then + + ! compute a new set of chebyshev moments. + + m = Momcom + 1 + par2 = parint*parint + par22 = par2 + 2.0_wp + sinpar = sin(parint) + cospar = cos(parint) + + ! compute the chebyshev moments with respect to cosine. + + v(1) = 2.0_wp*sinpar/parint + v(2) = (8.0_wp*cospar + (par2 + par2 - 8.0_wp)*sinpar/parint) & + /par2 + v(3) = (32.0_wp*(par2 - 12.0_wp)*cospar + (2.0_wp*((par2 - & + 80.0_wp)*par2 + 192.0_wp)*sinpar)/parint)/(par2*par2) + ac = 8.0_wp*cospar + as = 24.0_wp*parint*sinpar + if (abs(parint) > 24.0_wp) then + + ! compute the chebyshev moments by means of forward + ! recursion. + + an = 4.0_wp + do i = 4, 13 + an2 = an*an + v(i) = ((an2 - 4.0_wp)*(2.0_wp*(par22 - an2 - an2)*v(i - 1) - & + ac) + as - par2*(an + 1.0_wp)*(an + 2.0_wp)*v(i - 2)) & + /(par2*(an - 1.0_wp)*(an - 2.0_wp)) + an = an + 2.0_wp + end do + else + + ! compute the chebyshev moments as the solutions of a + ! boundary value problem with 1 initial value (v(3)) and 1 + ! end value (computed using an asymptotic formula). + + noequ = 25 + noeq1 = noequ - 1 + an = 6.0_wp + do k = 1, noeq1 + an2 = an*an + d(k) = -2.0_wp*(an2 - 4.0_wp)*(par22 - an2 - an2) + d2(k) = (an - 1.0_wp)*(an - 2.0_wp)*par2 + d1(k + 1) = (an + 3.0_wp)*(an + 4.0_wp)*par2 + v(k + 3) = as - (an2 - 4.0_wp)*ac + an = an + 2.0_wp + end do + an2 = an*an + d(noequ) = -2.0_wp*(an2 - 4.0_wp)*(par22 - an2 - an2) + v(noequ + 3) = as - (an2 - 4.0_wp)*ac + v(4) = v(4) - 56.0_wp*par2*v(3) + ass = parint*sinpar + asap = (((((210.0_wp*par2 - 1.0_wp)*cospar - (105.0_wp* & + par2 - 63.0_wp)*ass)/an2 - (1.0_wp - 15.0_wp*par2) & + *cospar + 15.0_wp*ass)/an2 - cospar + 3.0_wp*ass) & + /an2 - cospar)/an2 + v(noequ + 3) = v(noequ + 3) - 2.0_wp*asap*par2*(an - 1.0_wp) & + *(an - 2.0_wp) + + ! solve the tridiagonal system by means of gaussian + ! elimination with partial pivoting. + + call dgtsl(noequ, d1, d, d2, v(4), iers) + end if + do j = 1, 13 + Chebmo(m, 2*j - 1) = v(j) + end do + + ! compute the chebyshev moments with respect to sine. + + v(1) = 2.0_wp*(sinpar - parint*cospar)/par2 + v(2) = (18.0_wp - 48.0_wp/par2)*sinpar/par2 + & + (-2.0_wp + 48.0_wp/par2)*cospar/parint + ac = -24.0_wp*parint*cospar + as = -8.0_wp*sinpar + if (abs(parint) > 24.0_wp) then + + ! compute the chebyshev moments by means of forward recursion. + + an = 3.0_wp + do i = 3, 12 + an2 = an*an + v(i) = ((an2 - 4.0_wp)*(2.0_wp*(par22 - an2 - an2)*v(i - 1) + & + as) + ac - par2*(an + 1.0_wp)*(an + 2.0_wp)*v(i - 2)) & + /(par2*(an - 1.0_wp)*(an - 2.0_wp)) + an = an + 2.0_wp + end do + else + + ! compute the chebyshev moments as the solutions of a boundary + ! value problem with 1 initial value (v(2)) and 1 end value + ! (computed using an asymptotic formula). + + an = 5.0_wp + do k = 1, noeq1 + an2 = an*an + d(k) = -2.0_wp*(an2 - 4.0_wp)*(par22 - an2 - an2) + d2(k) = (an - 1.0_wp)*(an - 2.0_wp)*par2 + d1(k + 1) = (an + 3.0_wp)*(an + 4.0_wp)*par2 + v(k + 2) = ac + (an2 - 4.0_wp)*as + an = an + 2.0_wp + end do + an2 = an*an + d(noequ) = -2.0_wp*(an2 - 4.0_wp)*(par22 - an2 - an2) + v(noequ + 2) = ac + (an2 - 4.0_wp)*as + v(3) = v(3) - 42.0_wp*par2*v(2) + ass = parint*cospar + asap = (((((105.0_wp*par2 - 63.0_wp)*ass + (210.0_wp*par2 - & + 1.0_wp)*sinpar)/an2 + (15.0_wp*par2 - 1.0_wp) & + *sinpar - 15.0_wp*ass)/an2 - 3.0_wp*ass - sinpar) & + /an2 - sinpar)/an2 + v(noequ + 2) = v(noequ + 2) - 2.0_wp*asap*par2*(an - 1.0_wp) & + *(an - 2.0_wp) + + ! solve the tridiagonal system by means of gaussian + ! elimination with partial pivoting. + + call dgtsl(noequ, d1, d, d2, v(3), iers) + end if + do j = 1, 12 + Chebmo(m, 2*j) = v(j) + end do + end if + if (Nrmom < Momcom) m = Nrmom + 1 + if (Momcom < (Maxp1 - 1) .and. Nrmom >= Momcom) Momcom = Momcom + 1 + + ! compute the coefficients of the chebyshev expansions + ! of degrees 12 and 24 of the function f. + + fval(1) = 0.5_wp*f(centr + hlgth) + fval(13) = f(centr) + fval(25) = 0.5_wp*f(centr - hlgth) + do i = 2, 12 + isym = 26 - i + fval(i) = f(hlgth*x(i - 1) + centr) + fval(isym) = f(centr - hlgth*x(i - 1)) + end do + call dqcheb(x, fval, cheb12, cheb24) + + ! compute the integral and error estimates. + + resc12 = cheb12(13)*Chebmo(m, 13) + ress12 = 0.0_wp + k = 11 + do j = 1, 6 + resc12 = resc12 + cheb12(k)*Chebmo(m, k) + ress12 = ress12 + cheb12(k + 1)*Chebmo(m, k + 1) + k = k - 2 + end do + resc24 = cheb24(25)*Chebmo(m, 25) + ress24 = 0.0_wp + Resabs = abs(cheb24(25)) + k = 23 + do j = 1, 12 + resc24 = resc24 + cheb24(k)*Chebmo(m, k) + ress24 = ress24 + cheb24(k + 1)*Chebmo(m, k + 1) + Resabs = Resabs + abs(cheb24(k)) + abs(cheb24(k + 1)) + k = k - 2 + end do + estc = abs(resc24 - resc12) + ests = abs(ress24 - ress12) + Resabs = Resabs*abs(hlgth) + if (Integr == 2) then + Result = conc*ress24 + cons*resc24 + Abserr = abs(conc*ests) + abs(cons*estc) + else + Result = conc*resc24 - cons*ress24 + Abserr = abs(conc*estc) + abs(cons*ests) + end if + else + call dqk15w(f, dqwgtf, Omega, p2, p3, p4, Integr, a, b, Result, Abserr, & + Resabs, Resasc) + Neval = 15 + end if + + end subroutine dqc25f +!******************************************************************************** + +!******************************************************************************** +!> +! 25-point clenshaw-curtis integration +! +! to compute i = integral of `f*w` over `(bl,br)`, with error +! estimate, where the weight function `w` has a singular +! behaviour of algebraico-logarithmic type at the points +! `a` and/or `b`. `(bl,br)` is a part of `(a,b)`. +! +!### History +! * QUADPACK: date written 810101, revision date 830518 (yymmdd) + + subroutine dqc25s(f, a, b, Bl, Br, Alfa, Beta, Ri, Rj, Rg, Rh, Result, Abserr, & + Resasc, Integr, Nev) + implicit none + + procedure(func) :: f !! function subprogram defining the integrand f(x). + real(wp), intent(in) :: a !! left end point of the original interval + real(wp), intent(in) :: b !! right end point of the original interval, `b>a` + real(wp), intent(in) :: Bl !! lower limit of integration, `bl>=a` + real(wp), intent(in) :: Br !! upper limit of integration, `br<=b` + real(wp), intent(in) :: Alfa !! parameter in the weight function + real(wp), intent(in) :: Beta !! parameter in the weight function + real(wp), intent(in) :: Ri(25) !! modified chebyshev moments for the application + !! of the generalized clenshaw-curtis + !! method (computed in subroutine [[dqmomo]]) + real(wp), intent(in) :: Rj(25) !! modified chebyshev moments for the application + !! of the generalized clenshaw-curtis + !! method (computed in subroutine [[dqmomo]]) + real(wp), intent(in) :: Rg(25) !! modified chebyshev moments for the application + !! of the generalized clenshaw-curtis + !! method (computed in subroutine [[dqmomo]]) + real(wp), intent(in) :: Rh(25) !! modified chebyshev moments for the application + !! of the generalized clenshaw-curtis + !! method (computed in subroutine [[dqmomo]]) + real(wp), intent(out) :: Result !! approximation to the integral + !! `result` is computed by using a generalized + !! clenshaw-curtis method if `b1 = a` or `br = b`. + !! in all other cases the 15-point kronrod + !! rule is applied, obtained by optimal addition of + !! abscissae to the 7-point gauss rule. + real(wp), intent(out) :: Abserr !! estimate of the modulus of the absolute error, + !! which should equal or exceed `abs(i-result)` + real(wp), intent(out) :: Resasc !! approximation to the integral of abs(f*w-i/(b-a)) + integer, intent(in) :: Integr !! which determines the weight function + !! * = 1 `w(x) = (x-a)**alfa*(b-x)**beta` + !! * = 2 `w(x) = (x-a)**alfa*(b-x)**beta*log(x-a)` + !! * = 3 `w(x) = (x-a)**alfa*(b-x)**beta*log(b-x)` + !! * = 4 `w(x) = (x-a)**alfa*(b-x)**beta*log(x-a)*log(b-x)` + integer, intent(out) :: Nev !! number of integrand evaluations + + real(wp) :: cheb12(13) !! coefficients of the chebyshev series expansion + !! of degree 12, for the function `f`, in the + !! interval `(bl,br)` + real(wp) :: cheb24(25) !! coefficients of the chebyshev series expansion + !! of degree 24, for the function `f`, in the + !! interval `(bl,br)` + real(wp) :: fval(25) !! value of the function f at the points + !! `(br-bl)*0.5*cos(k*pi/24)+(br+bl)*0.5` + !! `k = 0, ..., 24` + real(wp) :: res12 !! approximation to the integral obtained from `cheb12` + real(wp) :: res24 !! approximation to the integral obtained from `cheb24` + real(wp) :: hlgth !! half-length of the interval `(bl,br)` + real(wp) :: centr !! mid point of the interval `(bl,br)` + integer :: k !! counter for `x` + real(wp) :: dc, factor, fix, resabs, u + integer :: i, isym + + real(wp), dimension(11), parameter :: x = [(cos(k*pi/24.0_wp), k=1, 11)] + !! the vector x contains the values `cos(k*pi/24)`, + !! `k = 1, ..., 11`, to be used for the chebyshev series + !! expansion of `f` + + Nev = 25 + if (Bl == a .and. (Alfa /= 0.0_wp .or. Integr == 2 .or. Integr == 4)) & + then + + ! this part of the program is executed only if a = bl. + + ! compute the chebyshev series expansion of the + ! following function + ! f1 = (0.5*(b+b-br-a)-0.5*(br-a)*x)**beta + ! *f(0.5*(br-a)*x+0.5*(br+a)) + + hlgth = 0.5_wp*(Br - Bl) + centr = 0.5_wp*(Br + Bl) + fix = b - centr + fval(1) = 0.5_wp*f(hlgth + centr)*(fix - hlgth)**Beta + fval(13) = f(centr)*(fix**Beta) + fval(25) = 0.5_wp*f(centr - hlgth)*(fix + hlgth)**Beta + do i = 2, 12 + u = hlgth*x(i - 1) + isym = 26 - i + fval(i) = f(u + centr)*(fix - u)**Beta + fval(isym) = f(centr - u)*(fix + u)**Beta + end do + factor = hlgth**(Alfa + 1.0_wp) + Result = 0.0_wp + Abserr = 0.0_wp + res12 = 0.0_wp + res24 = 0.0_wp + if (Integr > 2) then + + ! compute the chebyshev series expansion of the + ! following function + ! f4 = f1*log(0.5*(b+b-br-a)-0.5*(br-a)*x) + + fval(1) = fval(1)*log(fix - hlgth) + fval(13) = fval(13)*log(fix) + fval(25) = fval(25)*log(fix + hlgth) + do i = 2, 12 + u = hlgth*x(i - 1) + isym = 26 - i + fval(i) = fval(i)*log(fix - u) + fval(isym) = fval(isym)*log(fix + u) + end do + call dqcheb(x, fval, cheb12, cheb24) + + ! integr = 3 (or 4) + + do i = 1, 13 + res12 = res12 + cheb12(i)*Ri(i) + res24 = res24 + cheb24(i)*Ri(i) + end do + do i = 14, 25 + res24 = res24 + cheb24(i)*Ri(i) + end do + if (Integr /= 3) then + + ! integr = 4 + + dc = log(Br - Bl) + Result = res24*dc + Abserr = abs((res24 - res12)*dc) + res12 = 0.0_wp + res24 = 0.0_wp + do i = 1, 13 + res12 = res12 + cheb12(i)*Rg(i) + res24 = res24 + cheb24(i)*Rg(i) + end do + do i = 14, 25 + res24 = res24 + cheb24(i)*Rg(i) + end do + end if + else + call dqcheb(x, fval, cheb12, cheb24) + + ! integr = 1 (or 2) + + do i = 1, 13 + res12 = res12 + cheb12(i)*Ri(i) + res24 = res24 + cheb24(i)*Ri(i) + end do + do i = 14, 25 + res24 = res24 + cheb24(i)*Ri(i) + end do + if (Integr /= 1) then + + ! integr = 2 + + dc = log(Br - Bl) + Result = res24*dc + Abserr = abs((res24 - res12)*dc) + res12 = 0.0_wp + res24 = 0.0_wp + do i = 1, 13 + res12 = res12 + cheb12(i)*Rg(i) + res24 = res12 + cheb24(i)*Rg(i) + end do + do i = 14, 25 + res24 = res24 + cheb24(i)*Rg(i) + end do + end if + end if + Result = (Result + res24)*factor + Abserr = (Abserr + abs(res24 - res12))*factor + elseif (Br == b .and. (Beta /= 0.0_wp .or. Integr == 3 .or. Integr == 4)) then + + ! this part of the program is executed only if b = br. + + ! compute the chebyshev series expansion of the + ! following function + ! f2 = (0.5*(b+bl-a-a)+0.5*(b-bl)*x)**alfa + ! *f(0.5*(b-bl)*x+0.5*(b+bl)) + + hlgth = 0.5_wp*(Br - Bl) + centr = 0.5_wp*(Br + Bl) + fix = centr - a + fval(1) = 0.5_wp*f(hlgth + centr)*(fix + hlgth)**Alfa + fval(13) = f(centr)*(fix**Alfa) + fval(25) = 0.5_wp*f(centr - hlgth)*(fix - hlgth)**Alfa + do i = 2, 12 + u = hlgth*x(i - 1) + isym = 26 - i + fval(i) = f(u + centr)*(fix + u)**Alfa + fval(isym) = f(centr - u)*(fix - u)**Alfa + end do + factor = hlgth**(Beta + 1.0_wp) + Result = 0.0_wp + Abserr = 0.0_wp + res12 = 0.0_wp + res24 = 0.0_wp + if (Integr == 2 .or. Integr == 4) then + + ! compute the chebyshev series expansion of the + ! following function + ! f3 = f2*log(0.5*(b-bl)*x+0.5*(b+bl-a-a)) + + fval(1) = fval(1)*log(hlgth + fix) + fval(13) = fval(13)*log(fix) + fval(25) = fval(25)*log(fix - hlgth) + do i = 2, 12 + u = hlgth*x(i - 1) + isym = 26 - i + fval(i) = fval(i)*log(u + fix) + fval(isym) = fval(isym)*log(fix - u) + end do + call dqcheb(x, fval, cheb12, cheb24) + + ! integr = 2 (or 4) + + do i = 1, 13 + res12 = res12 + cheb12(i)*Rj(i) + res24 = res24 + cheb24(i)*Rj(i) + end do + do i = 14, 25 + res24 = res24 + cheb24(i)*Rj(i) + end do + if (Integr /= 2) then + dc = log(Br - Bl) + Result = res24*dc + Abserr = abs((res24 - res12)*dc) + res12 = 0.0_wp + res24 = 0.0_wp + + ! integr = 4 + + do i = 1, 13 + res12 = res12 + cheb12(i)*Rh(i) + res24 = res24 + cheb24(i)*Rh(i) + end do + do i = 14, 25 + res24 = res24 + cheb24(i)*Rh(i) + end do + end if + else + + ! integr = 1 (or 3) + + call dqcheb(x, fval, cheb12, cheb24) + do i = 1, 13 + res12 = res12 + cheb12(i)*Rj(i) + res24 = res24 + cheb24(i)*Rj(i) + end do + do i = 14, 25 + res24 = res24 + cheb24(i)*Rj(i) + end do + if (Integr /= 1) then + + ! integr = 3 + + dc = log(Br - Bl) + Result = res24*dc + Abserr = abs((res24 - res12)*dc) + res12 = 0.0_wp + res24 = 0.0_wp + do i = 1, 13 + res12 = res12 + cheb12(i)*Rh(i) + res24 = res24 + cheb24(i)*Rh(i) + end do + do i = 14, 25 + res24 = res24 + cheb24(i)*Rh(i) + end do + end if + end if + Result = (Result + res24)*factor + Abserr = (Abserr + abs(res24 - res12))*factor + else + + ! if a>bl and b +! chebyshev series expansion +! +! this routine computes the chebyshev series expansion +! of degrees 12 and 24 of a function using a +! fast fourier transform method +! +! * `f(x) = sum(k=1,..,13)` `(cheb12(k)*t(k-1,x))` +! * `f(x) = sum(k=1,..,25)` `(cheb24(k)*t(k-1,x))` +! +! where `t(k,x)` is the chebyshev polynomial of degree `k`. +! +!### See also +! * [[dqc25c]], [[dqc25f]], [[dqc25s]] +! +!### History +! * QUADPACK: revision date 830518 (yymmdd) + + subroutine dqcheb(x, Fval, Cheb12, Cheb24) + implicit none + + real(wp), intent(in) :: x(11) !! vector of dimension 11 containing the + !! values `cos(k*pi/24), k = 1, ..., 11` + real(wp), intent(inout) :: Fval(25) !! vector of dimension 25 containing the + !! function values at the points + !! `(b+a+(b-a)*cos(k*pi/24))/2, k = 0, ...,24`, + !! where `(a,b)` is the approximation interval. + !! `fval(1)` and `fval(25)` are divided by two + !! (these values are destroyed at output). + real(wp), intent(out) :: Cheb12(13) !! vector of dimension 13 containing the + !! chebyshev coefficients for degree 12 + real(wp), intent(out) :: Cheb24(25) !! vector of dimension 25 containing the + !! chebyshev coefficients for degree 24 + + real(wp) :: alam, alam1, alam2, part1, part2, part3, v(12) + integer :: i, j + + do i = 1, 12 + j = 26 - i + v(i) = Fval(i) - Fval(j) + Fval(i) = Fval(i) + Fval(j) + end do + alam1 = v(1) - v(9) + alam2 = x(6)*(v(3) - v(7) - v(11)) + Cheb12(4) = alam1 + alam2 + Cheb12(10) = alam1 - alam2 + alam1 = v(2) - v(8) - v(10) + alam2 = v(4) - v(6) - v(12) + alam = x(3)*alam1 + x(9)*alam2 + Cheb24(4) = Cheb12(4) + alam + Cheb24(22) = Cheb12(4) - alam + alam = x(9)*alam1 - x(3)*alam2 + Cheb24(10) = Cheb12(10) + alam + Cheb24(16) = Cheb12(10) - alam + part1 = x(4)*v(5) + part2 = x(8)*v(9) + part3 = x(6)*v(7) + alam1 = v(1) + part1 + part2 + alam2 = x(2)*v(3) + part3 + x(10)*v(11) + Cheb12(2) = alam1 + alam2 + Cheb12(12) = alam1 - alam2 + alam = x(1)*v(2) + x(3)*v(4) + x(5)*v(6) + x(7)*v(8) + x(9)*v(10) & + + x(11)*v(12) + Cheb24(2) = Cheb12(2) + alam + Cheb24(24) = Cheb12(2) - alam + alam = x(11)*v(2) - x(9)*v(4) + x(7)*v(6) - x(5)*v(8) + x(3)*v(10) & + - x(1)*v(12) + Cheb24(12) = Cheb12(12) + alam + Cheb24(14) = Cheb12(12) - alam + alam1 = v(1) - part1 + part2 + alam2 = x(10)*v(3) - part3 + x(2)*v(11) + Cheb12(6) = alam1 + alam2 + Cheb12(8) = alam1 - alam2 + alam = x(5)*v(2) - x(9)*v(4) - x(1)*v(6) - x(11)*v(8) + x(3)*v(10) & + + x(7)*v(12) + Cheb24(6) = Cheb12(6) + alam + Cheb24(20) = Cheb12(6) - alam + alam = x(7)*v(2) - x(3)*v(4) - x(11)*v(6) + x(1)*v(8) - x(9)*v(10) & + - x(5)*v(12) + Cheb24(8) = Cheb12(8) + alam + Cheb24(18) = Cheb12(8) - alam + do i = 1, 6 + j = 14 - i + v(i) = Fval(i) - Fval(j) + Fval(i) = Fval(i) + Fval(j) + end do + alam1 = v(1) + x(8)*v(5) + alam2 = x(4)*v(3) + Cheb12(3) = alam1 + alam2 + Cheb12(11) = alam1 - alam2 + Cheb12(7) = v(1) - v(5) + alam = x(2)*v(2) + x(6)*v(4) + x(10)*v(6) + Cheb24(3) = Cheb12(3) + alam + Cheb24(23) = Cheb12(3) - alam + alam = x(6)*(v(2) - v(4) - v(6)) + Cheb24(7) = Cheb12(7) + alam + Cheb24(19) = Cheb12(7) - alam + alam = x(10)*v(2) - x(6)*v(4) + x(2)*v(6) + Cheb24(11) = Cheb12(11) + alam + Cheb24(15) = Cheb12(11) - alam + do i = 1, 3 + j = 8 - i + v(i) = Fval(i) - Fval(j) + Fval(i) = Fval(i) + Fval(j) + end do + Cheb12(5) = v(1) + x(8)*v(3) + Cheb12(9) = Fval(1) - x(8)*Fval(3) + alam = x(4)*v(2) + Cheb24(5) = Cheb12(5) + alam + Cheb24(21) = Cheb12(5) - alam + alam = x(8)*Fval(2) - Fval(4) + Cheb24(9) = Cheb12(9) + alam + Cheb24(17) = Cheb12(9) - alam + Cheb12(1) = Fval(1) + Fval(3) + alam = Fval(2) + Fval(4) + Cheb24(1) = Cheb12(1) + alam + Cheb24(25) = Cheb12(1) - alam + Cheb12(13) = v(1) - v(3) + Cheb24(13) = Cheb12(13) + alam = 1.0_wp/6.0_wp + do i = 2, 12 + Cheb12(i) = Cheb12(i)*alam + end do + alam = 0.5_wp*alam + Cheb12(1) = Cheb12(1)*alam + Cheb12(13) = Cheb12(13)*alam + do i = 2, 24 + Cheb24(i) = Cheb24(i)*alam + end do + Cheb24(1) = 0.5_wp*alam*Cheb24(1) + Cheb24(25) = 0.5_wp*alam*Cheb24(25) + + end subroutine dqcheb +!******************************************************************************** + +!******************************************************************************** +!> +! the routine determines the limit of a given sequence of +! approximations, by means of the epsilon algorithm of +! p.wynn. an estimate of the absolute error is also given. +! the condensed epsilon table is computed. only those +! elements needed for the computation of the next diagonal +! are preserved. +! +!### See also +! * [[dqagie]], [[dqagoe]], [[dqagpe]], [[dqagse]] +! +!### History +! * QUADPACK: revision date 830518 (yymmdd). + + subroutine dqelg(n, Epstab, Result, Abserr, Res3la, Nres) + implicit none + + integer, intent(inout) :: n !! epstab(n) contains the new element in the + !! first column of the epsilon table. + real(wp), intent(out) :: Abserr !! estimate of the absolute error computed from + !! result and the 3 previous results + real(wp), intent(inout) :: Epstab(limexp + 2) !! vector of dimension 52 containing the elements + !! of the two lower diagonals of the triangular + !! epsilon table. the elements are numbered + !! starting at the right-hand corner of the + !! triangle. + real(wp), intent(out) :: Result !! resulting approximation to the integral + real(wp), intent(inout) :: Res3la(3) !! vector of dimension 3 containing the last 3 + !! results + integer, intent(inout) :: Nres !! number of calls to the routine + !! (should be zero at first call) + + real(wp) :: delta1, delta2, delta3, epsinf, & + err1, err2, err3, e0, e1, e1abs, & + e2, e3, res, ss, tol1, tol2, tol3 + integer :: i, ib, ib2, ie, indx, k1, k2, k3, num + + integer :: newelm !! number of elements to be computed in the new diagonal + real(wp) :: error !! `error = abs(e1-e0)+abs(e2-e1)+abs(new-e2)` + + ! result is the element in the new diagonal with least value of error + + ! e0 - the 4 elements on which the computation of a new + ! e1 element in the epsilon table is based + ! e2 + ! e3 e0 + ! e3 e1 new + ! e2 + + Nres = Nres + 1 + Abserr = oflow + Result = Epstab(n) + if (n >= 3) then + Epstab(n + 2) = Epstab(n) + newelm = (n - 1)/2 + Epstab(n) = oflow + num = n + k1 = n + do i = 1, newelm + k2 = k1 - 1 + k3 = k1 - 2 + res = Epstab(k1 + 2) + e0 = Epstab(k3) + e1 = Epstab(k2) + e2 = res + e1abs = abs(e1) + delta2 = e2 - e1 + err2 = abs(delta2) + tol2 = max(abs(e2), e1abs)*epmach + delta3 = e1 - e0 + err3 = abs(delta3) + tol3 = max(e1abs, abs(e0))*epmach + if (err2 > tol2 .or. err3 > tol3) then + e3 = Epstab(k1) + Epstab(k1) = e1 + delta1 = e1 - e3 + err1 = abs(delta1) + tol1 = max(e1abs, abs(e3))*epmach + ! if two elements are very close to each other, omit + ! a part of the table by adjusting the value of n + if (err1 > tol1 .and. err2 > tol2 .and. err3 > tol3) then + ss = 1.0_wp/delta1 + 1.0_wp/delta2 - 1.0_wp/delta3 + epsinf = abs(ss*e1) + ! test to detect irregular behaviour in the table, and + ! eventually omit a part of the table adjusting the value + ! of n. + if (epsinf > 0.1e-03_wp) then + ! compute a new element and eventually adjust + ! the value of result. + res = e1 + 1.0_wp/ss + Epstab(k1) = res + k1 = k1 - 2 + error = err2 + abs(res - e2) + err3 + if (error <= Abserr) then + Abserr = error + Result = res + end if + cycle + end if + end if + n = i + i - 1 + ! ***jump out of do-loop + exit + else + ! if e0, e1 and e2 are equal to within machine + ! accuracy, convergence is assumed. + ! result = e2 + ! abserr = abs(e1-e0)+abs(e2-e1) + Result = res + Abserr = err2 + err3 + ! ***jump out of do-loop + Abserr = max(Abserr, 5.0_wp*epmach*abs(Result)) + return + end if + end do + + ! shift the table. + if (n == limexp) n = 2*(limexp/2) - 1 + ib = 1 + if ((num/2)*2 == num) ib = 2 + ie = newelm + 1 + do i = 1, ie + ib2 = ib + 2 + Epstab(ib) = Epstab(ib2) + ib = ib2 + end do + if (num /= n) then + indx = num - n + 1 + do i = 1, n + Epstab(i) = Epstab(indx) + indx = indx + 1 + end do + end if + if (Nres >= 4) then + ! compute error estimate + Abserr = abs(Result - Res3la(3)) + abs(Result - Res3la(2)) & + + abs(Result - Res3la(1)) + Res3la(1) = Res3la(2) + Res3la(2) = Res3la(3) + Res3la(3) = Result + else + Res3la(Nres) = Result + Abserr = oflow + end if + end if + + Abserr = max(Abserr, 5.0_wp*epmach*abs(Result)) + + end subroutine dqelg +!******************************************************************************** + +!******************************************************************************** +!> +! estimate 1D integral on finite interval using a 15 point gauss-kronrod +! rule and give error estimate, non-automatic +! +! to compute i = integral of `f` over `(a,b)`, with error +! estimate j = integral of `abs(f)` over `(a,b)` +! +!### History +! * QUADPACK: date written 800101, revision date 830518 (yymmdd). + + subroutine dqk15(f, a, b, Result, Abserr, Resabs, Resasc) + implicit none + + procedure(func) :: f !! function subprogram defining the integrand function `f(x)`. + real(wp), intent(in) :: a !! lower limit of integration + real(wp), intent(in) :: b !! upper limit of integration + real(wp), intent(out) :: Result !! approximation to the integral i + !! `result` is computed by applying the 15-point + !! kronrod rule (resk) obtained by optimal addition + !! of abscissae to the7-point gauss rule(resg). + real(wp), intent(out) :: Abserr !! estimate of the modulus of the absolute error, + !! which should not exceed `abs(i-result)` + real(wp), intent(out) :: Resabs !! approximation to the integral j + real(wp), intent(out) :: Resasc !! approximation to the integral of `abs(f-i/(b-a))` over `(a,b)` + + real(wp) :: dhlgth, fc, fsum, fv1(7), fv2(7) + integer :: j, jtw, jtwm1 + real(wp) :: centr !! mid point of the interval + real(wp) :: hlgth !! half-length of the interval + real(wp) :: absc !! abscissa + real(wp) :: fval1 !! function value + real(wp) :: fval2 !! function value + real(wp) :: resg !! result of the 7-point gauss formula + real(wp) :: resk !! result of the 15-point kronrod formula + real(wp) :: reskh !! approximation to the mean value of `f` over `(a,b)`, i.e. to `i/(b-a)` + + ! the abscissae and weights are given for the interval (-1,1). + ! because of symmetry only the positive abscissae and their + ! corresponding weights are given. + + real(wp), dimension(4), parameter :: wg = [ & + 1.29484966168869693270611432679082018329e-1_wp, & + 2.79705391489276667901467771423779582487e-1_wp, & + 3.81830050505118944950369775488975133878e-1_wp, & + 4.17959183673469387755102040816326530612e-1_wp] !! weights of the 7-point gauss rule + + real(wp), dimension(8), parameter :: xgk = [ & + 9.91455371120812639206854697526328516642e-1_wp, & + 9.49107912342758524526189684047851262401e-1_wp, & + 8.64864423359769072789712788640926201211e-1_wp, & + 7.41531185599394439863864773280788407074e-1_wp, & + 5.86087235467691130294144838258729598437e-1_wp, & + 4.05845151377397166906606412076961463347e-1_wp, & + 2.07784955007898467600689403773244913480e-1_wp, & + 0.00000000000000000000000000000000000000e0_wp] !! abscissae of the 15-point kronrod rule: + !! + !! * xgk(2), xgk(4), ... abscissae of the 7-point + !! gauss rule + !! * xgk(1), xgk(3), ... abscissae which are optimally + !! added to the 7-point gauss rule + + real(wp), dimension(8), parameter :: wgk = [ & + 2.29353220105292249637320080589695919936e-2_wp, & + 6.30920926299785532907006631892042866651e-2_wp, & + 1.04790010322250183839876322541518017444e-1_wp, & + 1.40653259715525918745189590510237920400e-1_wp, & + 1.69004726639267902826583426598550284106e-1_wp, & + 1.90350578064785409913256402421013682826e-1_wp, & + 2.04432940075298892414161999234649084717e-1_wp, & + 2.09482141084727828012999174891714263698e-1_wp] !! weights of the 15-point kronrod rule + + centr = 0.5_wp*(a + b) + hlgth = 0.5_wp*(b - a) + dhlgth = abs(hlgth) + + ! compute the 15-point kronrod approximation to + ! the integral, and estimate the absolute error. + + fc = f(centr) + resg = fc*wg(4) + resk = fc*wgk(8) + Resabs = abs(resk) + do j = 1, 3 + jtw = j*2 + absc = hlgth*xgk(jtw) + fval1 = f(centr - absc) + fval2 = f(centr + absc) + fv1(jtw) = fval1 + fv2(jtw) = fval2 + fsum = fval1 + fval2 + resg = resg + wg(j)*fsum + resk = resk + wgk(jtw)*fsum + Resabs = Resabs + wgk(jtw)*(abs(fval1) + abs(fval2)) + end do + do j = 1, 4 + jtwm1 = j*2 - 1 + absc = hlgth*xgk(jtwm1) + fval1 = f(centr - absc) + fval2 = f(centr + absc) + fv1(jtwm1) = fval1 + fv2(jtwm1) = fval2 + fsum = fval1 + fval2 + resk = resk + wgk(jtwm1)*fsum + Resabs = Resabs + wgk(jtwm1)*(abs(fval1) + abs(fval2)) + end do + reskh = resk*0.5_wp + Resasc = wgk(8)*abs(fc - reskh) + do j = 1, 7 + Resasc = Resasc + wgk(j) & + *(abs(fv1(j) - reskh) + abs(fv2(j) - reskh)) + end do + Result = resk*hlgth + Resabs = Resabs*dhlgth + Resasc = Resasc*dhlgth + Abserr = abs((resk - resg)*hlgth) + if (Resasc /= 0.0_wp .and. Abserr /= 0.0_wp) & + Abserr = Resasc*min(1.0_wp, (200.0_wp*Abserr/Resasc)**1.5_wp) + if (Resabs > uflow/(50.0_wp*epmach)) & + Abserr = max((epmach*50.0_wp)*Resabs, Abserr) + + end subroutine dqk15 +!******************************************************************************** + +!******************************************************************************** +!> +! estimate 1D integral on (semi)infinite interval using a 15 point +! gauss-kronrod quadrature rule, non-automatic +! +! the original (infinite integration range is mapped +! onto the interval (0,1) and (a,b) is a part of (0,1). +! it is the purpose to compute: +! +! * i = integral of transformed integrand over `(a,b)`, +! * j = integral of abs(transformed integrand) over `(a,b)`. +! +!### History +! * QUADPACK: date written 800101, revision date 830518 (yymmdd). + + subroutine dqk15i(f, Boun, Inf, a, b, Result, Abserr, Resabs, Resasc) + implicit none + + procedure(func) :: f !! function subprogram defining the integrand function `f(x)`. + real(wp), intent(in) :: Boun !! finite bound of original integration + !! range (set to zero if inf = +2) + real(wp), intent(in) :: a !! lower limit for integration over subrange of `(0,1)` + real(wp), intent(in) :: b !! upper limit for integration over subrange of `(0,1)` + integer, intent(in) :: Inf !! * if inf = -1, the original interval is + !! `(-infinity,bound)`, + !! * if inf = +1, the original interval is + !! `(bound,+infinity)`, + !! * if inf = +2, the original interval is + !! `(-infinity,+infinity)` and + !! + !! the integral is computed as the sum of two + !! integrals, one over `(-infinity,0)` and one over + !! `(0,+infinity)`. + real(wp), intent(out) :: Result !! approximation to the integral i. + !! `result` is computed by applying the 15-point + !! kronrod rule(resk) obtained by optimal addition + !! of abscissae to the 7-point gauss rule(resg). + real(wp), intent(out) :: Abserr !! estimate of the modulus of the absolute error, + !! which should equal or exceed `abs(i-result)` + real(wp), intent(out) :: Resabs !! approximation to the integral j + real(wp), intent(out) :: Resasc !! approximation to the integral of + !! `abs((transformed integrand)-i/(b-a))` over `(a,b)` + + real(wp) :: absc, dinf, fc, fsum, fv1(7), fv2(7) + integer :: j + real(wp) :: centr !! mid point of the interval + real(wp) :: hlgth !! half-length of the interval + real(wp) :: absc1 !! abscissa + real(wp) :: absc2 !! abscissa + real(wp) :: tabsc1 !! transformed abscissa + real(wp) :: tabsc2 !! transformed abscissa + real(wp) :: fval1 !! function value + real(wp) :: fval2 !! function value + real(wp) :: resg !! result of the 7-point gauss formula + real(wp) :: resk !! result of the 15-point kronrod formula + real(wp) :: reskh !! approximation to the mean value of the transformed + !! integrand over `(a,b)`, i.e. to `i/(b-a)` + + ! the abscissae and weights are supplied for the interval + ! (-1,1). because of symmetry only the positive abscissae and + ! their corresponding weights are given. + + real(wp), dimension(8), parameter :: wg = [ & + 0.00000000000000000000000000000000000000e0_wp, & + 1.29484966168869693270611432679082018329e-1_wp, & + 0.00000000000000000000000000000000000000e0_wp, & + 2.79705391489276667901467771423779582487e-1_wp, & + 0.00000000000000000000000000000000000000e0_wp, & + 3.81830050505118944950369775488975133878e-1_wp, & + 0.00000000000000000000000000000000000000e0_wp, & + 4.17959183673469387755102040816326530612e-1_wp] !! weights of the 7-point gauss rule, corresponding + !! to the abscissae `xgk(2), xgk(4), ...`. + !! `wg(1), wg(3), ...` are set to zero. + + real(wp), dimension(8), parameter :: xgk = [ & + 9.91455371120812639206854697526328516642e-1_wp, & + 9.49107912342758524526189684047851262401e-1_wp, & + 8.64864423359769072789712788640926201211e-1_wp, & + 7.41531185599394439863864773280788407074e-1_wp, & + 5.86087235467691130294144838258729598437e-1_wp, & + 4.05845151377397166906606412076961463347e-1_wp, & + 2.07784955007898467600689403773244913480e-1_wp, & + 0.00000000000000000000000000000000000000e0_wp] !! abscissae of the 15-point kronrod rule: + !! + !! * xgk(2), xgk(4), ... abscissae of the 7-point + !! gauss rule + !! * xgk(1), xgk(3), ... abscissae which are optimally + !! added to the 7-point gauss rule + + real(wp), dimension(8), parameter :: wgk = [ & + 2.29353220105292249637320080589695919936e-2_wp, & + 6.30920926299785532907006631892042866651e-2_wp, & + 1.04790010322250183839876322541518017444e-1_wp, & + 1.40653259715525918745189590510237920400e-1_wp, & + 1.69004726639267902826583426598550284106e-1_wp, & + 1.90350578064785409913256402421013682826e-1_wp, & + 2.04432940075298892414161999234649084717e-1_wp, & + 2.09482141084727828012999174891714263698e-1_wp] !! weights of the 15-point kronrod rule + + dinf = min(1, Inf) + centr = 0.5_wp*(a + b) + hlgth = 0.5_wp*(b - a) + tabsc1 = Boun + dinf*(1.0_wp - centr)/centr + fval1 = f(tabsc1) + if (Inf == 2) fval1 = fval1 + f(-tabsc1) + fc = (fval1/centr)/centr + + ! compute the 15-point kronrod approximation to + ! the integral, and estimate the error. + + resg = wg(8)*fc + resk = wgk(8)*fc + Resabs = abs(resk) + do j = 1, 7 + absc = hlgth*xgk(j) + absc1 = centr - absc + absc2 = centr + absc + tabsc1 = Boun + dinf*(1.0_wp - absc1)/absc1 + tabsc2 = Boun + dinf*(1.0_wp - absc2)/absc2 + fval1 = f(tabsc1) + fval2 = f(tabsc2) + if (Inf == 2) then + fval1 = fval1 + f(-tabsc1) + fval2 = fval2 + f(-tabsc2) + end if + fval1 = (fval1/absc1)/absc1 + fval2 = (fval2/absc2)/absc2 + fv1(j) = fval1 + fv2(j) = fval2 + fsum = fval1 + fval2 + resg = resg + wg(j)*fsum + resk = resk + wgk(j)*fsum + Resabs = Resabs + wgk(j)*(abs(fval1) + abs(fval2)) + end do + reskh = resk*0.5_wp + Resasc = wgk(8)*abs(fc - reskh) + do j = 1, 7 + Resasc = Resasc + wgk(j) & + *(abs(fv1(j) - reskh) + abs(fv2(j) - reskh)) + end do + Result = resk*hlgth + Resasc = Resasc*hlgth + Resabs = Resabs*hlgth + Abserr = abs((resk - resg)*hlgth) + if (Resasc /= 0.0_wp .and. Abserr /= 0.0_wp) & + Abserr = Resasc*min(1.0_wp, (200.0_wp*Abserr/Resasc)**1.5_wp) + if (Resabs > uflow/(50.0_wp*epmach)) & + Abserr = max((epmach*50.0_wp)*Resabs, Abserr) + + end subroutine dqk15i +!******************************************************************************** + +!******************************************************************************** +!> +! estimate 1D integral with special singular weight functions using +! a 15 point gauss-kronrod quadrature rule +! +! to compute i = integral of `f*w` over `(a,b)`, with error +! estimate j = integral of `abs(f*w)` over `(a,b)` +! +!### History +! * QUADPACK: date written 810101, revision date 830518 (yymmdd). + + subroutine dqk15w(f, w, p1, p2, p3, p4, Kp, a, b, Result, Abserr, Resabs, & + Resasc) + implicit none + + procedure(func) :: f !! function subprogram defining the integrand function `f(x)`. + procedure(weight_func) :: w !! function subprogram defining the integrand weight function `w(x)`. + real(wp), intent(in) :: p1 !! parameter in the weight function + real(wp), intent(in) :: p2 !! parameter in the weight function + real(wp), intent(in) :: p3 !! parameter in the weight function + real(wp), intent(in) :: p4 !! parameter in the weight function + integer, intent(in) :: Kp !! key for indicating the type of weight function + real(wp), intent(in) :: a !! lower limit of integration + real(wp), intent(in) :: b !! upper limit of integration + real(wp), intent(out) :: Result !! approximation to the integral i + !! `result` is computed by applying the 15-point + !! kronrod rule (resk) obtained by optimal addition + !! of abscissae to the 7-point gauss rule (resg). + real(wp), intent(out) :: Abserr !! estimate of the modulus of the absolute error, + !! which should equal or exceed `abs(i-result)` + real(wp), intent(out) :: Resabs !! approximation to the integral of `abs(f)` + real(wp), intent(out) :: Resasc !! approximation to the integral of `abs(f-i/(b-a))` + + real(wp) :: absc1, absc2, dhlgth, fc, fsum, fv1(7), fv2(7) + integer :: j, jtw, jtwm1 + real(wp) :: centr !! mid point of the interval + real(wp) :: hlgth !! half-length of the interval + real(wp) :: absc !! abscissa + real(wp) :: fval1 !! function value + real(wp) :: fval2 !! function value + real(wp) :: resg !! result of the 7-point gauss formula + real(wp) :: resk !! result of the 15-point kronrod formula + real(wp) :: reskh !! approximation to the mean value of f*w over `(a,b)`, i.e. to `i/(b-a)` + + ! the abscissae and weights are given for the interval (-1,1). + ! because of symmetry only the positive abscissae and their + ! corresponding weights are given. + + real(wp), dimension(8), parameter :: xgk = [ & + 9.91455371120812639206854697526328516642e-1_wp, & + 9.49107912342758524526189684047851262401e-1_wp, & + 8.64864423359769072789712788640926201211e-1_wp, & + 7.41531185599394439863864773280788407074e-1_wp, & + 5.86087235467691130294144838258729598437e-1_wp, & + 4.05845151377397166906606412076961463347e-1_wp, & + 2.07784955007898467600689403773244913480e-1_wp, & + 0.00000000000000000000000000000000000000e0_wp] !! abscissae of the 15-point kronrod rule: + !! + !! * xgk(2), xgk(4), ... abscissae of the 7-point + !! gauss rule + !! * xgk(1), xgk(3), ... abscissae which are optimally + !! added to the 7-point gauss rule + + real(wp), dimension(8), parameter :: wgk = [ & + 2.29353220105292249637320080589695919936e-2_wp, & + 6.30920926299785532907006631892042866651e-2_wp, & + 1.04790010322250183839876322541518017444e-1_wp, & + 1.40653259715525918745189590510237920400e-1_wp, & + 1.69004726639267902826583426598550284106e-1_wp, & + 1.90350578064785409913256402421013682826e-1_wp, & + 2.04432940075298892414161999234649084717e-1_wp, & + 2.09482141084727828012999174891714263698e-1_wp] !! weights of the 15-point kronrod rule + + real(wp), dimension(4), parameter :: wg = [ & + 1.29484966168869693270611432679082018329e-1_wp, & + 2.79705391489276667901467771423779582487e-1_wp, & + 3.81830050505118944950369775488975133878e-1_wp, & + 4.17959183673469387755102040816326530612e-1_wp] !! weights of the 7-point gauss rule + + centr = 0.5_wp*(a + b) + hlgth = 0.5_wp*(b - a) + dhlgth = abs(hlgth) + + ! compute the 15-point kronrod approximation to the + ! integral, and estimate the error. + + fc = f(centr)*w(centr, p1, p2, p3, p4, Kp) + resg = wg(4)*fc + resk = wgk(8)*fc + Resabs = abs(resk) + do j = 1, 3 + jtw = j*2 + absc = hlgth*xgk(jtw) + absc1 = centr - absc + absc2 = centr + absc + fval1 = f(absc1)*w(absc1, p1, p2, p3, p4, Kp) + fval2 = f(absc2)*w(absc2, p1, p2, p3, p4, Kp) + fv1(jtw) = fval1 + fv2(jtw) = fval2 + fsum = fval1 + fval2 + resg = resg + wg(j)*fsum + resk = resk + wgk(jtw)*fsum + Resabs = Resabs + wgk(jtw)*(abs(fval1) + abs(fval2)) + end do + do j = 1, 4 + jtwm1 = j*2 - 1 + absc = hlgth*xgk(jtwm1) + absc1 = centr - absc + absc2 = centr + absc + fval1 = f(absc1)*w(absc1, p1, p2, p3, p4, Kp) + fval2 = f(absc2)*w(absc2, p1, p2, p3, p4, Kp) + fv1(jtwm1) = fval1 + fv2(jtwm1) = fval2 + fsum = fval1 + fval2 + resk = resk + wgk(jtwm1)*fsum + Resabs = Resabs + wgk(jtwm1)*(abs(fval1) + abs(fval2)) + end do + reskh = resk*0.5_wp + Resasc = wgk(8)*abs(fc - reskh) + do j = 1, 7 + Resasc = Resasc + wgk(j) & + *(abs(fv1(j) - reskh) + abs(fv2(j) - reskh)) + end do + Result = resk*hlgth + Resabs = Resabs*dhlgth + Resasc = Resasc*dhlgth + Abserr = abs((resk - resg)*hlgth) + if (Resasc /= 0.0_wp .and. Abserr /= 0.0_wp) & + Abserr = Resasc*min(1.0_wp, (200.0_wp*Abserr/Resasc)**1.5_wp) + if (Resabs > uflow/(50.0_wp*epmach)) & + Abserr = max((epmach*50.0_wp)*Resabs, Abserr) + + end subroutine dqk15w +!******************************************************************************** + +!******************************************************************************** +!> +! estimate 1D integral on finite interval using a 21 point +! gauss-kronrod rule and give error estimate, non-automatic +! +! to compute i = integral of `f` over `(a,b)`, with error +! estimate j = integral of `abs(f)` over `(a,b)` +! +!### History +! * QUADPACK: date written 800101, revision date 830518 (yymmdd). + + subroutine dqk21(f, a, b, Result, Abserr, Resabs, Resasc) + implicit none + + procedure(func) :: f !! function subprogram defining the integrand function `f(x)`. + real(wp), intent(in) :: a !! lower limit of integration + real(wp), intent(in) :: b !! upper limit of integration + real(wp), intent(out) :: Result !! approximation to the integral i + !! `result` is computed by applying the 21-point + !! kronrod rule (resk) obtained by optimal addition + !! of abscissae to the 10-point gauss rule (resg). + real(wp), intent(out) :: Abserr !! estimate of the modulus of the absolute error, + !! which should not exceed `abs(i-result)` + real(wp), intent(out) :: Resabs !! approximation to the integral j + real(wp), intent(out) :: Resasc !! approximation to the integral of `abs(f-i/(b-a))` + !! over `(a,b)` + + real(wp) :: dhlgth, fc, fsum, fv1(10), fv2(10) + integer :: j, jtw, jtwm1 + real(wp) :: centr !! mid point of the interval + real(wp) :: hlgth !! half-length of the interval + real(wp) :: absc !! abscissa + real(wp) :: fval1 !! function value + real(wp) :: fval2 !! function value + real(wp) :: resg !! result of the 10-point gauss formula + real(wp) :: resk !! result of the 21-point kronrod formula + real(wp) :: reskh !! approximation to the mean value of `f` over `(a,b)`, i.e. to `i/(b-a)` + + ! the abscissae and weights are given for the interval (-1,1). + ! because of symmetry only the positive abscissae and their + ! corresponding weights are given. + + real(wp), dimension(5), parameter :: wg = [ & + 6.66713443086881375935688098933317928579e-2_wp, & + 1.49451349150580593145776339657697332403e-1_wp, & + 2.19086362515982043995534934228163192459e-1_wp, & + 2.69266719309996355091226921569469352860e-1_wp, & + 2.95524224714752870173892994651338329421e-1_wp] !! weights of the 10-point gauss rule + + real(wp), dimension(11), parameter :: xgk = [ & + 9.95657163025808080735527280689002847921e-1_wp, & + 9.73906528517171720077964012084452053428e-1_wp, & + 9.30157491355708226001207180059508346225e-1_wp, & + 8.65063366688984510732096688423493048528e-1_wp, & + 7.80817726586416897063717578345042377163e-1_wp, & + 6.79409568299024406234327365114873575769e-1_wp, & + 5.62757134668604683339000099272694140843e-1_wp, & + 4.33395394129247190799265943165784162200e-1_wp, & + 2.94392862701460198131126603103865566163e-1_wp, & + 1.48874338981631210884826001129719984618e-1_wp, & + 0.00000000000000000000000000000000000000e0_wp] !! abscissae of the 21-point kronrod rule: + !! + !! * xgk(2), xgk(4), ... abscissae of the 10-point + !! gauss rule + !! * xgk(1), xgk(3), ... abscissae which are optimally + !! added to the 10-point gauss rule + + real(wp), dimension(11), parameter :: wgk = [ & + 1.16946388673718742780643960621920483962e-2_wp, & + 3.25581623079647274788189724593897606174e-2_wp, & + 5.47558965743519960313813002445801763737e-2_wp, & + 7.50396748109199527670431409161900093952e-2_wp, & + 9.31254545836976055350654650833663443900e-2_wp, & + 1.09387158802297641899210590325804960272e-1_wp, & + 1.23491976262065851077958109831074159512e-1_wp, & + 1.34709217311473325928054001771706832761e-1_wp, & + 1.42775938577060080797094273138717060886e-1_wp, & + 1.47739104901338491374841515972068045524e-1_wp, & + 1.49445554002916905664936468389821203745e-1_wp] !! weights of the 21-point kronrod rule + + centr = 0.5_wp*(a + b) + hlgth = 0.5_wp*(b - a) + dhlgth = abs(hlgth) + + ! compute the 21-point kronrod approximation to + ! the integral, and estimate the absolute error. + + resg = 0.0_wp + fc = f(centr) + resk = wgk(11)*fc + Resabs = abs(resk) + do j = 1, 5 + jtw = 2*j + absc = hlgth*xgk(jtw) + fval1 = f(centr - absc) + fval2 = f(centr + absc) + fv1(jtw) = fval1 + fv2(jtw) = fval2 + fsum = fval1 + fval2 + resg = resg + wg(j)*fsum + resk = resk + wgk(jtw)*fsum + Resabs = Resabs + wgk(jtw)*(abs(fval1) + abs(fval2)) + end do + do j = 1, 5 + jtwm1 = 2*j - 1 + absc = hlgth*xgk(jtwm1) + fval1 = f(centr - absc) + fval2 = f(centr + absc) + fv1(jtwm1) = fval1 + fv2(jtwm1) = fval2 + fsum = fval1 + fval2 + resk = resk + wgk(jtwm1)*fsum + Resabs = Resabs + wgk(jtwm1)*(abs(fval1) + abs(fval2)) + end do + reskh = resk*0.5_wp + Resasc = wgk(11)*abs(fc - reskh) + do j = 1, 10 + Resasc = Resasc + wgk(j) & + *(abs(fv1(j) - reskh) + abs(fv2(j) - reskh)) + end do + Result = resk*hlgth + Resabs = Resabs*dhlgth + Resasc = Resasc*dhlgth + Abserr = abs((resk - resg)*hlgth) + if (Resasc /= 0.0_wp .and. Abserr /= 0.0_wp) & + Abserr = Resasc*min(1.0_wp, (200.0_wp*Abserr/Resasc)**1.5_wp) + if (Resabs > uflow/(50.0_wp*epmach)) & + Abserr = max((epmach*50.0_wp)*Resabs, Abserr) + + end subroutine dqk21 +!******************************************************************************** + +!******************************************************************************** +!> +! estimate 1D integral on finite interval using a 31 point +! gauss-kronrod rule and give error estimate, non-automatic +! +! to compute i = integral of `f` over `(a,b)` with error +! estimate j = integral of `abs(f)` over `(a,b)` +! +!### History +! * QUADPACK: date written 800101, revision date 830518 (yymmdd). + + subroutine dqk31(f, a, b, Result, Abserr, Resabs, Resasc) + implicit none + + procedure(func) :: f !! function subprogram defining the integrand function `f(x)`. + real(wp), intent(in) :: a !! lower limit of integration + real(wp), intent(in) :: b !! upper limit of integration + real(wp), intent(out) :: Result !! approximation to the integral i + !! `result` is computed by applying the 31-point + !! gauss-kronrod rule (resk), obtained by optimal + !! addition of abscissae to the 15-point gauss + !! rule (resg). + real(wp), intent(out) :: Abserr !! estimate of the modulus of the modulus, + !! which should not exceed `abs(i-result)` + real(wp), intent(out) :: Resabs !! approximation to the integral j + real(wp), intent(out) :: Resasc !! approximation to the integral of `abs(f-i/(b-a))` + !! over `(a,b)` + + real(wp) :: centr !! mid point of the interval + real(wp) :: hlgth !! half-length of the interval + real(wp) :: absc !! abscissa + real(wp) :: fval1 !! function value + real(wp) :: fval2 !! function value + real(wp) :: resg !! result of the 15-point gauss formula + real(wp) :: resk !! result of the 31-point kronrod formula + real(wp) :: reskh !! approximation to the mean value of `f` over `(a,b)`, i.e. to `i/(b-a)` + real(wp) :: dhlgth, fc, fsum, fv1(15), fv2(15) + integer :: j, jtw, jtwm1 + + ! the abscissae and weights are given for the interval (-1,1). + ! because of symmetry only the positive abscissae and their + ! corresponding weights are given. + + real(wp), dimension(8), parameter :: wg = [ & + 3.07532419961172683546283935772044177217e-2_wp, & + 7.03660474881081247092674164506673384667e-2_wp, & + 1.07159220467171935011869546685869303416e-1_wp, & + 1.39570677926154314447804794511028322521e-1_wp, & + 1.66269205816993933553200860481208811131e-1_wp, & + 1.86161000015562211026800561866422824506e-1_wp, & + 1.98431485327111576456118326443839324819e-1_wp, & + 2.02578241925561272880620199967519314839e-1_wp] !! weights of the 15-point gauss rule + + real(wp), dimension(16), parameter :: xgk = [ & + 9.98002298693397060285172840152271209073e-1_wp, & + 9.87992518020485428489565718586612581147e-1_wp, & + 9.67739075679139134257347978784337225283e-1_wp, & + 9.37273392400705904307758947710209471244e-1_wp, & + 8.97264532344081900882509656454495882832e-1_wp, & + 8.48206583410427216200648320774216851366e-1_wp, & + 7.90418501442465932967649294817947346862e-1_wp, & + 7.24417731360170047416186054613938009631e-1_wp, & + 6.50996741297416970533735895313274692547e-1_wp, & + 5.70972172608538847537226737253910641238e-1_wp, & + 4.85081863640239680693655740232350612866e-1_wp, & + 3.94151347077563369897207370981045468363e-1_wp, & + 2.99180007153168812166780024266388962662e-1_wp, & + 2.01194093997434522300628303394596207813e-1_wp, & + 1.01142066918717499027074231447392338787e-1_wp, & + 0.00000000000000000000000000000000000000e0_wp] !! abscissae of the 31-point kronrod rule: + !! + !! * xgk(2), xgk(4), ... abscissae of the 15-point + !! gauss rule + !! * xgk(1), xgk(3), ... abscissae which are optimally + !! added to the 15-point gauss rule + + real(wp), dimension(16), parameter :: wgk = [ & + 5.37747987292334898779205143012764981831e-3_wp, & + 1.50079473293161225383747630758072680946e-2_wp, & + 2.54608473267153201868740010196533593973e-2_wp, & + 3.53463607913758462220379484783600481226e-2_wp, & + 4.45897513247648766082272993732796902233e-2_wp, & + 5.34815246909280872653431472394302967716e-2_wp, & + 6.20095678006706402851392309608029321904e-2_wp, & + 6.98541213187282587095200770991474757860e-2_wp, & + 7.68496807577203788944327774826590067221e-2_wp, & + 8.30805028231330210382892472861037896016e-2_wp, & + 8.85644430562117706472754436937743032123e-2_wp, & + 9.31265981708253212254868727473457185619e-2_wp, & + 9.66427269836236785051799076275893351367e-2_wp, & + 9.91735987217919593323931734846031310596e-2_wp, & + 1.00769845523875595044946662617569721916e-1_wp, & + 1.01330007014791549017374792767492546771e-1_wp] !! weights of the 31-point kronrod rule + + centr = 0.5_wp*(a + b) + hlgth = 0.5_wp*(b - a) + dhlgth = abs(hlgth) + + ! compute the 31-point kronrod approximation to + ! the integral, and estimate the absolute error. + + fc = f(centr) + resg = wg(8)*fc + resk = wgk(16)*fc + Resabs = abs(resk) + do j = 1, 7 + jtw = j*2 + absc = hlgth*xgk(jtw) + fval1 = f(centr - absc) + fval2 = f(centr + absc) + fv1(jtw) = fval1 + fv2(jtw) = fval2 + fsum = fval1 + fval2 + resg = resg + wg(j)*fsum + resk = resk + wgk(jtw)*fsum + Resabs = Resabs + wgk(jtw)*(abs(fval1) + abs(fval2)) + end do + do j = 1, 8 + jtwm1 = j*2 - 1 + absc = hlgth*xgk(jtwm1) + fval1 = f(centr - absc) + fval2 = f(centr + absc) + fv1(jtwm1) = fval1 + fv2(jtwm1) = fval2 + fsum = fval1 + fval2 + resk = resk + wgk(jtwm1)*fsum + Resabs = Resabs + wgk(jtwm1)*(abs(fval1) + abs(fval2)) + end do + reskh = resk*0.5_wp + Resasc = wgk(16)*abs(fc - reskh) + do j = 1, 15 + Resasc = Resasc + wgk(j) & + *(abs(fv1(j) - reskh) + abs(fv2(j) - reskh)) + end do + Result = resk*hlgth + Resabs = Resabs*dhlgth + Resasc = Resasc*dhlgth + Abserr = abs((resk - resg)*hlgth) + if (Resasc /= 0.0_wp .and. Abserr /= 0.0_wp) & + Abserr = Resasc*min(1.0_wp, (200.0_wp*Abserr/Resasc)**1.5_wp) + if (Resabs > uflow/(50.0_wp*epmach)) & + Abserr = max((epmach*50.0_wp)*Resabs, Abserr) + + end subroutine dqk31 +!******************************************************************************** + +!******************************************************************************** +!> +! estimate 1D integral on finite interval using a 41 point +! gauss-kronrod rule and give error estimate, non-automatic +! +! to compute i = integral of `f` over `(a,b)`, with error +! estimate j = integral of `abs(f)` over `(a,b)` +! +!### History +! * QUADPACK: date written 800101, revision date 830518 (yymmdd). + + subroutine dqk41(f, a, b, Result, Abserr, Resabs, Resasc) + implicit none + + procedure(func) :: f !! function subprogram defining the integrand function `f(x)`. + real(wp), intent(in) :: a !! lower limit of integration + real(wp), intent(in) :: b !! upper limit of integration + real(wp), intent(out) :: Result !! approximation to the integral i + !! `result` is computed by applying the 41-point + !! gauss-kronrod rule (resk) obtained by optimal + !! addition of abscissae to the 20-point gauss + !! rule (resg). + real(wp), intent(out) :: Abserr !! estimate of the modulus of the absolute error, + !! which should not exceed `abs(i-result)` + real(wp), intent(out) :: Resabs !! approximation to the integral j + real(wp), intent(out) :: Resasc !! approximation to the integral of abs(f-i/(b-a)) + !! over `(a,b)` + + real(wp) :: dhlgth, fc, fsum, fv1(20), fv2(20) + integer :: j, jtw, jtwm1 + real(wp) :: centr !! mid point of the interval + real(wp) :: hlgth !! half-length of the interval + real(wp) :: absc !! abscissa + real(wp) :: fval1 !! function value + real(wp) :: fval2 !! function value + real(wp) :: resg !! result of the 20-point gauss formula + real(wp) :: resk !! result of the 41-point kronrod formula + real(wp) :: reskh !! approximation to mean value of `f` over `(a,b)`, i.e. to `i/(b-a)` + + ! the abscissae and weights are given for the interval (-1,1). + ! because of symmetry only the positive abscissae and their + ! corresponding weights are given. + + real(wp), dimension(10), parameter :: wg = [ & + 1.76140071391521183118619623518528163621e-2_wp, & + 4.06014298003869413310399522749321098791e-2_wp, & + 6.26720483341090635695065351870416063516e-2_wp, & + 8.32767415767047487247581432220462061002e-2_wp, & + 1.01930119817240435036750135480349876167e-1_wp, & + 1.18194531961518417312377377711382287005e-1_wp, & + 1.31688638449176626898494499748163134916e-1_wp, & + 1.42096109318382051329298325067164933035e-1_wp, & + 1.49172986472603746787828737001969436693e-1_wp, & + 1.52753387130725850698084331955097593492e-1_wp] !! weights of the 20-point gauss rule + + real(wp), dimension(21), parameter :: xgk = [ & + 9.98859031588277663838315576545863010000e-1_wp, & + 9.93128599185094924786122388471320278223e-1_wp, & + 9.81507877450250259193342994720216944567e-1_wp, & + 9.63971927277913791267666131197277221912e-1_wp, & + 9.40822633831754753519982722212443380274e-1_wp, & + 9.12234428251325905867752441203298113049e-1_wp, & + 8.78276811252281976077442995113078466711e-1_wp, & + 8.39116971822218823394529061701520685330e-1_wp, & + 7.95041428837551198350638833272787942959e-1_wp, & + 7.46331906460150792614305070355641590311e-1_wp, & + 6.93237656334751384805490711845931533386e-1_wp, & + 6.36053680726515025452836696226285936743e-1_wp, & + 5.75140446819710315342946036586425132814e-1_wp, & + 5.10867001950827098004364050955250998425e-1_wp, & + 4.43593175238725103199992213492640107840e-1_wp, & + 3.73706088715419560672548177024927237396e-1_wp, & + 3.01627868114913004320555356858592260615e-1_wp, & + 2.27785851141645078080496195368574624743e-1_wp, & + 1.52605465240922675505220241022677527912e-1_wp, & + 7.65265211334973337546404093988382110048e-2_wp, & + 0.00000000000000000000000000000000000000e0_wp] !! abscissae of the 41-point gauss-kronrod rule: + !! + !! * xgk(2), xgk(4), ... abscissae of the 20-point + !! gauss rule + !! * xgk(1), xgk(3), ... abscissae which are optimally + !! added to the 20-point gauss rule + + real(wp), dimension(21), parameter :: wgk = [ & + 3.07358371852053150121829324603098748803e-3_wp, & + 8.60026985564294219866178795010234725213e-3_wp, & + 1.46261692569712529837879603088683561639e-2_wp, & + 2.03883734612665235980102314327547051228e-2_wp, & + 2.58821336049511588345050670961531429995e-2_wp, & + 3.12873067770327989585431193238007378878e-2_wp, & + 3.66001697582007980305572407072110084875e-2_wp, & + 4.16688733279736862637883059368947380440e-2_wp, & + 4.64348218674976747202318809261075168421e-2_wp, & + 5.09445739237286919327076700503449486648e-2_wp, & + 5.51951053482859947448323724197773291948e-2_wp, & + 5.91114008806395723749672206485942171364e-2_wp, & + 6.26532375547811680258701221742549805858e-2_wp, & + 6.58345971336184221115635569693979431472e-2_wp, & + 6.86486729285216193456234118853678017155e-2_wp, & + 7.10544235534440683057903617232101674129e-2_wp, & + 7.30306903327866674951894176589131127606e-2_wp, & + 7.45828754004991889865814183624875286161e-2_wp, & + 7.57044976845566746595427753766165582634e-2_wp, & + 7.63778676720807367055028350380610018008e-2_wp, & + 7.66007119179996564450499015301017408279e-2_wp] !! weights of the 41-point gauss-kronrod rule + + centr = 0.5_wp*(a + b) + hlgth = 0.5_wp*(b - a) + dhlgth = abs(hlgth) + + ! compute the 41-point gauss-kronrod approximation to + ! the integral, and estimate the absolute error. + + resg = 0.0_wp + fc = f(centr) + resk = wgk(21)*fc + Resabs = abs(resk) + do j = 1, 10 + jtw = j*2 + absc = hlgth*xgk(jtw) + fval1 = f(centr - absc) + fval2 = f(centr + absc) + fv1(jtw) = fval1 + fv2(jtw) = fval2 + fsum = fval1 + fval2 + resg = resg + wg(j)*fsum + resk = resk + wgk(jtw)*fsum + Resabs = Resabs + wgk(jtw)*(abs(fval1) + abs(fval2)) + end do + do j = 1, 10 + jtwm1 = j*2 - 1 + absc = hlgth*xgk(jtwm1) + fval1 = f(centr - absc) + fval2 = f(centr + absc) + fv1(jtwm1) = fval1 + fv2(jtwm1) = fval2 + fsum = fval1 + fval2 + resk = resk + wgk(jtwm1)*fsum + Resabs = Resabs + wgk(jtwm1)*(abs(fval1) + abs(fval2)) + end do + reskh = resk*0.5_wp + Resasc = wgk(21)*abs(fc - reskh) + do j = 1, 20 + Resasc = Resasc + wgk(j) & + *(abs(fv1(j) - reskh) + abs(fv2(j) - reskh)) + end do + Result = resk*hlgth + Resabs = Resabs*dhlgth + Resasc = Resasc*dhlgth + Abserr = abs((resk - resg)*hlgth) + if (Resasc /= 0.0_wp .and. Abserr /= 0.0_wp) & + Abserr = Resasc*min(1.0_wp, (200.0_wp*Abserr/Resasc)**1.5_wp) + if (Resabs > uflow/(50.0_wp*epmach)) & + Abserr = max((epmach*50.0_wp)*Resabs, Abserr) + + end subroutine dqk41 +!******************************************************************************** + +!******************************************************************************** +!> +! estimate 1D integral on finite interval using a 51 point +! gauss-kronrod rule and give error estimate, non-automatic +! +! to compute i = integral of `f` over `(a,b)` with error +! estimate j = integral of `abs(f)` over `(a,b)` +! +!### History +! * QUADPACK: date written 800101, revision date 830518 (yymmdd). + + subroutine dqk51(f, a, b, Result, Abserr, Resabs, Resasc) + implicit none + + procedure(func) :: f !! function subroutine defining the integrand function `f(x)`. + real(wp), intent(in) :: a !! lower limit of integration + real(wp), intent(in) :: b !! upper limit of integration + real(wp), intent(out) :: Result !! approximation to the integral i. + !! `result` is computed by applying the 51-point + !! kronrod rule (resk) obtained by optimal addition + !! of abscissae to the 25-point gauss rule (resg). + real(wp), intent(out) :: Abserr !! estimate of the modulus of the absolute error, + !! which should not exceed `abs(i-result)` + real(wp), intent(out) :: Resabs !! approximation to the integral j + real(wp), intent(out) :: Resasc !! approximation to the integral of `abs(f-i/(b-a))` + !! over `(a,b)` + + real(wp) :: centr !! mid point of the interval + real(wp) :: hlgth !! half-length of the interval + real(wp) :: absc !! abscissa + real(wp) :: fval1 !! function value + real(wp) :: fval2 !! function value + real(wp) :: resg !! result of the 25-point gauss formula + real(wp) :: resk !! result of the 51-point kronrod formula + real(wp) :: reskh !! approximation to the mean value of `f` over `(a,b)`, i.e. to `i/(b-a)` + + real(wp) :: dhlgth, fc, fsum, fv1(25), fv2(25) + integer :: j, jtw, jtwm1 + + ! the abscissae and weights are given for the interval (-1,1). + ! because of symmetry only the positive abscissae and their + ! corresponding weights are given. + + real(wp), dimension(13), parameter :: wg = [ & + 1.13937985010262879479029641132347736033e-2_wp, & + 2.63549866150321372619018152952991449360e-2_wp, & + 4.09391567013063126556234877116459536608e-2_wp, & + 5.49046959758351919259368915404733241601e-2_wp, & + 6.80383338123569172071871856567079685547e-2_wp, & + 8.01407003350010180132349596691113022902e-2_wp, & + 9.10282619829636498114972207028916533810e-2_wp, & + 1.00535949067050644202206890392685826988e-1_wp, & + 1.08519624474263653116093957050116619340e-1_wp, & + 1.14858259145711648339325545869555808641e-1_wp, & + 1.19455763535784772228178126512901047390e-1_wp, & + 1.22242442990310041688959518945851505835e-1_wp, & + 1.23176053726715451203902873079050142438e-1_wp] !! weights of the 25-point gauss rule + + real(wp), dimension(26), parameter :: xgk = [ & + 9.99262104992609834193457486540340593705e-1_wp, & + 9.95556969790498097908784946893901617258e-1_wp, & + 9.88035794534077247637331014577406227072e-1_wp, & + 9.76663921459517511498315386479594067745e-1_wp, & + 9.61614986425842512418130033660167241692e-1_wp, & + 9.42974571228974339414011169658470531905e-1_wp, & + 9.20747115281701561746346084546330631575e-1_wp, & + 8.94991997878275368851042006782804954175e-1_wp, & + 8.65847065293275595448996969588340088203e-1_wp, & + 8.33442628760834001421021108693569569461e-1_wp, & + 7.97873797998500059410410904994306569409e-1_wp, & + 7.59259263037357630577282865204360976388e-1_wp, & + 7.17766406813084388186654079773297780598e-1_wp, & + 6.73566368473468364485120633247622175883e-1_wp, & + 6.26810099010317412788122681624517881020e-1_wp, & + 5.77662930241222967723689841612654067396e-1_wp, & + 5.26325284334719182599623778158010178037e-1_wp, & + 4.73002731445714960522182115009192041332e-1_wp, & + 4.17885382193037748851814394594572487093e-1_wp, & + 3.61172305809387837735821730127640667422e-1_wp, & + 3.03089538931107830167478909980339329200e-1_wp, & + 2.43866883720988432045190362797451586406e-1_wp, & + 1.83718939421048892015969888759528415785e-1_wp, & + 1.22864692610710396387359818808036805532e-1_wp, & + 6.15444830056850788865463923667966312817e-2_wp, & + 0.00000000000000000000000000000000000000e0_wp] !! abscissae of the 51-point kronrod rule + !! + !! * xgk(2), xgk(4), ... abscissae of the 25-point + !! gauss rule + !! * xgk(1), xgk(3), ... abscissae which are optimally + !! added to the 25-point gauss rule + + real(wp), dimension(26), parameter :: wgk = [ & + 1.98738389233031592650785188284340988943e-3_wp, & + 5.56193213535671375804023690106552207018e-3_wp, & + 9.47397338617415160720771052365532387165e-3_wp, & + 1.32362291955716748136564058469762380776e-2_wp, & + 1.68478177091282982315166675363363158404e-2_wp, & + 2.04353711458828354565682922359389736788e-2_wp, & + 2.40099456069532162200924891648810813929e-2_wp, & + 2.74753175878517378029484555178110786148e-2_wp, & + 3.07923001673874888911090202152285856009e-2_wp, & + 3.40021302743293378367487952295512032257e-2_wp, & + 3.71162714834155435603306253676198759960e-2_wp, & + 4.00838255040323820748392844670756464014e-2_wp, & + 4.28728450201700494768957924394951611020e-2_wp, & + 4.55029130499217889098705847526603930437e-2_wp, & + 4.79825371388367139063922557569147549836e-2_wp, & + 5.02776790807156719633252594334400844406e-2_wp, & + 5.23628858064074758643667121378727148874e-2_wp, & + 5.42511298885454901445433704598756068261e-2_wp, & + 5.59508112204123173082406863827473468203e-2_wp, & + 5.74371163615678328535826939395064719948e-2_wp, & + 5.86896800223942079619741758567877641398e-2_wp, & + 5.97203403241740599790992919325618538354e-2_wp, & + 6.05394553760458629453602675175654271623e-2_wp, & + 6.11285097170530483058590304162927119227e-2_wp, & + 6.14711898714253166615441319652641775865e-2_wp, & + 6.15808180678329350787598242400645531904e-2_wp] !! weights of the 51-point kronrod rule. + + centr = 0.5_wp*(a + b) + hlgth = 0.5_wp*(b - a) + dhlgth = abs(hlgth) + + ! compute the 51-point kronrod approximation to + ! the integral, and estimate the absolute error. + + fc = f(centr) + resg = wg(13)*fc + resk = wgk(26)*fc + Resabs = abs(resk) + do j = 1, 12 + jtw = j*2 + absc = hlgth*xgk(jtw) + fval1 = f(centr - absc) + fval2 = f(centr + absc) + fv1(jtw) = fval1 + fv2(jtw) = fval2 + fsum = fval1 + fval2 + resg = resg + wg(j)*fsum + resk = resk + wgk(jtw)*fsum + Resabs = Resabs + wgk(jtw)*(abs(fval1) + abs(fval2)) + end do + do j = 1, 13 + jtwm1 = j*2 - 1 + absc = hlgth*xgk(jtwm1) + fval1 = f(centr - absc) + fval2 = f(centr + absc) + fv1(jtwm1) = fval1 + fv2(jtwm1) = fval2 + fsum = fval1 + fval2 + resk = resk + wgk(jtwm1)*fsum + Resabs = Resabs + wgk(jtwm1)*(abs(fval1) + abs(fval2)) + end do + reskh = resk*0.5_wp + Resasc = wgk(26)*abs(fc - reskh) + do j = 1, 25 + Resasc = Resasc + wgk(j) & + *(abs(fv1(j) - reskh) + abs(fv2(j) - reskh)) + end do + Result = resk*hlgth + Resabs = Resabs*dhlgth + Resasc = Resasc*dhlgth + Abserr = abs((resk - resg)*hlgth) + if (Resasc /= 0.0_wp .and. Abserr /= 0.0_wp) & + Abserr = Resasc*min(1.0_wp, (200.0_wp*Abserr/Resasc)**1.5_wp) + if (Resabs > uflow/(50.0_wp*epmach)) & + Abserr = max((epmach*50.0_wp)*Resabs, Abserr) + + end subroutine dqk51 +!******************************************************************************** + +!******************************************************************************** +!> +! estimate 1D integral on finite interval using a 61 point +! gauss-kronrod rule and give error estimate, non-automatic +! +! to compute i = integral of `f` over `(a,b)` with error +! estimate j = integral of `abs(f)` over `(a,b)`. +! +!### History +! * QUADPACK: date written 800101, revision date 830518 (yymmdd). + + subroutine dqk61(f, a, b, Result, Abserr, Resabs, Resasc) + implicit none + + procedure(func) :: f !! function subprogram defining the integrand function `f(x)`. + real(wp), intent(in) :: a !! lower limit of integration + real(wp), intent(in) :: b !! upper limit of integration + real(wp), intent(out) :: Result !! approximation to the integral i + !! `result` is computed by applying the 61-point + !! kronrod rule (resk) obtained by optimal addition of + !! abscissae to the 30-point gauss rule (resg). + real(wp), intent(out) :: Abserr !! estimate of the modulus of the absolute error, + !! which should equal or exceed `abs(i-result)` + real(wp), intent(out) :: Resabs !! approximation to the integral j + real(wp), intent(out) :: Resasc !! approximation to the integral of `abs(f-i/(b-a))` + + real(wp) :: dhlgth, fc, fsum, fv1(30), fv2(30) + integer :: j, jtw, jtwm1 + real(wp) :: centr !! mid point of the interval + real(wp) :: hlgth !! half-length of the interval + real(wp) :: absc !! abscissa + real(wp) :: fval1 !! function value + real(wp) :: fval2 !! function value + real(wp) :: resg !! result of the 30-point gauss rule + real(wp) :: resk !! result of the 61-point kronrod rule + real(wp) :: reskh !! approximation to the mean value of `f` over `(a,b)`, i.e. to `i/(b-a)` + + ! the abscissae and weights are given for the + ! interval (-1,1). because of symmetry only the positive + ! abscissae and their corresponding weights are given. + + real(wp), dimension(15), parameter :: wg = [ & + 7.96819249616660561546588347467362245048e-3_wp, & + 1.84664683110909591423021319120472690962e-2_wp, & + 2.87847078833233693497191796112920436396e-2_wp, & + 3.87991925696270495968019364463476920332e-2_wp, & + 4.84026728305940529029381404228075178153e-2_wp, & + 5.74931562176190664817216894020561287971e-2_wp, & + 6.59742298821804951281285151159623612374e-2_wp, & + 7.37559747377052062682438500221907341538e-2_wp, & + 8.07558952294202153546949384605297308759e-2_wp, & + 8.68997872010829798023875307151257025768e-2_wp, & + 9.21225222377861287176327070876187671969e-2_wp, & + 9.63687371746442596394686263518098650964e-2_wp, & + 9.95934205867952670627802821035694765299e-2_wp, & + 1.01762389748405504596428952168554044633e-1_wp, & + 1.02852652893558840341285636705415043868e-1_wp] !! weights of the 30-point gauss rule + + real(wp), dimension(31), parameter :: xgk = [ & + 9.99484410050490637571325895705810819469e-1_wp, & + 9.96893484074649540271630050918695283341e-1_wp, & + 9.91630996870404594858628366109485724851e-1_wp, & + 9.83668123279747209970032581605662801940e-1_wp, & + 9.73116322501126268374693868423706884888e-1_wp, & + 9.60021864968307512216871025581797662930e-1_wp, & + 9.44374444748559979415831324037439121586e-1_wp, & + 9.26200047429274325879324277080474004086e-1_wp, & + 9.05573307699907798546522558925958319569e-1_wp, & + 8.82560535792052681543116462530225590057e-1_wp, & + 8.57205233546061098958658510658943856821e-1_wp, & + 8.29565762382768397442898119732501916439e-1_wp, & + 7.99727835821839083013668942322683240736e-1_wp, & + 7.67777432104826194917977340974503131695e-1_wp, & + 7.33790062453226804726171131369527645669e-1_wp, & + 6.97850494793315796932292388026640068382e-1_wp, & + 6.60061064126626961370053668149270753038e-1_wp, & + 6.20526182989242861140477556431189299207e-1_wp, & + 5.79345235826361691756024932172540495907e-1_wp, & + 5.36624148142019899264169793311072794164e-1_wp, & + 4.92480467861778574993693061207708795644e-1_wp, & + 4.47033769538089176780609900322854000162e-1_wp, & + 4.00401254830394392535476211542660633611e-1_wp, & + 3.52704725530878113471037207089373860654e-1_wp, & + 3.04073202273625077372677107199256553531e-1_wp, & + 2.54636926167889846439805129817805107883e-1_wp, & + 2.04525116682309891438957671002024709524e-1_wp, & + 1.53869913608583546963794672743255920419e-1_wp, & + 1.02806937966737030147096751318000592472e-1_wp, & + 5.14718425553176958330252131667225737491e-2_wp, & + 0.00000000000000000000000000000000000000e0_wp] !! abscissae of the 61-point kronrod rule: + !! + !! * `xgk(2), xgk(4)` ... abscissae of the 30-point + !! gauss rule + !! * `xgk(1), xgk(3)` ... optimally added abscissae + !! to the 30-point gauss rule + + real(wp), dimension(31), parameter :: wgk = [ & + 1.38901369867700762455159122675969968105e-3, & + 3.89046112709988405126720184451550327852e-3, & + 6.63070391593129217331982636975016813363e-3, & + 9.27327965951776342844114689202436042127e-3, & + 1.18230152534963417422328988532505928963e-2, & + 1.43697295070458048124514324435800101958e-2, & + 1.69208891890532726275722894203220923686e-2, & + 1.94141411939423811734089510501284558514e-2, & + 2.18280358216091922971674857383389934015e-2, & + 2.41911620780806013656863707252320267604e-2, & + 2.65099548823331016106017093350754143665e-2, & + 2.87540487650412928439787853543342111447e-2, & + 3.09072575623877624728842529430922726353e-2, & + 3.29814470574837260318141910168539275106e-2, & + 3.49793380280600241374996707314678750972e-2, & + 3.68823646518212292239110656171359677370e-2, & + 3.86789456247275929503486515322810502509e-2, & + 4.03745389515359591119952797524681142161e-2, & + 4.19698102151642461471475412859697577901e-2, & + 4.34525397013560693168317281170732580746e-2, & + 4.48148001331626631923555516167232437574e-2, & + 4.60592382710069881162717355593735805947e-2, & + 4.71855465692991539452614781810994864829e-2, & + 4.81858617570871291407794922983045926058e-2, & + 4.90554345550297788875281653672381736059e-2, & + 4.97956834270742063578115693799423285392e-2, & + 5.04059214027823468408930856535850289022e-2, & + 5.08817958987496064922974730498046918534e-2, & + 5.12215478492587721706562826049442082511e-2, & + 5.14261285374590259338628792157812598296e-2, & + 5.14947294294515675583404336470993075327e-2] !! weights of the 61-point kronrod rule + + centr = 0.5_wp*(b + a) + hlgth = 0.5_wp*(b - a) + dhlgth = abs(hlgth) + + ! compute the 61-point kronrod approximation to the + ! integral, and estimate the absolute error. + + resg = 0.0_wp + fc = f(centr) + resk = wgk(31)*fc + Resabs = abs(resk) + do j = 1, 15 + jtw = j*2 + absc = hlgth*xgk(jtw) + fval1 = f(centr - absc) + fval2 = f(centr + absc) + fv1(jtw) = fval1 + fv2(jtw) = fval2 + fsum = fval1 + fval2 + resg = resg + wg(j)*fsum + resk = resk + wgk(jtw)*fsum + Resabs = Resabs + wgk(jtw)*(abs(fval1) + abs(fval2)) + end do + do j = 1, 15 + jtwm1 = j*2 - 1 + absc = hlgth*xgk(jtwm1) + fval1 = f(centr - absc) + fval2 = f(centr + absc) + fv1(jtwm1) = fval1 + fv2(jtwm1) = fval2 + fsum = fval1 + fval2 + resk = resk + wgk(jtwm1)*fsum + Resabs = Resabs + wgk(jtwm1)*(abs(fval1) + abs(fval2)) + end do + reskh = resk*0.5_wp + Resasc = wgk(31)*abs(fc - reskh) + do j = 1, 30 + Resasc = Resasc + wgk(j) & + *(abs(fv1(j) - reskh) + abs(fv2(j) - reskh)) + end do + Result = resk*hlgth + Resabs = Resabs*dhlgth + Resasc = Resasc*dhlgth + Abserr = abs((resk - resg)*hlgth) + if (Resasc /= 0.0_wp .and. Abserr /= 0.0_wp) & + Abserr = Resasc*min(1.0_wp, (200.0_wp*Abserr/Resasc)**1.5_wp) + if (Resabs > uflow/(50.0_wp*epmach)) & + Abserr = max((epmach*50.0_wp)*Resabs, Abserr) + + end subroutine dqk61 +!******************************************************************************** + +!******************************************************************************** +!> +! 1D integration of `k`-th degree Chebyshev polynomial times a function with singularities +! +! this routine computes modified chebsyshev moments. the `k`-th +! modified chebyshev moment is defined as the integral over +! `(-1,1)` of `w(x)*t(k,x)`, where `t(k,x)` is the chebyshev +! polynomial of degree `k`. +! +!### History +! * QUADPACK: date written 820101, revision date 830518 (yymmdd). + + subroutine dqmomo(Alfa, Beta, Ri, Rj, Rg, Rh, Integr) + implicit none + + real(wp), intent(in) :: Alfa !! parameter in the weight function `w(x)`, `alfa>(-1)` + real(wp), intent(in) :: Beta !! parameter in the weight function `w(x)`, `beta>(-1)` + real(wp), intent(out) :: Ri(25) !! `i(k)` is the integral over (-1,1) of + !! `(1+x)**alfa*t(k-1,x), k = 1, ..., 25`. + real(wp), intent(out) :: Rj(25) !! `rj(k)` is the integral over (-1,1) of + !! `(1-x)**beta*t(k-1,x), k = 1, ..., 25`. + real(wp), intent(out) :: Rg(25) !! `rg(k)` is the integral over (-1,1) of + !! `(1+x)**alfa*log((1+x)/2)*t(k-1,x), k = 1, ..., 25`. + real(wp), intent(out) :: Rh(25) !! `rh(k)` is the integral over (-1,1) of + !! `(1-x)**beta*log((1-x)/2)*t(k-1,x), k = 1, ..., 25`. + integer, intent(in) :: Integr !! input parameter indicating the modified + !! moments to be computed: + !! + !! * integr = 1 compute `ri`, `rj` + !! * integr = 2 compute `ri`, `rj`, `rg` + !! * integr = 3 compute `ri`, `rj`, `rh` + !! * integr = 4 compute `ri`, `rj`, `rg`, `rh` + + real(wp) :: alfp1, alfp2, an, anm1, betp1, betp2, ralf, rbet + integer :: i, im1 + + main : block + + alfp1 = Alfa + 1.0_wp + betp1 = Beta + 1.0_wp + alfp2 = Alfa + 2.0_wp + betp2 = Beta + 2.0_wp + ralf = 2.0_wp**alfp1 + rbet = 2.0_wp**betp1 + + ! compute ri, rj using a forward recurrence relation. + + Ri(1) = ralf/alfp1 + Rj(1) = rbet/betp1 + Ri(2) = Ri(1)*Alfa/alfp2 + Rj(2) = Rj(1)*Beta/betp2 + an = 2.0_wp + anm1 = 1.0_wp + do i = 3, 25 + Ri(i) = -(ralf + an*(an - alfp2)*Ri(i - 1))/(anm1*(an + alfp1)) + Rj(i) = -(rbet + an*(an - betp2)*Rj(i - 1))/(anm1*(an + betp1)) + anm1 = an + an = an + 1.0_wp + end do + if (Integr /= 1) then + if (Integr /= 3) then + + ! compute rg using a forward recurrence relation. + + Rg(1) = -Ri(1)/alfp1 + Rg(2) = -(ralf + ralf)/(alfp2*alfp2) - Rg(1) + an = 2.0_wp + anm1 = 1.0_wp + im1 = 2 + do i = 3, 25 + Rg(i) = -(an*(an - alfp2)*Rg(im1) - an*Ri(im1) + anm1*Ri(i)) & + /(anm1*(an + alfp1)) + anm1 = an + an = an + 1.0_wp + im1 = i + end do + if (Integr == 2) exit main + end if + + ! compute rh using a forward recurrence relation. + + Rh(1) = -Rj(1)/betp1 + Rh(2) = -(rbet + rbet)/(betp2*betp2) - Rh(1) + an = 2.0_wp + anm1 = 1.0_wp + im1 = 2 + do i = 3, 25 + Rh(i) = -(an*(an - betp2)*Rh(im1) - an*Rj(im1) + anm1*Rj(i)) & + /(anm1*(an + betp1)) + anm1 = an + an = an + 1.0_wp + im1 = i + end do + do i = 2, 25, 2 + Rh(i) = -Rh(i) + end do + end if + + end block main + + do i = 2, 25, 2 + Rj(i) = -Rj(i) + end do + + end subroutine dqmomo +!******************************************************************************** + +!******************************************************************************** +!> +! 1D non-adaptive automatic integrator +! +! the routine calculates an approximation result to a +! given definite integral i = integral of `f` over `(a,b)`, +! hopefully satisfying following claim for accuracy +! `abs(i-result)<=max(epsabs,epsrel*abs(i))`. +! +!### History +! * QUADPACK: date written 800101, revision date 810101 (yymmdd), +! kahaner,david,nbs - modified (2/82) + + subroutine dqng(f, a, b, Epsabs, Epsrel, Result, Abserr, Neval, Ier) + implicit none + + procedure(func) :: f !! function subprogram defining the integrand function `f(x)`. + real(wp), intent(in) :: a !! lower limit of integration + real(wp), intent(in) :: b !! upper limit of integration + real(wp), intent(in) :: Epsabs !! absolute accuracy requested + real(wp), intent(in) :: Epsrel !! relative accuracy requested + !! if `epsabs<=0` + !! and `epsrel0 abnormal termination of the routine. it is + !! assumed that the requested accuracy has + !! not been achieved. + !! + !! error messages: + !! + !! * ier = 1 the maximum number of steps has been + !! executed. the integral is probably too + !! difficult to be calculated by dqng. + !! * ier = 6 the input is invalid, because + !! `epsabs<=0` and + !! `epsrel 0.0_wp .or. Epsrel >= max(50.0_wp*epmach, 0.5e-28_wp)) & + then + hlgth = 0.5_wp*(b - a) + dhlgth = abs(hlgth) + centr = 0.5_wp*(b + a) + fcentr = f(centr) + Neval = 21 + Ier = 1 + + ! compute the integral using the 10- and 21-point formula. + + do l = 1, 3 + select case (l) + case (2) + + ! compute the integral using the 43-point formula. + + res43 = w43b(12)*fcentr + Neval = 43 + do k = 1, 10 + res43 = res43 + savfun(k)*w43a(k) + end do + do k = 1, 11 + ipx = ipx + 1 + absc = hlgth*x3(k) + fval = f(absc + centr) + f(centr - absc) + res43 = res43 + fval*w43b(k) + savfun(ipx) = fval + end do + + ! test for convergence. + + Result = res43*hlgth + Abserr = abs((res43 - res21)*hlgth) + case (3) + + ! compute the integral using the 87-point formula. + + res87 = w87b(23)*fcentr + Neval = 87 + do k = 1, 21 + res87 = res87 + savfun(k)*w87a(k) + end do + do k = 1, 22 + absc = hlgth*x4(k) + res87 = res87 + w87b(k)*(f(absc + centr) + f(centr - absc)) + end do + Result = res87*hlgth + Abserr = abs((res87 - res43)*hlgth) + case default + res10 = 0.0_wp + res21 = w21b(6)*fcentr + resabs = w21b(6)*abs(fcentr) + do k = 1, 5 + absc = hlgth*x1(k) + fval1 = f(centr + absc) + fval2 = f(centr - absc) + fval = fval1 + fval2 + res10 = res10 + w10(k)*fval + res21 = res21 + w21a(k)*fval + resabs = resabs + w21a(k)*(abs(fval1) + abs(fval2)) + savfun(k) = fval + fv1(k) = fval1 + fv2(k) = fval2 + end do + ipx = 5 + do k = 1, 5 + ipx = ipx + 1 + absc = hlgth*x2(k) + fval1 = f(centr + absc) + fval2 = f(centr - absc) + fval = fval1 + fval2 + res21 = res21 + w21b(k)*fval + resabs = resabs + w21b(k)*(abs(fval1) + abs(fval2)) + savfun(ipx) = fval + fv3(k) = fval1 + fv4(k) = fval2 + end do + + ! test for convergence. + + Result = res21*hlgth + resabs = resabs*dhlgth + reskh = 0.5_wp*res21 + resasc = w21b(6)*abs(fcentr - reskh) + do k = 1, 5 + resasc = resasc + w21a(k) & + *(abs(fv1(k) - reskh) + abs(fv2(k) - reskh)) & + + w21b(k) & + *(abs(fv3(k) - reskh) + abs(fv4(k) - reskh)) + end do + Abserr = abs((res21 - res10)*hlgth) + resasc = resasc*dhlgth + end select + if (resasc /= 0.0_wp .and. Abserr /= 0.0_wp) & + Abserr = resasc*min(1.0_wp, (200.0_wp*Abserr/resasc)**1.5_wp) + if (resabs > uflow/(50.0_wp*epmach)) & + Abserr = max((epmach*50.0_wp)*resabs, Abserr) + if (Abserr <= max(Epsabs, Epsrel*abs(Result))) Ier = 0 + ! ***jump out of do-loop + if (Ier == 0) return + end do + end if + call xerror('abnormal return from dqng ', Ier, 0) + + end subroutine dqng +!******************************************************************************** + +!******************************************************************************** +!> +! this routine maintains the descending ordering in the +! list of the local error estimated resulting from the +! interval subdivision process. at each call two error +! estimates are inserted using the sequential search +! method, top-down for the largest error estimate and +! bottom-up for the smallest error estimate. +! +!### See also +! * [[dqage]], [[dqagie]], [[dqagpe]], [[dqawse]] +! +!### History +! * QUADPACK: revision date 810101 (yymmdd) + + subroutine dqpsrt(Limit, Last, Maxerr, Ermax, Elist, Iord, Nrmax) + implicit none + + integer, intent(in) :: Limit !! maximum number of error estimates the list can contain + integer, intent(in) :: Last !! number of error estimates currently in the list + integer, intent(inout) :: Maxerr !! `maxerr` points to the `nrmax`-th largest error + !! estimate currently in the list + real(wp), intent(out) :: Ermax !! `nrmax`-th largest error estimate + !! `ermax = elist(maxerr)` + real(wp), intent(in) :: Elist(Last) !! vector of dimension `last` containing + !! the error estimates + integer, intent(inout) :: Iord(Last) !! vector of dimension `last`, the first `k` elements + !! of which contain pointers to the error + !! estimates, such that + !! `elist(iord(1)),..., elist(iord(k))` + !! form a decreasing sequence, with + !! `k = last` if `last<=(limit/2+2)`, and + !! `k = limit+1-last` otherwise + integer, intent(inout) :: Nrmax !! `maxerr = iord(nrmax)` + + real(wp) :: errmax, errmin + integer :: i, ibeg, ido, isucc, j, jbnd, jupbn, k + + main : block + + ! check whether the list contains more than + ! two error estimates. + + if (Last > 2) then + + ! this part of the routine is only executed if, due to a + ! difficult integrand, subdivision increased the error + ! estimate. in the normal case the insert procedure should + ! start after the nrmax-th largest error estimate. + + errmax = Elist(Maxerr) + if (Nrmax /= 1) then + ido = Nrmax - 1 + do i = 1, ido + isucc = Iord(Nrmax - 1) + ! ***jump out of do-loop + if (errmax <= Elist(isucc)) exit + Iord(Nrmax) = isucc + Nrmax = Nrmax - 1 + end do + end if + + ! compute the number of elements in the list to be maintained + ! in descending order. this number depends on the number of + ! subdivisions still allowed. + + jupbn = Last + if (Last > (Limit/2 + 2)) jupbn = Limit + 3 - Last + errmin = Elist(Last) + + ! insert errmax by traversing the list top-down, + ! starting comparison from the element elist(iord(nrmax+1)). + + jbnd = jupbn - 1 + ibeg = Nrmax + 1 + if (ibeg <= jbnd) then + do i = ibeg, jbnd + isucc = Iord(i) + ! ***jump out of do-loop + if (errmax >= Elist(isucc)) then + ! insert errmin by traversing the list bottom-up. + Iord(i - 1) = Maxerr + k = jbnd + do j = i, jbnd + isucc = Iord(k) + ! ***jump out of do-loop + if (errmin < Elist(isucc)) then + Iord(k + 1) = Last + exit main + end if + Iord(k + 1) = isucc + k = k - 1 + end do + Iord(i) = Last + exit main + end if + Iord(i - 1) = isucc + end do + end if + Iord(jbnd) = Maxerr + Iord(jupbn) = Last + else + Iord(1) = 1 + Iord(2) = 2 + end if + + end block main + + ! set maxerr and ermax. + Maxerr = Iord(Nrmax) + Ermax = Elist(Maxerr) + + end subroutine dqpsrt +!******************************************************************************** + +!******************************************************************************** +!> +! this function subprogram is used together with the +! routine [[qawc]] and defines the weight function. +! +!### See also +! * [[dqk15w]] +! +!### History +! * QUADPACK: revision date 810101 (yymmdd) +! +!### Keywords +! * weight function, cauchy principal value + + real(wp) function dqwgtc(x, c, p2, p3, p4, Kp) + implicit none + + real(wp), intent(in) :: c + real(wp), intent(in) :: p2 + real(wp), intent(in) :: p3 + real(wp), intent(in) :: p4 + real(wp), intent(in) :: x + integer, intent(in) :: Kp !! not used in this function + + dqwgtc = 1.0_wp/(x - c) + + end function dqwgtc +!******************************************************************************** + +!******************************************************************************** +!> +! cos or sin in weight function +! +!### See also +! * [[dqk15w]] +! +!### History +! * QUADPACK: revision date 810101 (yymmdd) + + real(wp) function dqwgtf(x, Omega, p2, p3, p4, Integr) + implicit none + + real(wp), intent(in) :: x + real(wp), intent(in) :: Omega + real(wp), intent(in) :: p2 + real(wp), intent(in) :: p3 + real(wp), intent(in) :: p4 + integer, intent(in) :: Integr + + if (Integr == 2) then + dqwgtf = sin(Omega*x) + else + dqwgtf = cos(Omega*x) + end if + + end function dqwgtf +!******************************************************************************** + +!******************************************************************************** +!> +! this function subprogram is used together with the +! routine [[dqaws]] and defines the weight function. +! +!### See also +! * [[dqk15w]] +! +!### History +! * QUADPACK: revision date 810101 (yymmdd) + + real(wp) function dqwgts(x, a, b, Alfa, Beta, Integr) + implicit none + + real(wp), intent(in) :: x + real(wp), intent(in) :: a + real(wp), intent(in) :: b + real(wp), intent(in) :: Alfa + real(wp), intent(in) :: Beta + integer, intent(in) :: Integr + + real(wp) :: bmx, xma + + xma = x - a + bmx = b - x + + dqwgts = xma**Alfa*bmx**Beta + select case (Integr) + case (1) + case (3) + dqwgts = dqwgts*log(bmx) + case (4) + dqwgts = dqwgts*log(xma)*log(bmx) + case default + dqwgts = dqwgts*log(xma) + end select + + end function dqwgts +!******************************************************************************** + +!******************************************************************************** +!> +! dgtsl given a general tridiagonal matrix and a right hand +! side will find the solution. +! +!### History +! * linpack. this version dated 08/14/78. +! jack dongarra, argonne national laboratory. + + subroutine dgtsl(n, c, d, e, b, info) + implicit none + + integer, intent(in) :: n !! the order of the tridiagonal matrix. + integer, intent(out) :: info !! * = 0 normal value. + !! * = `k` if the `k`-th element of the diagonal becomes + !! exactly zero. the subroutine returns when + !! this is detected. + real(wp), intent(inout) :: c(n) !! the subdiagonal of the tridiagonal matrix. + !! `c(2)` through `c(n) `should contain the subdiagonal. + !! on output `c` is destroyed. + real(wp), intent(inout) :: d(n) !! the diagonal of the tridiagonal matrix. + !! on output `d` is destroyed. + real(wp), intent(inout) :: e(n) !! the superdiagonal of the tridiagonal matrix. + !! `e(1)` through `e(n-1)` should contain the superdiagonal. + !! on output `e` is destroyed. + real(wp), intent(inout) :: b(n) !! * input: is the right hand side vector.. + !! * output: the solution vector. + + integer :: k, kb, kp1, nm1, nm2 + real(wp) :: t + + info = 0 + c(1) = d(1) + nm1 = n - 1 + + if (nm1 >= 1) then + d(1) = e(1) + e(1) = 0.0_wp + e(n) = 0.0_wp + + do k = 1, nm1 + kp1 = k + 1 + + ! find the largest of the two rows + + if (abs(c(kp1)) >= abs(c(k))) then + ! interchange row + t = c(kp1) + c(kp1) = c(k) + c(k) = t + t = d(kp1) + d(kp1) = d(k) + d(k) = t + t = e(kp1) + e(kp1) = e(k) + e(k) = t + t = b(kp1) + b(kp1) = b(k) + b(k) = t + end if + + ! zero elements + if (c(k) == 0.0_wp) then + info = k + return + end if + + t = -c(kp1)/c(k) + c(kp1) = d(kp1) + t*d(k) + d(kp1) = e(kp1) + t*e(k) + e(kp1) = 0.0_wp + b(kp1) = b(kp1) + t*b(k) + end do + + end if + + if (c(n) == 0.0_wp) then + info = n + else + ! back solve + nm2 = n - 2 + b(n) = b(n)/c(n) + if (n /= 1) then + b(nm1) = (b(nm1) - d(nm1)*b(n))/c(nm1) + if (nm2 >= 1) then + do kb = 1, nm2 + k = nm2 - kb + 1 + b(k) = (b(k) - d(k)*b(k + 1) - e(k)*b(k + 2))/c(k) + end do + end if + end if + end if + + end subroutine dgtsl +!******************************************************************************** + +!******************************************************************************** +!> +! This subroutine attempts to calculate the integral of `f(x)` +! over the interval `a` to `b` with relative error not +! exceeding `epsil`. +! +! The result is obtained using a sequence of 1,3,7,15,31,63, +! 127, and 255 point interlacing formulae (no integrand +! evaluations are wasted) of respective degree 1,5,11,23, +! 47,95,191 and 383. the formulae are based on the optimal +! extension of the 3-point gauss formula. +! +!### See also +! * Details of the formulae are given in "The optimum addition of points +! to quadrature formulae" by t.n.l. patterson, maths. comp. +! vol 22,847-856,1968. +! * QUAD From [NSWC Mathematical Library](https://github.com/jacobwilliams/nswc) + +subroutine dquad(f, a, b, result, epsil, npts, icheck) + implicit none + + procedure(func) :: f !! function subprogram defining the integrand function `f(x)`. + real(wp),intent(in) :: a !! lower limit of integration. + real(wp),intent(in) :: b !! upper limit of integration. + real(wp),intent(out) :: result !! the value of the integral to the + !! specified relative accuracy. + real(wp),intent(in) :: epsil !! relative accuracy required. when the relative + !! difference of two successive formulae does not + !! exceed `epsil` the last formula computed is taken + !! as the result. + integer,intent(out) :: npts !! number integrand evaluations. + integer,intent(out) :: icheck !! on exit normally `icheck=0`. however if convergence + !! to the accuracy requested is not achieved `icheck=1` + !! on exit. + + real(wp) :: acum, diff, funct(127), fzero, sum, x + integer :: i, inew, iold, j + real(wp),dimension(8) :: results !! this array holds the results obtained by + !! the 1,3,7, etc., point formulae. the number of + !! formulae computed depends on `epsil`. + integer :: k !! `results(k)` holds the value of the integral to the + !! specified relative accuracy. + + !> + ! abscissae and weights of quadrature rules are stacked in + ! array `p` in the order in which they are needed. + real(wp),dimension(381),parameter :: p = [ 7.74596669241483377035853079956479922167e-1_wp, & + 5.55555555555555555555555555555555555556e-1_wp, & + 8.88888888888888888888888888888888888889e-1_wp, & + 2.68488089868333440728569280666709624761e-1_wp, & + 9.60491268708020283423507092629079962670e-1_wp, & + 1.04656226026467265193823857192073038242e-1_wp, & + 4.34243749346802558002071502844627817283e-1_wp, & + 4.01397414775962222905051818618431878727e-1_wp, & + 4.50916538658474142345110087045570916539e-1_wp, & + 1.34415255243784220359968764802491520513e-1_wp, & + 5.16032829970797396969201205678609837136e-2_wp, & + 2.00628529376989021033931873331359306159e-1_wp, & + 9.93831963212755022208512841307951444370e-1_wp, & + 1.70017196299402603390274174026535252385e-2_wp, & + 8.88459232872256998890420167258502892651e-1_wp, & + 9.29271953151245376858942226541688263538e-2_wp, & + 6.21102946737226402940687443816594795012e-1_wp, & + 1.71511909136391380787353165019717217859e-1_wp, & + 2.23386686428966881628203986843998040091e-1_wp, & + 2.19156858401587496403693161643773747710e-1_wp, & + 2.25510499798206687386422549155949744906e-1_wp, & + 6.72077542959907035404010635813430091802e-2_wp, & + 2.58075980961766535646461187652328497046e-2_wp, & + 1.00314278611795578771293642695006079161e-1_wp, & + 8.43456573932110624631492964416019854788e-3_wp, & + 4.64628932617579865414046429639417161231e-2_wp, & + 8.57559200499903511541865204367976552400e-2_wp, & + 1.09578421055924638236688360572517068437e-1_wp, & + 9.99098124967667597662226062412998227686e-1_wp, & + 2.54478079156187441540278232983103810087e-3_wp, & + 9.81531149553740106867361888547025995016e-1_wp, & + 1.64460498543878109337883880689799875528e-2_wp, & + 9.29654857429740056670125725933373526769e-1_wp, & + 3.59571033071293220967778262209699862374e-2_wp, & + 8.36725938168868735502753818110221989775e-1_wp, & + 5.69795094941233574121973665457200316724e-2_wp, & + 7.02496206491527078609800156008001394343e-1_wp, & + 7.68796204990035310427051900809456411508e-2_wp, & + 5.31319743644375623972103438052468706781e-1_wp, & + 9.36271099812644736166587803392598658389e-2_wp, & + 3.31135393257976833092640782248746539410e-1_wp, & + 1.05669893580234809743815890442168534725e-1_wp, & + 1.12488943133186625745843327560318993879e-1_wp, & + 1.11956873020953456880143562321223860344e-1_wp, & + 1.12755256720768691607149869983804955967e-1_wp, & + 3.36038771482077305417339884731735403814e-2_wp, & + 1.29038001003512656259766532186329120125e-2_wp, & + 5.01571393058995374136795474239510758613e-2_wp, & + 4.21763044155885483908422682357386192911e-3_wp, & + 2.32314466399102694432564889365852548106e-2_wp, & + 4.28779600250077344929123037819815802239e-2_wp, & + 5.47892105279628650322175309941558213286e-2_wp, & + 1.26515655623006801137260909998182196593e-3_wp, & + 8.22300795723592966925778441546773952923e-3_wp, & + 1.79785515681282703328960466708609587502e-2_wp, & + 2.84897547458335486125060947723978716475e-2_wp, & + 3.84398102494555320386403467778787096784e-2_wp, & + 4.68135549906280124026480823343486642930e-2_wp, & + 5.28349467901165198620766563965308399269e-2_wp, & + 5.59784365104763194075533785872269074002e-2_wp, & + 9.99872888120357611937956782213944071260e-1_wp, & + 3.63221481845530659693580600240556307992e-4_wp, & + 9.97206259372221959076452532976228304987e-1_wp, & + 2.57904979468568827242779555856155526923e-3_wp, & + 9.88684757547429479938528919613635431554e-1_wp, & + 6.11550682211724633967828383326055155253e-3_wp, & + 9.72182874748581796578058835234688013989e-1_wp, & + 1.04982469096213218982728445836355320904e-2_wp, & + 9.46342858373402905148496208230196252152e-1_wp, & + 1.54067504665594978021308263315475287125e-2_wp, & + 9.10371156957004292497790670606627802042e-1_wp, & + 2.05942339159127111491885619503196295807e-2_wp, & + 8.63907938193690477146415857372833975090e-1_wp, & + 2.58696793272147469107582662448480815698e-2_wp, & + 8.06940531950217611856307980888497524441e-1_wp, & + 3.10735511116879648798843878245423584976e-2_wp, & + 7.39756044352694758677217797247847849281e-1_wp, & + 3.60644327807825726401071605896068916356e-2_wp, & + 6.62909660024780595461015255689389143141e-1_wp, & + 4.07155101169443189338940956005120803688e-2_wp, & + 5.77195710052045814843690955654189188852e-1_wp, & + 4.49145316536321974142542482618307358856e-2_wp, & + 4.83618026945841027562153280531749528761e-1_wp, & + 4.85643304066731987159471181667515286036e-2_wp, & + 3.83359324198730346916485193850312924770e-1_wp, & + 5.15832539520484587768091008575259100889e-2_wp, & + 2.77749822021824315065356412191446337302e-1_wp, & + 5.39054993352660639268769548863627639088e-2_wp, & + 1.68235251552207464982313275440102194714e-1_wp, & + 5.54814043565593639878384079955474248395e-2_wp, & + 5.63443130465927899719678607894467994099e-2_wp, & + 5.62776998312543012725953494255420385181e-2_wp, & + 5.63776283603847173876625571652345456628e-2_wp, & + 1.68019385741038652708694177373376419512e-2_wp, & + 6.45190005017573692280509776823864801062e-3_wp, & + 2.50785696529497687068397738442843404553e-2_wp, & + 2.10881524572663287933255325908005307552e-3_wp, & + 1.16157233199551347269849538868063638578e-2_wp, & + 2.14389800125038672464561593340624586806e-2_wp, & + 2.73946052639814325161087655093506901318e-2_wp, & + 6.32607319362633544219014096675880699298e-4_wp, & + 4.11150397865469304717026799389472424747e-3_wp, & + 8.98927578406413572328060374118804325340e-3_wp, & + 1.42448773729167743063415662436440605523e-2_wp, & + 1.92199051247277660193202803314218350072e-2_wp, & + 2.34067774953140062013240419700257395196e-2_wp, & + 2.64174733950582599310383282311985688836e-2_wp, & + 2.79892182552381597037766893004181239916e-2_wp, & + 1.80739564445388357820333919514772193888e-4_wp, & + 1.28952408261041739209850869778722441219e-3_wp, & + 3.05775341017553113613138395354134040323e-3_wp, & + 5.24912345480885912513384612635322646208e-3_wp, & + 7.70337523327974184816597819689326816907e-3_wp, & + 1.02971169579563555236864641070254134718e-2_wp, & + 1.29348396636073734547339558742365283615e-2_wp, & + 1.55367755558439824399284170162975429371e-2_wp, & + 1.80322163903912863200530999857265918070e-2_wp, & + 2.03577550584721594669470211177738968197e-2_wp, & + 2.24572658268160987071271218144441916129e-2_wp, & + 2.42821652033365993579735587740315274638e-2_wp, & + 2.57916269760242293884045503660307978007e-2_wp, & + 2.69527496676330319634384774240575382488e-2_wp, & + 2.77407021782796819939192039890754553228e-2_wp, & + 2.81388499156271506362976747068974890301e-2_wp, & + 9.99982430354891598580012135905109717915e-1_wp, & + 5.05360952078625176246656006337139648434e-5_wp, & + 9.99598799671910683251967529211801629987e-1_wp, & + 3.77746646326984660274364525157659292846e-4_wp, & + 9.98316635318407392530634580111074984770e-1_wp, & + 9.38369848542381500794044394681832138117e-4_wp, & + 9.95724104698407188509439459018460213288e-1_wp, & + 1.68114286542146990631373023491466618281e-3_wp, & + 9.91495721178106132398500079082519841189e-1_wp, & + 2.56876494379402037312771598563833315664e-3_wp, & + 9.85371499598520371113758241326513834962e-1_wp, & + 3.57289278351729964938448769864570199506e-3_wp, & + 9.77141514639705714156395810916629371363e-1_wp, & + 4.67105037211432174740543340826718946450e-3_wp, & + 9.66637851558416567092279836370846960853e-1_wp, & + 5.84344987583563950755951196450566504689e-3_wp, & + 9.53730006425761136414748643963112198908e-1_wp, & + 7.07248999543355546804631626841303341137e-3_wp, & + 9.38320397779592883654822310657872070243e-1_wp, & + 8.34283875396815770558412424167922936020e-3_wp, & + 9.20340025470012420729821382965612468142e-1_wp, & + 9.64117772970253669529830300284767390288e-3_wp, & + 8.99744899776940036638633212194468142956e-1_wp, & + 1.09557333878379016480327257363071595543e-2_wp, & + 8.76513414484705269741626645388423610417e-1_wp, & + 1.22758305600827700869663307413667617882e-2_wp, & + 8.50644494768350279757827407542049433990e-1_wp, & + 1.35915710097655467895729161814962317789e-2_wp, & + 8.22156254364980407372527142399375938309e-1_wp, & + 1.48936416648151820348103959267637767075e-2_wp, & + 7.91084933799848361434638057884175040395e-1_wp, & + 1.61732187295777199419479627980342182818e-2_wp, & + 7.57483966380513637926269606413039215349e-1_wp, & + 1.74219301594641737471522631397278549267e-2_wp, & + 7.21423085370098915484976184424530392547e-1_wp, & + 1.86318482561387901863140395332782911045e-2_wp, & + 6.82987431091079228087077605443637571318e-1_wp, & + 1.97954950480974994880277229389153128227e-2_wp, & + 6.42276642509759513774113624213729383798e-1_wp, & + 2.09058514458120238522218505878770859167e-2_wp, & + 5.99403930242242892974251049643553400441e-1_wp, & + 2.19563663053178249392605004207807929855e-2_wp, & + 5.54495132631932548866381362001869387185e-1_wp, & + 2.29409642293877487608005319195974357365e-2_wp, & + 5.07687757533716602154783137518047824630e-1_wp, & + 2.38540521060385400804460326687470805434e-2_wp, & + 4.59130011989832332873501971840246609692e-1_wp, & + 2.46905247444876769090608353528487841618e-2_wp, & + 4.08979821229888672409031653482169654497e-1_wp, & + 2.54457699654647658125743963445742965154e-2_wp, & + 3.57403837831532152376214925551056574778e-1_wp, & + 2.61156733767060976804988093771272602809e-2_wp, & + 3.04576441556714043335324049984830586514e-1_wp, & + 2.66966229274503599061546992881962515319e-2_wp, & + 2.50678730303483176612957105310757374530e-1_wp, & + 2.71855132296247918192086027320328453777e-2_wp, & + 1.95897502711100153915460230694341454649e-1_wp, & + 2.75797495664818730348687126189110696657e-2_wp, & + 1.40424233152560174593819634863430055039e-1_wp, & + 2.78772514766137016085237966902996263720e-2_wp, & + 8.44540400837108837101821672793851125821e-2_wp, & + 2.80764557938172466068478485336831566215e-2_wp, & + 2.81846489497456943393973278703614550567e-2_wp, & + 2.81763190330166021306535805326311346689e-2_wp, & + 2.81888141801923586938312785882097958145e-2_wp, & + 8.40096928705193263543470886866882097559e-3_wp, & + 3.22595002508786846140254888664674399963e-3_wp, & + 1.25392848264748843534198869221421702276e-2_wp, & + 1.05440762286331677224956681256723093434e-3_wp, & + 5.80786165997756736349247694340318193339e-3_wp, & + 1.07194900062519336232280796670312293403e-2_wp, & + 1.36973026319907162580543827546753450659e-2_wp, & + 3.16303660822264476886001542319765673695e-4_wp, & + 2.05575198932734652358557179891967892437e-3_wp, & + 4.49463789203206786164030187059407895106e-3_wp, & + 7.12243868645838715317078312182203027615e-3_wp, & + 9.60995256236388300966014016571091750361e-3_wp, & + 1.17033887476570031006620209850128697598e-2_wp, & + 1.32087366975291299655191641155992844418e-2_wp, & + 1.39946091276190798518883446502090619958e-2_wp, & + 9.03727346587511492612048292799447801127e-5_wp, & + 6.44762041305724779327197260132661244643e-4_wp, & + 1.52887670508776556838105789798193451205e-3_wp, & + 2.62456172740442956256692394303736650452e-3_wp, & + 3.85168761663987092408298909845685878251e-3_wp, & + 5.14855847897817776184323205351270717418e-3_wp, & + 6.46741983180368672736697793711826418082e-3_wp, & + 7.76838777792199121996420850814877146855e-3_wp, & + 9.01610819519564316002654999286329590351e-3_wp, & + 1.01788775292360797334735105588869484098e-2_wp, & + 1.12286329134080493535635609072220958065e-2_wp, & + 1.21410826016682996789867793870157637319e-2_wp, & + 1.28958134880121146942022751830153989003e-2_wp, & + 1.34763748338165159817192387120287691244e-2_wp, & + 1.38703510891398409969596019945377276614e-2_wp, & + 1.40694249578135753181488373534487445151e-2_wp, & + 2.51578703842806614886029901874368269190e-5_wp, & + 1.88873264506504913660930569062668820773e-4_wp, & + 4.69184924247850409754566477203398287419e-4_wp, & + 8.40571432710722463646844648204542489678e-4_wp, & + 1.28438247189701017680511226368885244509e-3_wp, & + 1.78644639175864982468103287043436779759e-3_wp, & + 2.33552518605716087370269795035052675936e-3_wp, & + 2.92172493791781975377975593711547903293e-3_wp, & + 3.53624499771677773402315813405234465284e-3_wp, & + 4.17141937698407885279206212083887894115e-3_wp, & + 4.82058886485126834764915150142383212497e-3_wp, & + 5.47786669391895082401636286815357973430e-3_wp, & + 6.13791528004138504348316537068338089359e-3_wp, & + 6.79578550488277339478645809074811588946e-3_wp, & + 7.44682083240759101740519796338188835376e-3_wp, & + 8.08660936478885997097398139901710914092e-3_wp, & + 8.71096507973208687357613156986392746334e-3_wp, & + 9.31592412806939509315701976663914555223e-3_wp, & + 9.89774752404874974401386146945765641137e-3_wp, & + 1.04529257229060119261109252939385429584e-2_wp, & + 1.09781831526589124696302502103903964927e-2_wp, & + 1.14704821146938743804002659597987178682e-2_wp, & + 1.19270260530192700402230163343735402717e-2_wp, & + 1.23452623722438384545304176764243920809e-2_wp, & + 1.27228849827323829062871981722871482577e-2_wp, & + 1.30578366883530488402494046885636301405e-2_wp, & + 1.33483114637251799530773496440981257659e-2_wp, & + 1.35927566148123959096043013660164226889e-2_wp, & + 1.37898747832409365174343563094555348329e-2_wp, & + 1.39386257383068508042618983451498131860e-2_wp, & + 1.40382278969086233034239242668415783107e-2_wp, & + 1.40881595165083010653267902663155673344e-2_wp, & + 9.99997596379748464620231592559093837611e-1_wp, & + 6.93793643241082671695382297169979368601e-6_wp, & + 9.99943996207054375763853646470050626596e-1_wp, & + 5.32752936697806131253524393895881823770e-5_wp, & + 9.99760490924432047330447933438138365417e-1_wp, & + 1.35754910949228719729842895656339874910e-4_wp, & + 9.99380338025023581928079338774322759519e-1_wp, & + 2.49212400482997294024537662868023009356e-4_wp, & + 9.98745614468095114703528542397791959986e-1_wp, & + 3.89745284473282293215563879845838727539e-4_wp, & + 9.97805354495957274561833338685736105778e-1_wp, & + 5.54295314930374714917732120266906130439e-4_wp, & + 9.96514145914890273848684083613153803279e-1_wp, & + 7.40282804244503330463160177700222594979e-4_wp, & + 9.94831502800621000519130529785414200225e-1_wp, & + 9.45361516858525382463015198607451979300e-4_wp, & + 9.92721344282788615328202203758497351413e-1_wp, & + 1.16748411742995940769333157872940045783e-3_wp, & + 9.90151370400770159180535140748087193102e-1_wp, & + 1.40490799565514464271521123296916900291e-3_wp, & + 9.87092527954034067189898792468859039993e-1_wp, & + 1.65611272815445260521682786451135109534e-3_wp, & + 9.83518657578632728761664630770795617152e-1_wp, & + 1.91971297101387241252271734466970358673e-3_wp, & + 9.79406281670862683806133521363753397925e-1_wp, & + 2.19440692536383883880291840868628867052e-3_wp, & + 9.74734459752402667760726712997609707570e-1_wp, & + 2.47895822665756793067821535745476374906e-3_wp, & + 9.69484659502459231770908123207442170150e-1_wp, & + 2.77219576459345099399521424961083418592e-3_wp, & + 9.63640621569812132520974048832142316972e-1_wp, & + 3.07301843470257832340783765226605973620e-3_wp, & + 9.57188216109860962736208621751374728884e-1_wp, & + 3.38039799108692038234993039038885672945e-3_wp, & + 9.50115297521294876557842262038304179472e-1_wp, & + 3.69337791702565081825729998764452535617e-3_wp, & + 9.42411565191083059812560025758972247897e-1_wp, & + 4.01106872407502339888993614903965571565e-3_wp, & + 9.34068436157725787999477771530264179420e-1_wp, & + 4.33264096809298285453769983324695296414e-3_wp, & + 9.25078932907075652364132996222672693491e-1_wp, & + 4.65731729975685477727794484849624969667e-3_wp, & + 9.15437587155765040643953616154536973514e-1_wp, & + 4.98436456476553860120001022162080486896e-3_wp, & + 9.05140358813261595189303779754262290451e-1_wp, & + 5.31308660518705656628804340372923963811e-3_wp, & + 8.94184568335559022859352159222674193953e-1_wp, & + 5.64281810138444415845460587311671071412e-3_wp, & + 8.82568840247341906841695404228946666934e-1_wp, & + 5.97291956550816580494729856935913899149e-3_wp, & + 8.70293055548113905851151444154923420039e-1_wp, & + 6.30277344908575871716398763418949052534e-3_wp, & + 8.57358310886232156525126596087163923324e-1_wp, & + 6.63178124290188789412200734180398266358e-3_wp, & + 8.43766882672708601038314138625718101532e-1_wp, & + 6.95936140939042293944507544479114448976e-3_wp, & + 8.29522194637401400178105088351227616660e-1_wp, & + 7.28494798055380706387981147534993110085e-3_wp, & + 8.14628787655137413435816577891367083540e-1_wp, & + 7.60798966571905658321739694223386579593e-3_wp, & + 7.99092290960841401799803164024282388556e-1_wp, & + 7.92794933429484911025254235115728574858e-3_wp, & + 7.82919394118283016385180478369806362244e-1_wp, & + 8.24430376303286803055059706535356438929e-3_wp, & + 7.66117819303760090716674093891474570508e-1_wp, & + 8.55654356130768961917293275004918273728e-3_wp, & + 7.48696293616936602822828737479369222926e-1_wp, & + 8.86417320948249426411429453091759055196e-3_wp, & + 7.30664521242181261329306715350070027793e-1_wp, & + 9.16671116356078840670519648472888628456e-3_wp, & + 7.12033155362252034586679081013994469857e-1_wp, & + 9.46368999383006529427243113943215866506e-3_wp, & + 6.92813769779114702894651485928486730921e-1_wp, & + 9.75465653631741146108293452735497379607e-3_wp, & + 6.73018830230418479198879472689545414663e-1_wp, & + 1.00391720440568407981810290438378080094e-2_wp, & + 6.52661665410017496100770934689234627423e-1_wp, & + 1.03168123309476216819207000244181912440e-2_wp, & + 6.31756437711194230413584623172536712454e-1_wp, & + 1.05871679048851979309428189932402399185e-2_wp, & + 6.10318113715186400155578672320162394224e-1_wp, & + 1.08498440893373140990245263318076192187e-2_wp, & + 5.88362434447662541434367386275547111879e-1_wp, & + 1.11044611340069265369994188454572096386e-2_wp, & + 5.65905885423654422622970392231343950219e-1_wp, & + 1.13506543159805966017344840804968802477e-2_wp, & + 5.42965666498311490492303133422203430532e-1_wp, & + 1.15880740330439525684239776012385794172e-2_wp, & + 5.19559661537457021992914143047305013398e-1_wp, & + 1.18163858908302357632247900084966241627e-2_wp, & + 4.95706407918761460170111534008667847416e-1_wp, & + 1.20352707852795626304498694306103606393e-2_wp, & + 4.71425065871658876934088018252224136473e-1_wp, & + 1.22444249816119858986292063324627371480e-2_wp, & + 4.46735387662028473742222281592907967623e-1_wp, & + 1.24435601907140352631495031087115129475e-2_wp, & + 4.21657686626163300056304726883310969563e-1_wp, & + 1.26324036435420787645405441085200317588e-2_wp, & + 3.96212806057615939182521394284924513267e-1_wp, & + 1.28106981638773619668417039218064387909e-2_wp, & + 3.70422087950078230137537383958155880174e-1_wp, & + 1.29782022395373992858421803348245496762e-2_wp, & + 3.44307341599438022776622416041385263462e-1_wp, & + 1.31346900919601528363813260381779658443e-2_wp, & + 3.17890812068476683181739338725980798218e-1_wp, & + 1.32799517439305306503775089710281336690e-2_wp, & + 2.91195148518246681963691099017626573079e-1_wp, & + 1.34137930851100985129663776085717215632e-2_wp, & + 2.64243372410926761944948292977628978728e-1_wp, & + 1.35360359349562136136653091890522717067e-2_wp, & + 2.37058845589829727212668030348623871778e-1_wp, & + 1.36465181025712914283998912158692590540e-2_wp, & + 2.09665238243181194766342717964439602895e-1_wp, & + 1.37450934430018966322520540025550273779e-2_wp, & + 1.82086496759252198246399488588060039322e-1_wp, & + 1.38316319095064286764959688535114143323e-2_wp, & + 1.54346811481378108692446779987579230421e-1_wp, & + 1.39060196013254612635312215253609885781e-2_wp, & + 1.26470584372301966850663538758563345841e-1_wp, & + 1.39681588065169385157277797674326721757e-2_wp, & + 9.84823965981192020902757578971386695319e-2_wp, & + 1.40179680394566088098722249688496041850e-2_wp, & + 7.04069760428551790632968760555968372924e-2_wp, & + 1.40553820726499642771679253311023986914e-2_wp, & + 4.22691647653636032124048988444769492564e-2_wp, & + 1.40803519625536613248458411104536513059e-2_wp, & + 1.40938864107824626141884882355263630430e-2_wp, & + 1.40928450691604083549592735386756230351e-2_wp, & + 1.40944070900961793469156392941048979072e-2_wp ] + + icheck = 0 + + ! check for trivial case. + if (a == b) then + ! trivial case + result = 0.0_wp + npts = 0 + return + else + ! scale factors. + sum = (b + a)/2.0_wp + diff = (b - a)/2.0_wp + ! 1-point gauss + fzero = f(sum) + results(1) = 2.0_wp*fzero*diff + i = 0 + iold = 0 + inew = 1 + k = 2 + acum = 0.0_wp + do + ! contribution from new function values. + iold = iold + inew + do j = inew, iold + i = i + 1 + x = p(i)*diff + funct(j) = f(sum + x) + f(sum - x) + i = i + 1 + acum = acum + p(i)*funct(j) + end do + inew = iold + 1 + i = i + 1 + results(k) = (acum + p(i)*fzero)*diff + ! check for convergence. + if (abs(results(k) - results(k - 1)) <= epsil*abs(results(k))) exit + if (k == 8) then + ! convergence not achieved. + icheck = 1 + exit + else + k = k + 1 + acum = 0.0_wp + ! contribution from function values already computed. + do j = 1, iold + i = i + 1 + acum = acum + p(i)*funct(j) + end do + end if + end do + result = results(k) + end if + + ! normal termination. + npts = inew + iold + + end subroutine dquad +!******************************************************************************** + +!******************************************************************************** +!> +! Integrate a function tabulated at arbitrarily spaced +! abscissas using overlapping parabolas. +! +! DAVINT integrates a function tabulated at arbitrarily spaced +! abscissas. The limits of integration need not coincide +! with the tabulated abscissas. +! +! A method of overlapping parabolas fitted to the data is used +! provided that there are at least 3 abscissas between the +! limits of integration. DAVINT also handles two special cases. +! If the limits of integration are equal, DAVINT returns a +! result of zero regardless of the number of tabulated values. +! If there are only two function values, DAVINT uses the +! trapezoid rule. +! +!### References +! * R. E. Jones, "Approximate integrator of functions +! tabulated at arbitrarily spaced abscissas", +! Report SC-M-69-335, Sandia Laboratories, 1969. +! * Original program from *Numerical Integration* by Davis & Rabinowitz +! Adaptation and modifications by Rondall E Jones. +! +!### Author +! * Jones, R. E., (SNLA) +! +!### Revision history +! * 690901 DATE WRITTEN +! * 890831 Modified array declarations. (WRB) +! * 890831 REVISION DATE from Version 3.2 +! * 891214 Prologue converted to Version 4.0 format. (BAB) +! * 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +! * 920501 Reformatted the REFERENCES section. (WRB) +! * Jacob Williams, Jan 2022 : modernized this procedure. + + subroutine davint(x,y,n,xlo,xup,ans,ierr) + + implicit none + + real(wp),dimension(:),intent(in) :: x !! array of abscissas, which must be in increasing order. + real(wp),dimension(:),intent(in) :: y !! array of function values. i.e., `y(i)=func(x(i))` + integer,intent(in) :: n !! The integer number of function values supplied. + !! `N >= 2` unless `XLO = XUP`. + real(wp),intent(in) :: xlo !! lower limit of integration + real(wp),intent(in) :: xup !! upper limit of integration. Must have `XLO <= XUP` + real(wp),intent(out) :: ans !! computed approximate value of integral + integer,intent(out) :: ierr !! A status code: + !! + !! * Normal Code + !! * =1 Means the requested integration was performed. + !! * Abnormal Codes + !! * =2 Means `XUP` was less than `XLO`. + !! * =3 Means the number of `X(I)` between `XLO` and `XUP` + !! (inclusive) was less than 3 and neither of the two + !! special cases described in the abstract occurred. + !! No integration was performed. + !! * =4 Means the restriction `X(I+1)>X(I)` was violated. + !! * =5 Means the number `N` of function values was < 2. + !! + !! ANS is set to zero if `IERR` = 2, 3, 4, or 5. + + integer :: i , inlft , inrt , istart , istop + real(wp) :: a , b , c , ca , cb , cc , fl , fr , r3 , & + rp5 , slope , sum , syl , syl2 , syl3 , syu , & + syu2 , syu3 , term1 , term2 , term3 , x1 , & + x12 , x13 , x2 , x23 , x3 + + ierr = 1 + ans = 0.0_wp + + ! error checks and trivial cases: + if (xlo == xup) return + if (xlo > xup) then + ierr = 2 + call xerror('the upper limit of integration was not greater '//& + 'than the lower limit.',4,1) + return + end if + if (n < 2) then + ierr = 5 + call xerror('less than two function values were supplied.', & + 4,1) + return + end if + do i = 2 , n + if ( x(i)<=x(i-1) ) then + ierr = 4 + call xerror('the abscissas were not strictly increasing. must have '& + //'x(i-1) < x(i) for all i.',4,1) + return + end if + if ( x(i)>xup ) exit + enddo + + if ( n<3 ) then + + ! special n=2 case + slope = (y(2)-y(1))/(x(2)-x(1)) + fl = y(1) + slope*(xlo-x(1)) + fr = y(2) + slope*(xup-x(2)) + ans = 0.5_wp*(fl+fr)*(xup-xlo) + + elseif ( x(n-2)=xlo ) then + inlft = i + i = n + do + if ( x(i)<=xup ) then + inrt = i + if ( (inrt-inlft)>=2 ) then + istart = inlft + if ( inlft==1 ) istart = 2 + istop = inrt + if ( inrt==n ) istop = n - 1 + r3 = 3.0_wp + rp5 = 0.5_wp + sum = 0.0_wp + syl = xlo + syl2 = syl*syl + syl3 = syl2*syl + do i = istart , istop + x1 = x(i-1) + x2 = x(i) + x3 = x(i+1) + x12 = x1 - x2 + x13 = x1 - x3 + x23 = x2 - x3 + term1 = y(i-1)/(x12*x13) + term2 = -y(i)/(x12*x23) + term3 = y(i+1)/(x13*x23) + a = term1 + term2 + term3 + b = -(x2+x3)*term1 - (x1+x3)*term2 - (x1+x2)*term3 + c = x2*x3*term1 + x1*x3*term2 + x1*x2*term3 + if ( i>istart ) then + ca = 0.5_wp*(a+ca) + cb = 0.5_wp*(b+cb) + cc = 0.5_wp*(c+cc) + else + ca = a + cb = b + cc = c + endif + syu = x2 + syu2 = syu*syu + syu3 = syu2*syu + sum = sum + ca*(syu3-syl3)/r3 + cb*rp5*(syu2-syl2) + cc*(syu-syl) + ca = a + cb = b + cc = c + syl = syu + syl2 = syu2 + syl3 = syu3 + enddo + syu = xup + ans = sum + ca*(syu**3-syl3)/r3 + cb*rp5*(syu**2-syl2) + cc*(syu-syl) + else + ierr = 3 + call xerror('there were less than three function values '& + //'between the limits of integration.',4,1) + endif + return + endif + i = i - 1 + end do + endif + i = i + 1 + end do + + else + ierr = 3 + call xerror('there were less than three function values '& + //'between the limits of integration.',4,1) + endif + + end subroutine davint +!******************************************************************************** + +!******************************************************************************** +!> +! Integrate a function using a 7-point adaptive Newton-Cotes +! quadrature rule. +! +! DQNC79 is a general purpose program for evaluation of +! one dimensional integrals of user defined functions. +! DQNC79 will pick its own points for evaluation of the +! integrand and these will vary from problem to problem. +! Thus, DQNC79 is not designed to integrate over data sets. +! Moderately smooth integrands will be integrated efficiently +! and reliably. For problems with strong singularities, +! oscillations etc., the user may wish to use more sophis- +! ticated routines such as those in QUADPACK. One measure +! of the reliability of DQNC79 is the output parameter `K`, +! giving the number of integrand evaluations that were needed. +! +!### Author +! * Kahaner, D. K., (NBS) +! * Jones, R. E., (SNLA) +! +!### Revision history (YYMMDD) +! * 790601 DATE WRITTEN +! * 890531 Changed all specific intrinsics to generic. (WRB) +! * 890911 Removed unnecessary intrinsics. (WRB) +! * 890911 REVISION DATE from Version 3.2 +! * 891214 Prologue converted to Version 4.0 format. (BAB) +! * 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +! * 920218 Code redone to parallel QNC79. (WRB) +! * 930120 Increase array size 80->99, and KMX 2000->5000 for SUN -r8 wordlength. (RWC) +! * Jacob Williams, Jan 2022 : modernized the SLATEC procedure. added quad-precision coefficients. +! +!@note This one has a lot of failures in the test cases. + + subroutine dqnc79(fun,a,b,err,ans,ierr,k) + + implicit none + + procedure(func) :: fun !! function subprogram defining the integrand function `f(x)`. + real(wp),intent(in) :: a !! lower limit of integration + real(wp),intent(in) :: b !! upper limit of integration (may be less than `A`) + real(wp),intent(in) :: err !! a requested error tolerance. Normally, pick a value + !! `0 < ERR < 1.0e-8`. + real(wp),intent(out) :: ans !! computed value of the integral. Hopefully, `ANS` is + !! accurate to within `ERR *` integral of `ABS(FUN(X))`. + integer,intent(out) :: ierr !! a status code: + !! + !! * Normal codes + !! * **1** `ANS` most likely meets requested error tolerance. + !! * **-1** `A` and `B` are too nearly equal to + !! allow normal integration. `ANS` is set to zero. + !! * Abnormal code + !! * **2** `ANS` probably does not meet requested error tolerance. + integer,intent(out) :: k !! the number of function evaluations actually used to do + !! the integration. A value of `K > 1000` indicates a + !! difficult problem; other programs may be more efficient. + !! `DQNC79` will gracefully give up if `K` exceeds 5000. + + real(wp),parameter :: w1 = 41.0_wp/140.0_wp + real(wp),parameter :: w2 = 216.0_wp/140.0_wp + real(wp),parameter :: w3 = 27.0_wp/140.0_wp + real(wp),parameter :: w4 = 272.0_wp/140.0_wp + real(wp),parameter :: sq2 = sqrt(2.0_wp) + real(wp),parameter :: ln2 = log(2.0_wp) + integer,parameter :: nbits = int(d1mach(5)*i1mach14/0.30102000_wp) !! is 0.30102000 supposed to be log10(2.0_wp) ??? + integer,parameter :: nlmx = min(99, (nbits*4)/5) + integer,parameter :: nlmn = 2 + integer,parameter :: kml = 7 + integer,parameter :: kmx = 5000 !! JW : is this the max function evals? should be an input + integer,parameter :: array_size = 99 !! JW : what is this magic number 99 array size ?? + !! does it depend on the number of function evals ? + !! (see comment in revision history) + + real(wp) :: ae,area,bank,blocal,c,ce,ee,ef,eps,q13,q7,q7l,test,tol,vr + integer :: i,l,lmn,lmx,nib + real(wp),dimension(13) :: f + real(wp),dimension(array_size) :: aa,f1,f2,f3,f4,f5,f6,f7,hh,q7r,vl + integer,dimension(array_size) :: lr + + ans = 0.0_wp + ierr = 1 + if ( a==b ) return ! JW : this was an error return in the original code + + ce = 0.0_wp + lmx = nlmx + lmn = nlmn + if ( b/=0.0_wp ) then + if ( sign(1.0_wp,b)*a>0.0_wp ) then + c = abs(1.0_wp-a/b) + if ( c<=0.1_wp ) then + if ( c<=0.0_wp ) then + ierr = -1 + call xerror('a and b are too nearly equal to allow normal integration. '& + //'ans is set to zero and ierr to -1.',-1,-1) + return + end if + nib = 0.5_wp - log(c)/ln2 + lmx = min(nlmx,nbits-nib-4) + if ( lmx<2 ) then + call xerror('a and b are too nearly equal to allow normal integration. '& + //'ans is set to zero and ierr to -1.',-1,-1) + return + end if + lmn = min(lmn,lmx) + endif + endif + endif + tol = max(abs(err),2.0_wp**(5-nbits)) + if ( err==0.0_wp ) tol = sqrt(epmach) + eps = tol + hh(1) = (b-a)/12.0_wp + aa(1) = a + lr(1) = 1 + do i = 1 , 11 , 2 + f(i) = fun(a+(i-1)*hh(1)) + enddo + blocal = b + f(13) = fun(blocal) + k = 7 + l = 1 + area = 0.0_wp + q7 = 0.0_wp + ef = 256.0_wp/255.0_wp + bank = 0.0_wp + + loop : do + + ! compute refined estimates, estimate the error, etc. + do i = 2 , 12 , 2 + f(i) = fun(aa(l)+(i-1)*hh(l)) + enddo + k = k + 6 + + ! compute left and right half estimates + q7l = hh(l)*((w1*(f(1)+f(7))+w2*(f(2)+f(6)))+(w3*(f(3)+f(5))+w4*f(4))) + q7r(l) = hh(l)*((w1*(f(7)+f(13))+w2*(f(8)+f(12)))+(w3*(f(9)+f(11))+w4*f(10))) + + ! update estimate of integral of absolute value + area = area + (abs(q7l)+abs(q7r(l))-abs(q7)) + + ! do not bother to test convergence before minimum refinement level + if ( l>=lmn ) then + + ! estimate the error in new value for whole interval, q13 + q13 = q7l + q7r(l) + ee = abs(q7-q13)*ef + + ! compute nominal allowed error + ae = eps*area + + ! borrow from bank account, but not too much + test = min(ae+0.8_wp*bank,10.0_wp*ae) + + ! don't ask for excessive accuracy + test = max(test,tol*abs(q13),0.00003_wp*tol*area) ! jw : should change ? + + ! now, did this interval pass or not? + if ( ee<=test ) then + ! on good intervals accumulate the theoretical estimate + ce = ce + (q7-q13)/255.0_wp + else + ! consider the left half of next deeper level + if ( k>kmx ) lmx = min(kml,lmx) + if ( l2.0_wp*tol*area ) then + ierr = 2 + call xerror('ans is probably insufficiently accurate.',2,1) + endif + return + else + if ( l<=17 ) ef = ef*sq2 + eps = eps*2.0_wp + l = l - 1 + if ( lr(l)<=0 ) then + vl(l) = vl(l+1) + vr + call f300() + cycle loop + else + vr = vl(l+1) + vr + endif + endif + end do + endif + endif + + call f200() + + end do loop + + contains + + subroutine f200() + l = l + 1 + eps = eps*0.5_wp + if ( l<=17 ) ef = ef/sq2 + hh(l) = hh(l-1)*0.5_wp + lr(l) = -1 + aa(l) = aa(l-1) + q7 = q7l + f1(l) = f(7) + f2(l) = f(8) + f3(l) = f(9) + f4(l) = f(10) + f5(l) = f(11) + f6(l) = f(12) + f7(l) = f(13) + f(13) = f(7) + f(11) = f(6) + f(9) = f(5) + f(7) = f(4) + f(5) = f(3) + f(3) = f(2) + end subroutine f200 + + subroutine f300() + q7 = q7r(l-1) + lr(l) = 1 + aa(l) = aa(l) + 12.0_wp*hh(l) + f(1) = f1(l) + f(3) = f2(l) + f(5) = f3(l) + f(7) = f4(l) + f(9) = f5(l) + f(11) = f6(l) + f(13) = f7(l) + end subroutine f300 + + end subroutine dqnc79 +!******************************************************************************** + +!******************************************************************************** +!> +! Integrate a real function of one variable over a finite +! interval using an adaptive 8-point Legendre-Gauss +! algorithm. +! +! Intended primarily for high accuracy +! integration or integration of smooth functions. +! +!### See also +! * Original SLATEC sourcecode from: http://www.netlib.org/slatec/src/dgaus8.f +! +!### History +! * Author: Jones, R. E., (SNLA) +! * 810223 DATE WRITTEN +! * 890531 Changed all specific intrinsics to generic. (WRB) +! * 890911 Removed unnecessary intrinsics. (WRB) +! * 890911 REVISION DATE from Version 3.2 +! * 891214 Prologue converted to Version 4.0 format. (BAB) +! * 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +! * 900326 Removed duplicate information from DESCRIPTION section. (WRB) +! * Jacob Williams : Jan 2022 : refactored SLATEC routine to modern Fortran. + + subroutine dgauss8( f, a, b, error_tol, ans, ierr, err) + + implicit none + + procedure(func) :: f !! function subprogram defining the integrand function `f(x)`. + real(wp),intent(in) :: a !! lower bound of the integration + real(wp),intent(in) :: b !! upper bound of the integration + real(wp),intent(in) :: error_tol !! is a requested pseudorelative error tolerance. normally + !! pick a value of abs(error_tol) so that + !! `dtol < abs(error_tol) <= 1.0e-3` where dtol is the larger + !! of `1.0e-18 `and the real unit roundoff `d1mach(4)`. + !! `ans` will normally have no more error than `abs(error_tol)` + !! times the integral of the absolute value of `f(x)`. usually, + !! smaller values of error_tol yield more accuracy and require + !! more function evaluations. + real(wp),intent(out) :: ans !! computed value of integral + integer,intent(out) :: ierr !! status code: + !! + !! * normal codes: + !! * 1 : `ans` most likely meets requested error tolerance, + !! or `a=b`. + !! * -1 : `a` and `b` are too nearly equal to allow normal + !! integration. `ans` is set to zero. + !! * abnormal code: + !! * 2 : `ans` probably does not meet requested error tolerance. + real(wp),intent(out) :: err !! an estimate of the absolute error in `ans`. + !! the estimated error is solely for information to the user and + !! should not be used as a correction to the computed integral. + + ! note: see also dqnc79 for some clues about the purpose of these numbers... + real(wp),parameter :: sq2 = sqrt(2.0_wp) + real(wp),parameter :: ln2 = log(2.0_wp) + integer,parameter :: kmx = 5000 + integer,parameter :: kml = 6 + real(wp),parameter :: magic = 0.30102000_wp !! is 0.30102000 supposed to be log10(2.0_wp) ??? + integer,parameter :: iwork = 60 !! size of the work arrays. ?? Why 60 ?? + integer,parameter :: nbits = int(d1mach(5)*i1mach14/magic) + integer,parameter :: nlmn = 1 + integer,parameter :: nlmx = min(60,(nbits*5)/8) + + integer :: k !! number of function evaluations + integer :: l,lmn,lmx,mxl,nib + real(wp) :: ae,area,c,ee,ef,eps,est,gl,glr,tol + real(wp),dimension(iwork) :: aa,hh,vl,gr + integer,dimension(iwork) :: lr + + ans = 0.0_wp + ierr = 1 + err = 0.0_wp + if (a == b) return + + aa = 0.0_wp + hh = 0.0_wp + vl = 0.0_wp + gr = 0.0_wp + lr = 0 + lmx = nlmx + lmn = nlmn + if (b /= 0.0_wp) then + if (sign(1.0_wp,b)*a > 0.0_wp) then + c = abs(1.0_wp-a/b) + if (c <= 0.1_wp) then + if (c <= 0.0_wp) return + nib = int(0.5_wp - log(c)/ln2) + lmx = min(nlmx,nbits-nib-7) + if (lmx < 1) then + ! a and b are too nearly equal to allow + ! normal integration [ans is set to zero] + ierr = -1 + return + end if + lmn = min(lmn,lmx) + end if + end if + end if + if (error_tol == 0.0_wp) then + tol = sqrt(epmach) + else + tol = max(abs(error_tol),2.0_wp**(5-nbits))/2.0_wp + end if + eps = tol + hh(1) = (b-a)/4.0_wp + aa(1) = a + lr(1) = 1 + l = 1 + est = g(aa(l)+2.0_wp*hh(l),2.0_wp*hh(l)) + k = 8 + area = abs(est) + ef = 0.5_wp + mxl = 0 + + !compute refined estimates, estimate the error, etc. + main : do + + gl = g(aa(l)+hh(l),hh(l)) + gr(l) = g(aa(l)+3.0_wp*hh(l),hh(l)) + k = k + 16 + area = area + (abs(gl)+abs(gr(l))-abs(est)) + glr = gl + gr(l) + ee = abs(est-glr)*ef + ae = max(eps*area,tol*abs(glr)) + if (ee-ae > 0.0_wp) then + !consider the left half of this level + if (k > kmx) lmx = kml + if (l >= lmx) then + mxl = 1 + else + l = l + 1 + eps = eps*0.5_wp + ef = ef/sq2 + hh(l) = hh(l-1)*0.5_wp + lr(l) = -1 + aa(l) = aa(l-1) + est = gl + cycle main + end if + end if + + err = err + (est-glr) + if (lr(l) > 0) then + !return one level + ans = glr + do + if (l <= 1) exit main ! finished + l = l - 1 + eps = eps*2.0_wp + ef = ef*sq2 + if (lr(l) <= 0) then + vl(l) = vl(l+1) + ans + est = gr(l-1) + lr(l) = 1 + aa(l) = aa(l) + 4.0_wp*hh(l) + cycle main + end if + ans = vl(l+1) + ans + end do + else + !proceed to right half at this level + vl(l) = glr + est = gr(l-1) + lr(l) = 1 + aa(l) = aa(l) + 4.0_wp*hh(l) + cycle main + end if + + end do main + + if ((mxl/=0) .and. (abs(err)>2.0_wp*tol*area)) ierr = 2 ! ans is probably insufficiently accurate + + contains + + !************************************************************************************ + !> + ! This is the 8-point formula from the original SLATEC routine + ! [DGAUS8](http://www.netlib.org/slatec/src/dgaus8.f). + ! + !@note replaced coefficients with high-precision ones from: + ! http://processingjs.nihongoresources.com/bezierinfo/legendre-gauss-values.php + + function g(x, h) + + implicit none + + real(wp),intent(in) :: x + real(wp),intent(in) :: h + real(wp) :: g + + !> abscissae: + real(wp),parameter :: x1 = 0.18343464249564980493947614236018398066675781291297378231718847_wp + real(wp),parameter :: x2 = 0.52553240991632898581773904918924634904196424312039285775085709_wp + real(wp),parameter :: x3 = 0.79666647741362673959155393647583043683717173161596483207017029_wp + real(wp),parameter :: x4 = 0.96028985649753623168356086856947299042823523430145203827163977_wp + + !> weights: + real(wp),parameter :: w1 = 0.36268378337836198296515044927719561219414603989433054052482306_wp + real(wp),parameter :: w2 = 0.31370664587788728733796220198660131326032899900273493769026394_wp + real(wp),parameter :: w3 = 0.22238103445337447054435599442624088443013087005124956472590928_wp + real(wp),parameter :: w4 = 0.10122853629037625915253135430996219011539409105168495705900369_wp + + g = h * ( w1*( f(x-x1*h) + f(x+x1*h) ) + & + w2*( f(x-x2*h) + f(x+x2*h) ) + & + w3*( f(x-x3*h) + f(x+x3*h) ) + & + w4*( f(x-x4*h) + f(x+x4*h) ) ) + + end function g + !************************************************************************************ + + end subroutine dgauss8 +!******************************************************************************** + +!******************************************************************************** +!> +! Numerically evaluate integral using adaptive Simpson rule. +! +!### See also +! * W. Gander and W. Gautschi, "Adaptive Quadrature - Revisited", +! BIT Vol. 40, No. 1, March 2000, pp. 84--101. + + recursive subroutine dsimpson (f, a, b, error_tol, ans, ierr) + + implicit none + + procedure(func) :: f !! function subprogram defining the integrand function `f(x)`. + real(wp),intent(in) :: a !! lower bound of the integration + real(wp),intent(in) :: b !! upper bound of the integration + real(wp),intent(in) :: error_tol !! relative error tolerance + real(wp),intent(out) :: ans !! computed value of integral + integer,intent(out) :: ierr !! status code: + !! + !! * 1 = success + !! * 2 = requested accuracy may not be satisfied + + real(wp) :: bma,is,tol,fa,fm,fb + real(wp),dimension(5) :: yy + integer :: k !! number of calls to the recursive function + + real(wp),parameter :: eps = epsilon(1.0_wp) + real(wp),dimension(5),parameter :: c = [.9501_wp, .2311_wp, .6068_wp, .4860_wp, .8913_wp] + integer,parameter :: kmax = 10000 !! maximum number of calls to the recursive function (probably should be an input) + + k = 0 + ierr = 1 + bma = b-a + tol = max(eps, error_tol) + + fa = f(a) + fm = f((a+b)/2.0_wp) + fb = f(b) + yy(1) = f(a+c(1)*bma ) + yy(2) = f(a+c(2)*bma ) + yy(3) = f(a+c(3)*bma ) + yy(4) = f(a+c(4)*bma ) + yy(5) = f(a+c(5)*bma ) + + is = bma/8.0_wp * (fa+fm+fb+sum(yy)) + if (is==0.0_wp) is = bma + is = is*tol/eps + + call adaptive_simpson_step(a,b,fa,fm,fb,is,ans) + + contains + + recursive subroutine adaptive_simpson_step (a,b,fa,fm,fb,is,ans) + !! Recursive function used by adaptive_simpson. + !! Tries to approximate the integral of f(x) from a to b + !! to an appropriate relative error. + + implicit none + + real(wp),intent(in) :: a + real(wp),intent(in) :: b + real(wp),intent(in) :: fa + real(wp),intent(in) :: fm + real(wp),intent(in) :: fb + real(wp),intent(in) :: is + real(wp),intent(out) :: ans + + real(wp) :: m,h,fml,fmr,i1,i2,q1,q2 + + k = k + 1 + if (k>kmax) then + ierr = 2 + ans = 0.0_wp + return + end if + m = (a + b)/2.0_wp + h = (b - a)/4.0_wp + fml = f(a + h) + fmr = f(b - h) + i1 = h/1.5_wp * (fa + 4.0_wp*fm + fb) + i2 = h/3.0_wp * (fa + 4.0_wp*(fml + fmr) + 2.0_wp*fm + fb) + i1 = (16.0_wp*i2 - i1)/15.0_wp + + if ( (is + (i1-i2) == is) .or. (m <= a) .or. (b <= m) ) then + + if ( ((m <= a) .or. (b<=m)) .and. (ierr==1) ) ierr = 2 + ans = i1 + + else + + if (ierr==1) call adaptive_simpson_step (a,m,fa,fml,fm,is,q1) + if (ierr==1) call adaptive_simpson_step (m,b,fm,fmr,fb,is,q2) + + if (ierr==1) then + ans = q1 + q2 + else + ans = i1 + end if + + end if + + end subroutine adaptive_simpson_step + !************************************************************** + + end subroutine dsimpson +!******************************************************************************** + +!******************************************************************************** +!> +! Numerically evaluate integral using adaptive Lobatto rule +! +!### See also +! * W. Gander and W. Gautschi, "Adaptive Quadrature - Revisited", +! BIT Vol. 40, No. 1, March 2000, pp. 84--101. + + recursive subroutine dlobatto (f, a, b, error_tol, ans, ierr) + + procedure(func) :: f !! function subprogram defining the integrand function `f(x)`. + real(wp),intent(in) :: a !! lower bound of the integration + real(wp),intent(in) :: b !! upper bound of the integration + real(wp),intent(in) :: error_tol !! relative error tolerance + real(wp),intent(out) :: ans !! computed value of integral + integer,intent(out) :: ierr !! status code: + !! + !! * 1 = success + !! * 2 = requested accuracy may not be satisfied + + real(wp) :: m,h,s,erri1,erri2,is,tol,fa,fb,i1,i2,r + real(wp),dimension(13) :: x,y + integer :: i + integer :: k !! number of calls to the recursive function + + integer,parameter :: kmax = 10000 !! maximum number of calls to the recursive function (probably should be an input) + real(wp),parameter :: eps = epsilon(1.0_wp) + real(wp),parameter :: alpha = sqrt(2.0_wp/3.0_wp) + real(wp),parameter :: beta = 1.0_wp/sqrt(5.0_wp) + real(wp),parameter :: x1 = .94288241569547971905635175843185720232_wp + real(wp),parameter :: x2 = .64185334234578130578123554132903188354_wp + real(wp),parameter :: x3 = .23638319966214988028222377349205292599_wp + real(wp),dimension(7) :: c = [ .015827191973480183087169986733305510591_wp, & + .094273840218850045531282505077108171960_wp, & + .15507198733658539625363597980210298680_wp, & + .18882157396018245442000533937297167125_wp, & + .19977340522685852679206802206648840246_wp, & + .22492646533333952701601768799639508076_wp, & + .24261107190140773379964095790325635233_wp ] + k = 0 + ierr = 1 + tol = max(eps, error_tol) + m = (a+b)/2.0_wp + h = (b-a)/2.0_wp + + x = [a, m-x1*h, m-alpha*h, m-x2*h, m-beta*h, m-x3*h, m, m+x3*h, m+beta*h, m+x2*h, m+alpha*h, m+x1*h, b] + do i=1,13 + y(i) = f(x(i)) + end do + + fa=y(1) + fb=y(13) + i2=(h/6.0_wp)*(y(1)+y(13)+5.0_wp*(y(5)+y(9))) + i1=(h/1470.0_wp)*(77.0_wp*(y(1)+y(13))+432.0_wp*(y(3)+y(11))+625.0_wp*(y(5)+y(9))+672.0_wp*y(7)) + + is = h*(c(1)*(y(1)+y(13)) + & + c(2)*(y(2)+y(12)) + & + c(3)*(y(3)+y(11)) + & + c(4)*(y(4)+y(10)) + & + c(5)*(y(5)+y(9)) + & + c(6)*(y(6)+y(8)) + & + c(7)*y(7)) + + s = sign(1.0_wp,is) + if (s==0.0_wp) s = 1.0_wp + erri1 = abs(i1-is) + erri2 = abs(i2-is) + r = 1.0_wp + if (erri2/=0.0_wp) r=erri1/erri2 + if (r>0.0_wp .and. r<1.0_wp) tol=tol/r + is=s*abs(is)*tol/eps + if (is==0.0_wp) is=b-a + + call adaptive_lobatto_step(a,b,fa,fb,is,ans) + + contains + + recursive subroutine adaptive_lobatto_step(a,b,fa,fb,is,ans) + + !! Recursive function used by adaptive_lobatto. + !! Tries to approximate the integral of f(x) from a to b + !! to an appropriate relative error. + + implicit none + + real(wp),intent(in) :: a + real(wp),intent(in) :: b + real(wp),intent(in) :: fa + real(wp),intent(in) :: fb + real(wp),intent(in) :: is + real(wp),intent(out) :: ans + + real(wp) :: h,m,mll,ml,mr,mrr,fmll,fml,fm,fmr,fmrr,i2,i1 + real(wp),dimension(6) :: q + + k = k + 1 + if (k>kmax) then + ierr = 2 + ans = 0.0_wp + return + end if + h = (b-a)/2.0_wp + m = (a+b)/2.0_wp + mll = m-alpha*h + ml = m-beta*h + mr = m+beta*h + mrr = m+alpha*h + + fmll = f(mll) + fml = f(ml) + fm = f(m) + fmr = f(mr) + fmrr = f(mrr) + + i2 = (h/6.0_wp)*(fa+fb+5.0_wp*(fml+fmr)) + i1 = (h/1470.0_wp)*(77.0_wp*(fa+fb)+432.0_wp*(fmll+fmrr)+625.0_wp*(fml+fmr)+672.0_wp*fm) + + if ( (is+(i1-i2)==is) .or. (mll<=a) .or. (b<=mrr) ) then + + if (((m <= a) .or. (b<=m)) .and. (ierr==1)) ierr = 2 + ans = i1 + + else + + if (ierr==1) call adaptive_lobatto_step(a,mll,fa,fmll, is,q(1)) + if (ierr==1) call adaptive_lobatto_step(mll,ml,fmll,fml, is,q(2)) + if (ierr==1) call adaptive_lobatto_step(ml,m,fml,fm, is,q(3)) + if (ierr==1) call adaptive_lobatto_step(m,mr,fm,fmr, is,q(4)) + if (ierr==1) call adaptive_lobatto_step(mr,mrr,fmr,fmrr, is,q(5)) + if (ierr==1) call adaptive_lobatto_step(mrr,b,fmrr,fb, is,q(6)) + + if (ierr==1) then + ans = sum(q) + else + ans = i1 + end if + + end if + + end subroutine adaptive_lobatto_step +!************************************************************** + + end subroutine dlobatto +!******************************************************************************** + +!******************************************************************************** +!> +! XERROR processes a diagnostic message, in a manner +! determined by the value of LEVEL and the current value +! of the library error control flag, KONTRL. +! (See subroutine XSETF for details.) +! +! Examples +!```fortran +! call xerror('smooth -- num was zero.',1,2) +! call xerror('integ -- less than full accuracy achieved.',2,1) +! call xerror('rooter -- actual zero of f found before interval fully collapsed.',3,0) +! call xerror('exp -- underflows being set to zero.',1,-1) +!``` +! +!### History +! * Written by Ron Jones, with SLATEC Common Math Library Subcommittee +! * Latest SLATEC revision --- 19 MAR 1980 +! * Jacob Williams, Dec 2021 : rewrite simple version for new quadpack +! +!### References +! * Jones R.E., Kahaner D.K., "Xerror, the slatec error-handling package", +! sand82-0800, sandia laboratories, 1982. + + subroutine xerror(messg, nerr, level) + use,intrinsic :: iso_fortran_env, only: error_unit + implicit none + + character(len=*), intent(in) :: messg !! message to be processed + integer, intent(in) :: nerr !! the error number associated with this message. + !! NERR must not be zero. + integer, intent(in) :: level !! error category: + !! * =2 means this is an unconditionally fatal error. + !! * =1 means this is a recoverable error. (I.e., it is + !! non-fatal if XSETF has been appropriately called.) + !! * =0 means this is a warning message only. + !! * =-1 means this is a warning message which is to be + !! printed at most once, regardless of how many + !! times this call is executed. + + write (error_unit, '(I5,1X,A)') nerr, messg + if (level == 2) error stop + + end subroutine xerror +!******************************************************************************** + +#ifndef MOD_INCLUDE +!******************************************************************************** +end module quadpack_generic +!******************************************************************************** +#endif diff --git a/fortran_implementation/external_libraries/quadpack/quadpack_quad.F90 b/fortran_implementation/external_libraries/quadpack/quadpack_quad.F90 new file mode 100644 index 0000000..11bf4c6 --- /dev/null +++ b/fortran_implementation/external_libraries/quadpack/quadpack_quad.F90 @@ -0,0 +1,10 @@ +module quadpack_quad + !! + !!@note For this module, `wp` is `real128` (double precision). + !! + use iso_fortran_env, only: wp => real128 +#if !defined(NOQUAD) +#define MOD_INCLUDE=1 +#include "quadpack_generic.F90" +#endif +end module quadpack_quad diff --git a/fortran_implementation/external_libraries/quadpack/quadpack_single.F90 b/fortran_implementation/external_libraries/quadpack/quadpack_single.F90 new file mode 100644 index 0000000..96d86e1 --- /dev/null +++ b/fortran_implementation/external_libraries/quadpack/quadpack_single.F90 @@ -0,0 +1,8 @@ +module quadpack_single + !! + !!@note For this module, `wp` is `real32` (single precision). + !! + use iso_fortran_env, only: wp => real32 +#define MOD_INCLUDE=1 +#include "quadpack_generic.F90" +end module quadpack_single diff --git a/fortran_implementation/integrals.f90 b/fortran_implementation/integrals.f90 new file mode 100644 index 0000000..e031641 --- /dev/null +++ b/fortran_implementation/integrals.f90 @@ -0,0 +1,243 @@ +module integral_helpers + use iso_fortran_env, only: dp => real64 + use model_types, only: para_coefficients + implicit none + integer :: s_n + type(para_coefficients) :: para_helper +end module integral_helpers + +module solution_vecs + use iso_fortran_env, only: dp => real64 + use constants, only: HALF_PI, PI, THREE_HALF_PI, TWO_PI + use quadpack, only: dqag + use model_types, only: para_coefficients + implicit none + + real(dp), parameter :: epsabs = 1.0e-12_dp ! Absolute error tolerance + real(dp), parameter :: epsrel = 1.0e-12_dp ! Relative error tolerance + integer, parameter :: key = 5 ! selects Gauss-Kronrod 25,51 points + real(dp) :: result ! the estimated integral + real(dp) :: abserr ! the estimated absolute error + integer :: neval ! the number of function evaluations + integer :: ier ! an error flag + integer, parameter :: limit = 100 ! maximum number of subintervals + integer, parameter :: lenw = limit*4 ! need to store endpoints, val, err for each subinterval + integer :: last ! the number of subintervals actually used + integer :: iwork(limit) ! for parsing the work array for dqag + real(dp) :: work(lenw) ! work array for dqag + +contains + + subroutine star_solution_vec(a, b, g_coeffs, para, solution_vector) + implicit none + + real(dp), intent(in) :: a, b + real(dp), intent(in), allocatable :: g_coeffs(:) + type(para_coefficients), intent(in) :: para + real(dp), intent(out), allocatable :: solution_vector(:) + + ! local variables + real(dp) :: x1, y1, x2, y2, theta1, theta2, theta1_tmp, theta2_tmp, delta + logical :: wrap + + solution_vector = g_coeffs*0.0_dp + + x1 = para%c_x1*dcos(a) + para%c_x2*dsin(a) + para%c_x3 + y1 = para%c_y1*dcos(a) + para%c_y2*dsin(a) + para%c_y3 + theta1_tmp = datan2(y1, x1) + if (theta1_tmp < 0.0_dp) then + theta1_tmp = theta1_tmp + 2.0_dp*PI + end if + + x2 = para%c_x1*dcos(b) + para%c_x2*dsin(b) + para%c_x3 + y2 = para%c_y1*dcos(b) + para%c_y2*dsin(b) + para%c_y3 + theta2_tmp = datan2(y2, x2) + if (theta2_tmp < 0.0_dp) then + theta2_tmp = theta2_tmp + 2.0_dp*PI + end if + + ! Order the angles + if (theta1_tmp < theta2_tmp) then + theta1 = theta1_tmp + theta2 = theta2_tmp + else + theta1 = theta2_tmp + theta2 = theta1_tmp + end if + + delta = theta2 - theta1 + + wrap = delta > PI + ! print *, "delta: ", delta + + if (wrap .neqv. .true.) then + ! print *, "no wrap integration" + call dqag(s0_integrand_star, theta1, theta2, epsabs, epsrel, key, result, & + abserr, neval, ier, limit, lenw, last, & + iwork, work) + solution_vector(1) = result + + call dqag(s1_integrand_star, theta1, theta2, epsabs, epsrel, key, result, & + abserr, neval, ier, limit, lenw, last, & + iwork, work) + solution_vector(2) = result + + return + else + ! print *, "wrap integration" + call dqag(s0_integrand_star, theta2, TWO_PI, epsabs, epsrel, key, result, & + abserr, neval, ier, limit, lenw, last, & + iwork, work) + solution_vector(1) = result + + call dqag(s0_integrand_star, 0.0_dp, theta1, epsabs, epsrel, key, result, & + abserr, neval, ier, limit, lenw, last, & + iwork, work) + solution_vector(1) = solution_vector(1) + result + + call dqag(s1_integrand_star, theta2, TWO_PI, epsabs, epsrel, key, result, & + abserr, neval, ier, limit, lenw, last, & + iwork, work) + solution_vector(2) = result + + call dqag(s1_integrand_star, 0.0_dp, theta1, epsabs, epsrel, key, result, & + abserr, neval, ier, limit, lenw, last, & + iwork, work) + solution_vector(2) = solution_vector(2) + result + end if + + contains + function s0_integrand_star(t) result(val) + implicit none + real(dp), intent(in) :: t + real(dp) :: val + real(dp) :: tmp + tmp = dcos(t) + val = tmp*tmp + end function s0_integrand_star + + function s1_integrand_star(t) result(val) + use constants, only: PI, HALF_PI, THREE_HALF_PI + implicit none + real(dp), intent(in) :: t + real(dp) :: val + + real(dp) :: cos_t, cos_2t + cos_t = dcos(t) + cos_2t = dcos(2.0_dp*t) + + if (t < HALF_PI .or. t > THREE_HALF_PI) then + val = (PI*cos_t*(5.0_dp + 3.0_dp*cos_2t))/24.0_dp + else + val = -(PI*cos_t*(1.0_dp + 3.0_dp*cos_2t))/24.0_dp + end if + end function s1_integrand_star + + end subroutine star_solution_vec + + subroutine planet_solution_vec(a, b, g_coeffs, para, solution_vector) + use integral_helpers + implicit none + + real(dp), intent(in) :: a, b + real(dp), intent(in), allocatable :: g_coeffs(:) + type(para_coefficients), intent(in) :: para + real(dp), intent(out), allocatable :: solution_vector(:) + + integer :: i + + ! copy para into the shared module so + ! the integrand functions can access it + para_helper = para + + solution_vector = g_coeffs*0.0_dp + + call dqag(s0_integrand_planet, a, b, epsabs, epsrel, key, result, & + abserr, neval, ier, limit, lenw, last, & + iwork, work) + solution_vector(1) = result + + call dqag(s1_integrand_planet, a, b, epsabs, epsrel, key, result, & + abserr, neval, ier, limit, lenw, last, & + iwork, work) + solution_vector(2) = result + + s_n = 2 + do i = s_n, size(g_coeffs) + call dqag(sn_integrand_planet, a, b, epsabs, epsrel, key, result, & + abserr, neval, ier, limit, lenw, last, & + iwork, work) + solution_vector(i + 1) = result + s_n = s_n + 1 + end do + + contains + function s0_integrand_planet(t) result(val) + use integral_helpers + implicit none + real(dp), intent(in) :: t + real(dp) :: val + + real(dp) :: cos_t, sin_t + cos_t = dcos(t) + sin_t = dsin(t) + val = (cos_t*para_helper%c_x1 + sin_t*para_helper%c_x2 + para_helper%c_x3)* & + (-sin_t*para_helper%c_y1 + cos_t*para_helper%c_y2) + + end function s0_integrand_planet + + function s1_integrand_planet(t) result(val) + use integral_helpers + implicit none + real(dp), intent(in) :: t + real(dp) :: val + + real(dp) :: x_term, y_term, sqrt_term, atan_term + + x_term = dcos(t)*para_helper%c_x1 + dsin(t)*para_helper%c_x2 + para_helper%c_x3 + + y_term = dcos(t)*para_helper%c_y1 + dsin(t)*para_helper%c_y2 + para_helper%c_y3 + + sqrt_term = dsqrt(1.0_dp - x_term**2 - y_term**2) + + atan_term = datan(x_term/sqrt_term) + + val = (-(dsin(t)*para_helper%c_y1) + dcos(t)*para_helper%c_y2)*( & + PI + & + 6.0_dp*x_term*sqrt_term - & + 6.0_dp*atan_term*(-1.0_dp + y_term**2) & + )/12.0_dp + + end function s1_integrand_planet + + function sn_integrand_planet(t) result(val) + use integral_helpers + implicit none + + real(dp), intent(in) :: t + real(dp) :: val + + real(dp) :: cos_s, sin_s, tmp1, tmp2, squared_terms, power_term, cross_products + + cos_s = cos(t) + sin_s = sin(t) + + tmp1 = cos_s*para_helper%c_x1 + sin_s*para_helper%c_x2 + para_helper%c_x3 + tmp2 = cos_s*para_helper%c_y1 + sin_s*para_helper%c_y2 + para_helper%c_y3 + + squared_terms = 1.0d0 - tmp1*tmp1 - tmp2*tmp2 + + ! s_n comes from the shared module integral_helpers + power_term = squared_terms**(s_n/2.0d0) + + cross_products = para_helper%c_x3*(sin_s*para_helper%c_y1 - cos_s*para_helper%c_y2) + & + para_helper%c_x2*(para_helper%c_y1 + cos_s*para_helper%c_y3) - & + para_helper%c_x1*(para_helper%c_y2 + sin_s*para_helper%c_y3) + + val = -(power_term*cross_products) + + end function sn_integrand_planet + + end subroutine planet_solution_vec + +end module solution_vecs diff --git a/fortran_implementation/intersection_pts.f90 b/fortran_implementation/intersection_pts.f90 new file mode 100644 index 0000000..31438b8 --- /dev/null +++ b/fortran_implementation/intersection_pts.f90 @@ -0,0 +1,108 @@ +module intersection_pts + use, intrinsic :: iso_fortran_env, only: dp => real64 + use model_types, only: rho_coefficients + implicit none + +contains + + function t4_term(rho) result(t4) + implicit none + type(rho_coefficients), intent(in) :: rho + real(dp) :: t4 + t4 = -1._dp + rho%rho_00 - rho%rho_x0 + rho%rho_xx + end function t4_term + + function t3_term(rho) result(t3) + implicit none + type(rho_coefficients), intent(in) :: rho + real(dp) :: t3 + t3 = -2._dp*rho%rho_xy + 2._dp*rho%rho_y0 + end function t3_term + + function t2_term(rho) result(t2) + implicit none + type(rho_coefficients), intent(in) :: rho + real(dp) :: t2 + t2 = -2._dp + 2._dp*rho%rho_00 - 2._dp*rho%rho_xx + 4._dp*rho%rho_yy + end function t2_term + + function t1_term(rho) result(t1) + implicit none + type(rho_coefficients), intent(in) :: rho + real(dp) :: t1 + t1 = 2._dp*rho%rho_xy + 2._dp*rho%rho_y0 + end function t1_term + + function t0_term(rho) result(t0) + implicit none + type(rho_coefficients), intent(in) :: rho + real(dp) :: t0 + t0 = -1._dp + rho%rho_00 + rho%rho_x0 + rho%rho_xx + end function t0_term + + function intersection_points(rho) result(intersections) + implicit none + type(rho_coefficients), intent(in) :: rho + real(dp), dimension(4, 2) :: intersections + complex(dp), dimension(4) :: roots_complex + integer, parameter :: N = 4 ! 4th order polynomial + real(dp) :: t4, t3, t2, t1, t0 + real(dp), dimension(5) :: coeffs + complex(dp), dimension(4, 4) :: companion + complex(dp), dimension(4*4) :: work ! Workspace for ZGEEV + real(dp), dimension(2*4) :: rwork + integer :: info + real(dp), dimension(4) :: t_roots + integer :: i + + t4 = t4_term(rho) + t3 = t3_term(rho) + t2 = t2_term(rho) + t1 = t1_term(rho) + t0 = t0_term(rho) + + coeffs = [t0, t1, t2, t3, t4] + + ! Normalize coefficients by dividing by leading coefficient + do i = 1, N + coeffs(i) = coeffs(i)/coeffs(N + 1) + end do + + ! Construct companion matrix (directly as complex) + companion = complex(0.0_dp, 0.0_dp) + do i = 1, N - 1 + companion(i + 1, i) = complex(1.0_dp, 0.0_dp) + end do + do i = 1, N + companion(i, N) = complex(-coeffs(i), 0.0_dp) + end do + + ! Find eigenvalues using LAPACK's ZGEEV + call ZGEEV('N', 'N', N, companion, N, roots_complex, companion, 1, & + companion, 1, work, 4*N, rwork, info) + + ! now we have the roots of the quartic + ! figure out which of those are real + do i = 1, 4 + ! ack oof it never turns out to be exactly zero like the jax version, + ! check if this threshold is good. chance of false positives? + if (abs(aimag(roots_complex(i))) < 1e-13_dp) then + t_roots(i) = real(roots_complex(i)) + else + t_roots(i) = 999._dp + end if + end do + + ! convert the t's into xs and ys + intersections = 999 + do i = 1, 4 + if (t_roots(i) == 999._dp) then + cycle + end if + intersections(i, 1) = (1 - t_roots(i)*t_roots(i))/(1 + t_roots(i)*t_roots(i)) + intersections(i, 2) = 2*t_roots(i)/(1 + t_roots(i)*t_roots(i)) + end do + + end function intersection_points + +end module intersection_pts diff --git a/fortran_implementation/keplerian.f90 b/fortran_implementation/keplerian.f90 new file mode 100644 index 0000000..72bb383 --- /dev/null +++ b/fortran_implementation/keplerian.f90 @@ -0,0 +1,266 @@ +module keplerian + use iso_fortran_env, only: dp => real64 + use constants, only: PI, TWO_PI + use model_types + implicit none + +contains + function true_anomaly_at_transit_center(e, i, omega) result(true_anomaly) + implicit none + + ! Input variables (all scalar) + real(dp), intent(in) :: e, i, omega + ! Output variable + real(dp) :: true_anomaly + + ! Local variables + real(dp) :: hp, kp, dcos_i_squared + real(dp) :: eta_1, eta_2, eta_3, eta_4, eta_5, eta_6 + + ! Calculate intermediate values + hp = e*dsin(omega) + kp = e*dcos(omega) + dcos_i_squared = dcos(i)**2 + + ! Calculate η₁ term + eta_1 = (kp/(1.0_dp + hp))*dcos_i_squared + + ! Calculate η₂ term + eta_2 = (kp/(1.0_dp + hp))* & + (1.0_dp/(1.0_dp + hp))* & + dcos_i_squared**2 + + ! Calculate η₃ term + eta_3 = -(kp/(1.0_dp + hp))* & + ((-6.0_dp*(1.0_dp + hp) + & + kp**2*(-1.0_dp + 2.0_dp*hp))/ & + (6.0_dp*(1.0_dp + hp)**3))* & + dcos_i_squared**3 + + ! Calculate η₄ term + eta_4 = -(kp/(1.0_dp + hp))* & + ((-2.0_dp*(1.0_dp + hp) + & + kp**2*(-1.0_dp + 3.0_dp*hp))/ & + (2.0_dp*(1.0_dp + hp)**4))* & + dcos_i_squared**4 + + ! Calculate η₅ term + eta_5 = (kp/(1.0_dp + hp))* & + ((40.0_dp*(1.0_dp + hp)**2 - & + 40.0_dp*kp**2*(-1.0_dp + 3.0_dp*hp + 4.0_dp*hp**2) + & + kp**4*(3.0_dp - 19.0_dp*hp + 8.0_dp*hp**2))/ & + (40.0_dp*(1.0_dp + hp)**6))* & + dcos_i_squared**5 + + ! Calculate η₆ term + eta_6 = (kp/(1.0_dp + hp))* & + ((24.0_dp*(1.0_dp + hp)**2 - & + 40.0_dp*kp**2*(-1.0_dp + 4.0_dp*hp + 5.0_dp*hp**2) + & + 9.0_dp*kp**4*(1.0_dp - 8.0_dp*hp + 5.0_dp*hp**2))/ & + (24.0_dp*(1.0_dp + hp)**7))* & + dcos_i_squared**6 + + ! Calculate final true anomaly + true_anomaly = PI/2.0_dp - omega - eta_1 - eta_2 - eta_3 - eta_4 - eta_5 - eta_6 + + end function true_anomaly_at_transit_center + + function t0_to_t_peri(e, i, omega, period, t0) result(t_peri) + implicit none + real(dp), intent(in) :: e, i, omega, period, t0 + real(dp) :: t_peri + + real(dp) :: f, eccentric_anomaly, mean_anomaly + + f = true_anomaly_at_transit_center(e, i, omega) + + eccentric_anomaly = atan2(sqrt(1 - e**2)*dsin(f), e + dcos(f)) + mean_anomaly = eccentric_anomaly - e*dsin(eccentric_anomaly) + + t_peri = t0 - period/(2*PI)*mean_anomaly + + end function t0_to_t_peri + + function kepler(M, ecc) result(f) + ! Solve Kepler's equation to compute the true anomaly + ! Args: + ! M (dp): Mean anomaly in radians + ! ecc (dp): Eccentricity (dimensionless) + ! Returns: + ! f (dp): True anomaly in radians [0, 2π) + implicit none + + real(dp), intent(in) :: M, ecc + real(dp) :: f, dsinf, dcosf + + call kepler_internal(M, ecc, dsinf, dcosf) + + ! Calculate arctangent and ensure result is in [0, 2π) + f = atan2(dsinf, dcosf) + if (f < 0.0_dp) then + f = f + TWO_PI + end if + end function kepler + + subroutine kepler_internal(M, ecc, dsinf, dcosf) + implicit none + real(dp), intent(in) :: M, ecc + real(dp), intent(out) :: dsinf, dcosf + real(dp) :: M_wrapped, E, ome + logical :: high + real(dp) :: tan_half_f, tan2_half_f, denom + + ! Wrap into the right range + M_wrapped = modulo(M, TWO_PI) + + ! We can restrict to the range [0, PI) + high = M_wrapped > PI + if (high) then + M_wrapped = TWO_PI - M_wrapped + end if + + ! Solve + ome = 1.0_dp - ecc + E = starter(M_wrapped, ecc, ome) + E = refine(M_wrapped, ecc, ome, E) + + ! Re-wrap back into the full range + if (high) then + E = TWO_PI - E + end if + + ! Convert to true anomaly + tan_half_f = sqrt((1.0_dp + ecc)/(1.0_dp - ecc))*tan(0.5_dp*E) + tan2_half_f = tan_half_f*tan_half_f + + ! Compute dsin(f) and dcos(f) + denom = 1.0_dp/(1.0_dp + tan2_half_f) + dsinf = 2.0_dp*tan_half_f*denom + dcosf = (1.0_dp - tan2_half_f)*denom + end subroutine kepler_internal + + function starter(M, ecc, ome) result(E) + implicit none + real(dp), intent(in) :: M, ecc, ome + real(dp) :: E + real(dp) :: M2, alpha, d, alphad, r, q, q2, w + + M2 = M*M + alpha = 3.0_dp*PI/(PI - 6.0_dp/PI) + alpha = alpha + 1.6_dp/(PI - 6.0_dp/PI)*(PI - M)/(1.0_dp + ecc) + + d = 3.0_dp*ome + alpha*ecc + alphad = alpha*d + r = (3.0_dp*alphad*(d - ome) + M2)*M + q = 2.0_dp*alphad*ome - M2 + q2 = q*q + + w = (abs(r) + sqrt(q2*q + r*r))**(1.0_dp/3.0_dp) + w = w*w + + E = (2.0_dp*r*w/(w*w + w*q + q2) + M)/d + end function starter + + function refine(M, ecc, ome, E_in) result(E_out) + implicit none + real(dp), intent(in) :: M, ecc, ome, E_in + real(dp) :: E_out + real(dp) :: sE, cE, f_0, f_1, f_2, f_3 + real(dp) :: d_3, d_4, d_42, dE + + sE = E_in - dsin(E_in) + cE = 1.0_dp - dcos(E_in) + + f_0 = ecc*sE + E_in*ome - M + f_1 = ecc*cE + ome + f_2 = ecc*(E_in - sE) + f_3 = 1.0_dp - f_1 + + d_3 = -f_0/(f_1 - 0.5_dp*f_0*f_2/f_1) + d_4 = -f_0/(f_1 + 0.5_dp*d_3*f_2 + (d_3*d_3)*f_3/6.0_dp) + d_42 = d_4*d_4 + + dE = -f_0/(f_1 + 0.5_dp*d_4*f_2 + d_4*d_4*f_3/6.0_dp - & + d_42*d_4*f_2/24.0_dp) + + E_out = E_in + dE + + end function refine + + function x_position(a, e, f, big_Omega, i, little_omega) result(x) + ! Compute x coordinate in the sky frame + ! Args: + ! a (dp): Semi-major axis in stellar radii + ! e (dp): Eccentricity + ! f (dp): True anomaly in radians + ! big_Omega (dp): Longitude of ascending node (Ω) in radians + ! i (dp): Inclination in radians + ! little_omega (dp): Argument of periapsis (ω) in radians + implicit none + real(dp), intent(in) :: a, e, f, big_Omega, i, little_omega + real(dp) :: x + real(dp) :: factor1, factor2, term1, term2 + + ! Pre-compute common factors to improve readability and efficiency + factor1 = a*(1.0_dp - e*e)/(1.0_dp + e*dcos(f)) + factor2 = dsin(f) + + ! First parenthesized term + term1 = factor2*(dcos(big_Omega)*dsin(little_omega) + & + dcos(i)*dcos(little_omega)*dsin(big_Omega)) + + ! Second parenthesized term + term2 = dcos(f)*(-dcos(little_omega)*dcos(big_Omega) + & + dcos(i)*dsin(little_omega)*dsin(big_Omega)) + + x = -factor1*(term1 + term2) + end function x_position + + function y_position(a, e, f, big_Omega, i, little_omega) result(y) + ! Compute y coordinate in the sky frame + ! Args similar to x_position + implicit none + real(dp), intent(in) :: a, e, f, big_Omega, i, little_omega + real(dp) :: y + real(dp) :: factor, combined_angle + + factor = a*(1.0_dp - e*e)/(1.0_dp + e*dcos(f)) + combined_angle = f + little_omega + + y = factor*(dcos(i)*dcos(big_Omega)*dsin(combined_angle) + & + dcos(combined_angle)*dsin(big_Omega)) + end function y_position + + function z_position(a, e, f, big_Omega, i, little_omega) result(z) + ! Compute z coordinate in the sky frame + ! Args similar to x_position + implicit none + real(dp), intent(in) :: a, e, f, big_Omega, i, little_omega + real(dp) :: z + real(dp) :: factor + + factor = a*(1.0_dp - e*e)/(1.0_dp + e*dcos(f)) + z = factor*dsin(i)*dsin(f + little_omega) + end function z_position + + function skypos(orbit_params, f) result(pos) + ! Compute the sky position of the planet + ! Args: + ! orbit_params (model_parameters): Model parameters + ! f (dp): True anomaly in radians + ! Returns: + ! pos (skypos_positions): Sky position of the planet + implicit none + type(orbit_parameters) :: orbit_params + real(dp):: f + type(skypos_positions) :: pos + + pos%x = x_position(orbit_params%semi, orbit_params%ecc, f, & + orbit_params%big_Omega, orbit_params%inc, orbit_params%little_omega) + pos%y = y_position(orbit_params%semi, orbit_params%ecc, f, & + orbit_params%big_Omega, orbit_params%inc, orbit_params%little_omega) + pos%z = z_position(orbit_params%semi, orbit_params%ecc, f, & + orbit_params%big_Omega, orbit_params%inc, orbit_params%little_omega) + end function skypos + +end module keplerian diff --git a/fortran_implementation/main.f90 b/fortran_implementation/main.f90 new file mode 100644 index 0000000..dc86d18 --- /dev/null +++ b/fortran_implementation/main.f90 @@ -0,0 +1,156 @@ +program main + !!!!!!!!! + ! imports + !!!!!!!!! + use iso_fortran_env, only: dp => real64 + use model_types, only: orbit_parameters, planet_parameters_2d, planet_parameters_3d, p_coefficients + use constants, only: PI + use read_in_files, only: read_time_array, read_change_of_basis_matrix + use keplerian, only: kepler, t0_to_t_peri + use squishyplanet_2d, only: squishyplanet_lightcurve_2d + use squishyplanet_3d, only: squishyplanet_lightcurve_3d + implicit none + + real(dp), allocatable :: times(:) + real(dp), allocatable :: fluxes(:) + + type(orbit_parameters) :: orbit_params + type(planet_parameters_2d) :: planet_params + type(planet_parameters_3d) :: planet_params_3d + + logical :: exists + integer(8) :: count_rate, count_max, count_start, count_end + real(8) :: elapsed_time + + ! this has to match the length of your ld_u_coeffs array + ! will read in the appropriate change of basis matrix based on that + real(dp), dimension(8) :: ld_u_coeffs + + character(len=256) :: filename + real(dp), dimension(size(ld_u_coeffs) + 1, size(ld_u_coeffs) + 1) :: change_of_basis_matrix + + !!!!!!!!!!! + ! setup + !!!!!!!!!!! + times = read_time_array('../times.txt') ! this allocates times + allocate (fluxes(size(times))) + + write (filename, '(a,i0,a)') '../change_of_basis_matricies/g_matrix_', size(ld_u_coeffs), '.bin' + change_of_basis_matrix = read_change_of_basis_matrix(filename, size(ld_u_coeffs)) + + orbit_params%semi = 200.0_dp + orbit_params%ecc = 0.3_dp + orbit_params%inc = 89.75_dp*PI/180.0_dp + orbit_params%big_Omega = 95.0_dp*PI/180.0_dp ! should always be pi/2 for transits, this is just to test it works in a full 3D scenario + orbit_params%little_omega = PI/3.5_dp + orbit_params%period = 1001.0_dp + orbit_params%t0 = 0.2_dp + + planet_params%r_eff = 0.1_dp + planet_params%f_squish_proj = 0.3_dp + planet_params%theta_proj = 0.2_dp + + ld_u_coeffs = (/0.008_dp, 0.007_dp, 0.006_dp, 0.005_dp, 0.004_dp, 0.003_dp, 0.002_dp, 0.001_dp/) + + print *, "beginning the 2d version of squishyplanet" + call SYSTEM_CLOCK(count_start, count_rate, count_max) + call squishyplanet_lightcurve_2d( & + ! these change with each sample + orbit_params=orbit_params, & + planet_params=planet_params, & + ld_u_coeffs=ld_u_coeffs, & + ! these don't change with each sample + times=times, & + fluxes=fluxes, & + change_of_basis_matrix=change_of_basis_matrix & + ) + call SYSTEM_CLOCK(count_end) + elapsed_time = real(count_end - count_start) / REAL(count_rate) + print *, 'Time taken = ', elapsed_time*1000.0_dp, ' ms' + + print *, "done, writing the lightcurve to 2d_lightcurve.bin" + inquire(file='../2d_lightcurve.bin', exist=exists) + if (exists) then + open(unit=10, file='../lightcurve.bin') + close(unit=10, status='delete') + end if + open(unit=10, file='../2d_lightcurve.bin', form='unformatted', access='stream', status='replace') + write(10) fluxes + close(10) + + + print *, "" + print *, "beginning the 3d version, different planet" + + orbit_params%semi = 200.0_dp + orbit_params%ecc = 0.3_dp + orbit_params%inc = 89.75_dp*PI/180.0_dp + orbit_params%big_Omega = 95.0_dp*PI/180.0_dp + orbit_params%little_omega = PI/3.5_dp + orbit_params%period = 1001.0_dp + orbit_params%t0 = 0.2_dp + + planet_params_3d%r = 0.2_dp + planet_params_3d%f_squish_1 = 0.1_dp + planet_params_3d%f_squish_2 = 0.2_dp + planet_params_3d%obliquity = 0.3_dp + planet_params_3d%precession = 0.4_dp + + call SYSTEM_CLOCK(count_start, count_rate, count_max) + call squishyplanet_lightcurve_3d( & + ! these change with each sample + orbit_params=orbit_params, & + planet_params=planet_params_3d, & + ld_u_coeffs=ld_u_coeffs, & + ! these don't change with each sample + tidally_locked=.false., & + times=times, & + fluxes=fluxes, & + change_of_basis_matrix=change_of_basis_matrix & + ) + call SYSTEM_CLOCK(count_end) + elapsed_time = real(count_end - count_start) / REAL(count_rate) + print *, 'Time taken = ', elapsed_time*1000.0_dp, ' ms' + + print *, "done, writing the lightcurve to 3d_lightcurve.bin" + inquire(file='../3d_lightcurve.bin', exist=exists) + if (exists) then + open(unit=10, file='../lightcurve.bin') + close(unit=10, status='delete') + end if + open(unit=10, file='../3d_lightcurve.bin', form='unformatted', access='stream', status='replace') + write(10) fluxes + close(10) + + print *, "" + print *, "now again, but tidally locked" + call SYSTEM_CLOCK(count_start, count_rate, count_max) + call squishyplanet_lightcurve_3d( & + ! these change with each sample + orbit_params=orbit_params, & + planet_params=planet_params_3d, & + ld_u_coeffs=ld_u_coeffs, & + ! these don't change with each sample + tidally_locked=.true., & + times=times, & + fluxes=fluxes, & + change_of_basis_matrix=change_of_basis_matrix & + ) + call SYSTEM_CLOCK(count_end) + elapsed_time = real(count_end - count_start) / REAL(count_rate) + print *, 'Time taken = ', elapsed_time*1000.0_dp, ' ms' + + print *, "done, writing the lightcurve to 3d_lightcurve_tl.bin" + inquire(file='../3d_lightcurve_tl.bin', exist=exists) + if (exists) then + open(unit=10, file='../lightcurve.bin') + close(unit=10, status='delete') + end if + open(unit=10, file='../3d_lightcurve_tl.bin', form='unformatted', access='stream', status='replace') + write(10) fluxes + close(10) + + deallocate (times) + deallocate (fluxes) + +end program main diff --git a/fortran_implementation/model_types.f90 b/fortran_implementation/model_types.f90 new file mode 100644 index 0000000..2f7c3cd --- /dev/null +++ b/fortran_implementation/model_types.f90 @@ -0,0 +1,75 @@ +module model_types + use, intrinsic :: iso_fortran_env, only: dp => real64 + implicit none + + type :: orbit_parameters + real(dp) :: semi + real(dp) :: ecc + real(dp) :: inc + real(dp) :: big_Omega + real(dp) :: little_omega + real(dp) :: period + real(dp) :: t0 + end type orbit_parameters + + type :: planet_parameters_2d + real(dp) :: r_eff + real(dp) :: f_squish_proj + real(dp) :: theta_proj + end type planet_parameters_2d + + type :: planet_parameters_3d + real(dp) :: r + real(dp) :: f_squish_1 + real(dp) :: f_squish_2 + real(dp) :: obliquity + real(dp) :: precession + end type planet_parameters_3d + + type :: skypos_positions + real(dp) :: x + real(dp) :: y + real(dp) :: z + end type skypos_positions + + type :: rho_coefficients + real(dp) :: rho_xx + real(dp) :: rho_xy + real(dp) :: rho_x0 + real(dp) :: rho_yy + real(dp) :: rho_y0 + real(dp) :: rho_00 + end type rho_coefficients + + type :: para_coefficients + real(dp) :: c_x1 + real(dp) :: c_x2 + real(dp) :: c_x3 + real(dp) :: c_y1 + real(dp) :: c_y2 + real(dp) :: c_y3 + end type para_coefficients + + type :: para_helper_coeffs + real(dp) :: r1 + real(dp) :: r2 + real(dp) :: xc + real(dp) :: yc + real(dp) :: cosa + real(dp) :: sina + end type para_helper_coeffs + + type :: p_coefficients + real(dp) :: p_xx + real(dp) :: p_xy + real(dp) :: p_xz + real(dp) :: p_x0 + real(dp) :: p_yy + real(dp) :: p_yz + real(dp) :: p_y0 + real(dp) :: p_zz + real(dp) :: p_z0 + real(dp) :: p_00 + end type p_coefficients + +end module diff --git a/fortran_implementation/parametric_ellipse.f90 b/fortran_implementation/parametric_ellipse.f90 new file mode 100644 index 0000000..d8d5ca6 --- /dev/null +++ b/fortran_implementation/parametric_ellipse.f90 @@ -0,0 +1,184 @@ +module parametric_ellipse + use, intrinsic :: iso_fortran_env, only: dp => real64 + use model_types, only: rho_coefficients, para_helper_coeffs, para_coefficients + use constants, only: PI, HALF_PI + implicit none + +contains + + function calculate_rho_coefficients(projected_r, projected_f, projected_theta, & + xc, yc) result(rho_coeffs) + ! same as the rho calcs in parameterize_2d_helper in sq.engine.polynomial_limb_darkened_transit + ! but, even with identical inputs/structure, ~1e-14 differences between the two + ! running w/ it + implicit none + + ! Input parameters + real(dp), intent(in) :: projected_r ! Input radius + real(dp), intent(in) :: projected_f ! Input f parameter + real(dp), intent(in) :: projected_theta ! Input theta angle + real(dp), intent(in) :: xc, yc ! Input center coordinates + + ! Output structure + type(rho_coefficients) :: rho_coeffs + + ! Local variables + real(dp) :: cos_t, sin_t, projected_r2 + real(dp) :: projected_r_sq, projected_r2_sq, cos_t_sq, sin_t_sq, xc_sq, yc_sq + real(dp) :: tmp + + ! Calculate intermediate values + projected_r2 = projected_r*(1.0_dp - projected_f) + cos_t = cos(projected_theta) + sin_t = sin(projected_theta) + + projected_r_sq = projected_r*projected_r + projected_r2_sq = projected_r2*projected_r2 + cos_t_sq = cos_t*cos_t + sin_t_sq = sin_t*sin_t + xc_sq = xc*xc + yc_sq = yc*yc + + rho_coeffs%rho_xx = cos_t_sq/projected_r_sq + & + sin_t_sq/projected_r2_sq + + tmp = (2.0_dp*cos_t*sin_t) + rho_coeffs%rho_xy = tmp/projected_r_sq - & + tmp/projected_r2_sq + + tmp = 2.0_dp*cos_t*yc*sin_t + rho_coeffs%rho_x0 = ((-2.0_dp*cos_t_sq*xc) - tmp)/projected_r_sq & + + (tmp - (2.0_dp*xc*sin_t_sq))/projected_r2_sq + + rho_coeffs%rho_yy = cos_t_sq/projected_r2_sq + & + sin_t_sq/projected_r_sq + + tmp = 2.0_dp*cos_t*xc*sin_t + rho_coeffs%rho_y0 = ((-2.0_dp*cos_t_sq*yc) + (tmp))/projected_r2_sq & + - ((2.0_dp*cos_t*xc*sin_t) + (2.0_dp*yc*sin_t_sq))/projected_r_sq + + tmp = 2.0_dp*cos_t*xc*yc*sin_t + rho_coeffs%rho_00 = ((cos_t_sq*xc_sq) + (tmp) + (yc_sq*sin_t_sq))/projected_r_sq + & + ((cos_t_sq*yc_sq) - (tmp) + (xc_sq*sin_t_sq))/projected_r2_sq + + end function calculate_rho_coefficients + + function poly_to_parametric_helper(rho) & + result(para_helpers) + implicit none + + ! Input parameters + type(rho_coefficients), intent(in) :: rho + + ! Output parameters + type(para_helper_coeffs) :: para_helpers + + ! Local variables + real(dp) :: rho_xx_shift, rho_xy_shift, rho_yy_shift + real(dp) :: theta, denom, a, b + real(dp) :: diff_xx_yy + + ! Calculate the center of the ellipse + denom = 4.0_dp*rho%rho_xx*rho%rho_yy - rho%rho_xy**2 + para_helpers%xc = (rho%rho_xy*rho%rho_y0 - 2.0_dp*rho%rho_yy*rho%rho_x0)/denom + para_helpers%yc = (rho%rho_xy*rho%rho_x0 - 2.0_dp*rho%rho_xx*rho%rho_y0)/denom + + ! Calculate shifted coefficients for centered ellipse + denom = (-1.0_dp + rho%rho_00)*rho%rho_xy**2 - rho%rho_x0*rho%rho_xy*rho%rho_y0 + & + rho%rho_x0**2*rho%rho_yy + rho%rho_xx*(rho%rho_y0**2 + 4.0_dp*rho%rho_yy - & + 4.0_dp*rho%rho_00*rho%rho_yy) + + rho_xx_shift = -(rho%rho_xx*(rho%rho_xy**2 - 4.0_dp*rho%rho_xx*rho%rho_yy))/denom + rho_xy_shift = (-(rho%rho_xy**3) + 4.0_dp*rho%rho_xx*rho%rho_xy*rho%rho_yy)/denom + rho_yy_shift = -(rho%rho_yy*(rho%rho_xy**2 - 4.0_dp*rho%rho_xx*rho%rho_yy))/denom + + ! Calculate rotation angle + diff_xx_yy = rho_xx_shift - rho_yy_shift + if (abs(diff_xx_yy) > tiny(1.0_dp)) then + theta = 0.5_dp*atan2(rho_xy_shift, diff_xx_yy) + HALF_PI + if (theta < 0.0_dp) then + theta = theta + PI + end if + else + theta = 0.0_dp + end if + + ! Calculate sine and cosine of rotation angle + para_helpers%cosa = cos(theta) + para_helpers%sina = sin(theta) + + ! Calculate semi-major and semi-minor axes + a = rho_xx_shift*para_helpers%cosa**2 + rho_xy_shift*para_helpers%cosa*para_helpers%sina + & + rho_yy_shift*para_helpers%sina**2 + b = rho_xx_shift*para_helpers%sina**2 - rho_xy_shift*para_helpers%cosa*para_helpers%sina + & + rho_yy_shift*para_helpers%cosa**2 + + ! Calculate final radii + para_helpers%r1 = 1.0_dp/sqrt(a) + para_helpers%r2 = 1.0_dp/sqrt(b) + + end function poly_to_parametric_helper + + function poly_to_parametric(rho) result(para) + implicit none + + ! Input parameters + type(rho_coefficients), intent(in) :: rho + + ! Output parameters + type(para_coefficients) :: para + + ! Local variables + type(para_helper_coeffs) :: para_helpers + + ! Calculate helper coefficients + para_helpers = poly_to_parametric_helper(rho) + + ! Calculate final coefficients + para%c_x1 = para_helpers%r1*para_helpers%cosa + para%c_x2 = -para_helpers%r2*para_helpers%sina + para%c_x3 = para_helpers%xc + para%c_y1 = para_helpers%r1*para_helpers%sina + para%c_y2 = para_helpers%r2*para_helpers%cosa + para%c_y3 = para_helpers%yc + + end function poly_to_parametric + + function cartesian_intersection_to_parametric_angle(xs, ys, para) result(alphas) + implicit none + + real(dp), intent(in) :: xs(4) + real(dp), intent(in) :: ys(4) + type(para_coefficients), intent(in) :: para + real(dp) :: alphas(4) + + ! Local variables + real(dp) :: det, xs_centered(4), ys_centered(4), cosa(4), sina(4) + real(dp) :: inv_matrix(2, 2) + integer :: i + + ! Center the ellipse by subtracting c_x3 and c_y3 + xs_centered = xs - para%c_x3 + ys_centered = ys - para%c_y3 + + ! Calculate inverse matrix + det = para%c_x1*para%c_y2 - para%c_x2*para%c_y1 + inv_matrix(1, 1) = para%c_y2/det + inv_matrix(1, 2) = -para%c_x2/det + inv_matrix(2, 1) = -para%c_y1/det + inv_matrix(2, 2) = para%c_x1/det + + ! Calculate cosa and sina for each point + do i = 1, 4 + cosa(i) = inv_matrix(1, 1)*xs_centered(i) + inv_matrix(1, 2)*ys_centered(i) + sina(i) = inv_matrix(2, 1)*xs_centered(i) + inv_matrix(2, 2)*ys_centered(i) + end do + + ! Calculate alpha using atan2 + do i = 1, 4 + alphas(i) = datan2(sina(i), cosa(i)) + end do + + end function cartesian_intersection_to_parametric_angle + +end module parametric_ellipse diff --git a/fortran_implementation/planet_3d.f90 b/fortran_implementation/planet_3d.f90 new file mode 100644 index 0000000..897211e --- /dev/null +++ b/fortran_implementation/planet_3d.f90 @@ -0,0 +1,100 @@ +module three_d_coefficients + use iso_fortran_env, only: dp => real64 + use constants, only: PI + use model_types, only: orbit_parameters, planet_parameters_3d, p_coefficients, rho_coefficients + implicit none + +contains + subroutine compute_3d_coeffs(orbit_params, planet_params, true_anomaly, p_coeffs) + implicit none + type(orbit_parameters), intent(in) :: orbit_params + type(planet_parameters_3d), intent(in) :: planet_params + real(dp), intent(in) :: true_anomaly + type(p_coefficients), intent(out) :: p_coeffs + + real(dp) :: sin_little_omega, cos_little_omega + real(dp) :: sin_big_Omega, cos_big_Omega + real(dp) :: sin_inc, cos_inc + real(dp) :: cos_ta + + real(dp) :: sin_obliquity, cos_obliquity + real(dp) :: sin_precession, cos_precession + + real(dp) :: sin_2_obliquity, cos_2_obliquity + real(dp) :: sin_2_big_Omega, cos_2_big_Omega + real(dp) :: sin_precession_plus_little_omega, cos_precession_plus_little_omega + real(dp) :: sin_2_little_omega, cos_2_little_omega + real(dp) :: sin_2_precession + real(dp) :: sin_ta_minus_precession, cos_ta_minus_precession + real(dp) :: sin_omega_plus_Omega, cos_omega_plus_Omega + + ! this is lazy but... it's a lot of variables + real(dp) :: a, e, i, little_omega, big_Omega, f1, f2, r, f, precession, obliquity + a = orbit_params%semi + e = orbit_params%ecc + i = orbit_params%inc + little_omega = orbit_params%little_omega + big_Omega = orbit_params%big_Omega + f1 = planet_params%f_squish_1 + f2 = planet_params%f_squish_2 + r = planet_params%r + precession = planet_params%precession + obliquity = planet_params%obliquity + f = true_anomaly + + sin_little_omega = dsin(orbit_params%little_omega) + cos_little_omega = dcos(orbit_params%little_omega) + sin_big_Omega = dsin(orbit_params%big_Omega) + cos_big_Omega = dcos(orbit_params%big_Omega) + sin_inc = dsin(orbit_params%inc) + cos_inc = dcos(orbit_params%inc) + cos_ta = dcos(true_anomaly) + + sin_obliquity = dsin(planet_params%obliquity) + cos_obliquity = dcos(planet_params%obliquity) + sin_precession = dsin(planet_params%precession) + cos_precession = dcos(planet_params%precession) + + sin_2_big_Omega = dsin(2.0_dp*orbit_params%big_Omega) + cos_2_big_Omega = dcos(2.0_dp*orbit_params%big_Omega) + sin_2_little_omega = dsin(2.0_dp*orbit_params%little_omega) + cos_2_little_omega = dcos(2.0_dp*orbit_params%little_omega) + sin_omega_plus_Omega = dsin(orbit_params%little_omega + orbit_params%big_Omega) + cos_omega_plus_Omega = dcos(orbit_params%little_omega + orbit_params%big_Omega) + sin_precession_plus_little_omega = dsin(planet_params%precession + orbit_params%little_omega) + cos_precession_plus_little_omega = dcos(planet_params%precession + orbit_params%little_omega) + + sin_2_obliquity = dsin(2.0_dp*planet_params%obliquity) + cos_2_obliquity = dcos(2.0_dp*planet_params%obliquity) + sin_2_precession = dsin(2.0_dp*planet_params%precession) + sin_ta_minus_precession = dsin(true_anomaly - planet_params%precession) + cos_ta_minus_precession = dcos(true_anomaly - planet_params%precession) + + p_coeffs%p_xx = ((cos_little_omega*(cos_big_Omega*sin_precession + cos_inc*cos_precession*sin_big_Omega) + sin_little_omega*(cos_precession*cos_big_Omega - cos_inc*sin_precession*sin_big_Omega))**2/(-1 + f2)**2 + (sin_inc*sin_obliquity*sin_big_Omega + cos_obliquity*sin_precession*(cos_big_Omega*sin_little_omega + cos_inc*cos_little_omega*sin_big_Omega) + cos_precession*cos_obliquity*(-(cos_little_omega*cos_big_Omega) + cos_inc*sin_little_omega*sin_big_Omega))**2 + (cos_big_Omega*sin_precession*sin_obliquity*sin_little_omega + (-(cos_obliquity*sin_inc) + cos_inc*cos_little_omega*sin_precession*sin_obliquity)*sin_big_Omega + cos_precession*sin_obliquity*(-(cos_little_omega*cos_big_Omega) + cos_inc*sin_little_omega*sin_big_Omega))**2/(-1 + f1)**2)/r**2 + p_coeffs%p_xy = ((16*(cos_big_Omega**2*sin_inc*sin_precession*sin_2_obliquity*sin_little_omega - 2*cos_obliquity**2*cos_big_Omega*sin_inc**2*sin_big_Omega - 2*cos_obliquity*sin_inc*sin_precession*sin_obliquity*sin_little_omega*sin_big_Omega**2 + cos_inc*sin_obliquity*(cos_2_little_omega*cos_2_big_Omega*sin_2_precession*sin_obliquity + cos_precession**2*cos_2_big_Omega*sin_obliquity*sin_2_little_omega - cos_2_big_Omega*sin_precession**2*sin_obliquity*sin_2_little_omega + 4*cos_obliquity*cos_little_omega*cos_big_Omega*sin_inc*sin_precession*sin_big_Omega + 4*cos_precession*cos_obliquity*cos_big_Omega*sin_inc*sin_little_omega*sin_big_Omega) - cos_precession*cos_little_omega*(cos_2_big_Omega*sin_inc*sin_2_obliquity + 4*cos_big_Omega*sin_precession*sin_obliquity**2*sin_little_omega*sin_big_Omega) + cos_precession**2*cos_little_omega**2*sin_obliquity**2*sin_2_big_Omega + sin_precession**2*sin_obliquity**2*sin_little_omega**2*sin_2_big_Omega - cos_inc**2*sin_obliquity**2*sin_precession_plus_little_omega**2*sin_2_big_Omega))/(-1 + f1)**2 - 32*(-(cos_precession**2*cos_obliquity**2*cos_little_omega**2*cos_big_Omega*sin_big_Omega) + cos_big_Omega*sin_inc**2*sin_obliquity**2*sin_big_Omega + cos_precession*cos_obliquity*cos_little_omega*(-(cos_big_Omega**2*sin_inc*sin_obliquity) - cos_inc*cos_obliquity*cos_2_big_Omega*sin_precession_plus_little_omega + sin_inc*sin_obliquity*sin_big_Omega**2 + cos_obliquity*sin_precession*sin_little_omega*sin_2_big_Omega) + cos_obliquity*sin_inc*sin_obliquity*(cos_big_Omega**2*sin_precession*sin_little_omega - sin_precession*sin_little_omega*sin_big_Omega**2 + cos_inc*sin_precession_plus_little_omega*sin_2_big_Omega) + cos_obliquity**2*(cos_inc*cos_2_big_Omega*sin_precession*sin_little_omega*sin_precession_plus_little_omega - cos_big_Omega*sin_precession**2*sin_little_omega**2*sin_big_Omega + (cos_inc**2*sin_precession_plus_little_omega**2*sin_2_big_Omega)/2.)) + (4*Sin(i - 2*(precession + little_omega - big_Omega)) - 4*Sin(i + 2*(precession + little_omega - big_Omega)) + 2*Sin(2*(i - big_Omega)) + Sin(2*(i - precession - little_omega - big_Omega)) + 6*Sin(2*(precession + little_omega - big_Omega)) + Sin(2*(i + precession + little_omega - big_Omega)) + 4*sin_2_big_Omega - 2*Sin(2*(i + big_Omega)) - Sin(2*(i - precession - little_omega + big_Omega)) - 6*Sin(2*(precession + little_omega + big_Omega)) - Sin(2*(i + precession + little_omega + big_Omega)) + 4*Sin(i - 2*(precession + little_omega + big_Omega)) - 4*Sin(i + 2*(precession + little_omega + big_Omega)))/(-1 + f2)**2)/(16.*r**2) + p_coeffs%p_xz = (2*(-((cos_precession_plus_little_omega*sin_inc*(cos_little_omega*(cos_big_Omega*sin_precession + cos_inc*cos_precession*sin_big_Omega) + sin_little_omega*(cos_precession*cos_big_Omega - cos_inc*sin_precession*sin_big_Omega)))/(-1 + f2)**2) + (cos_inc*sin_obliquity - cos_obliquity*sin_inc*sin_precession_plus_little_omega)*(sin_inc*sin_obliquity*sin_big_Omega + cos_obliquity*sin_precession*(cos_big_Omega*sin_little_omega + cos_inc*cos_little_omega*sin_big_Omega) + cos_precession*cos_obliquity*(-(cos_little_omega*cos_big_Omega) + cos_inc*sin_little_omega*sin_big_Omega)) - ((cos_inc*cos_obliquity + sin_inc*sin_obliquity*sin_precession_plus_little_omega)*(cos_big_Omega*sin_precession*sin_obliquity*sin_little_omega + (-(cos_obliquity*sin_inc) + cos_inc*cos_little_omega*sin_precession*sin_obliquity)*sin_big_Omega + cos_precession*sin_obliquity*(-(cos_little_omega*cos_big_Omega) + cos_inc*sin_little_omega*sin_big_Omega)))/(-1 + f1)**2))/r**2 + p_coeffs%p_x0 = (2*a*(-1 + e**2)*(-((sin_ta_minus_precession*(cos_little_omega*(cos_big_Omega*sin_precession + cos_inc*cos_precession*sin_big_Omega) + sin_little_omega*(cos_precession*cos_big_Omega - cos_inc*sin_precession*sin_big_Omega)))/(-1 + f2)**2) + (cos_ta_minus_precession*(cos_precession*(2 - 2*f1 + f1**2 + (-2 + f1)*f1*cos_2_obliquity)*(cos_little_omega*cos_big_Omega - cos_inc*sin_little_omega*sin_big_Omega) - 2*((-2 + f1)*f1*cos_obliquity*sin_inc*sin_obliquity*sin_big_Omega + (-1 + f1)**2*cos_obliquity**2*sin_precession*(cos_big_Omega*sin_little_omega + cos_inc*cos_little_omega*sin_big_Omega) + sin_precession*sin_obliquity**2*(cos_big_Omega*sin_little_omega + cos_inc*cos_little_omega*sin_big_Omega))))/(2.*(-1 + f1)**2)))/(r**2*(1 + e*cos_ta)) + p_coeffs%p_yy = ((cos_big_Omega*(sin_inc*sin_obliquity + cos_inc*cos_obliquity*sin_precession_plus_little_omega) + cos_obliquity*cos_precession_plus_little_omega*sin_big_Omega)**2 + (cos_inc*cos_precession_plus_little_omega*cos_big_Omega - sin_precession_plus_little_omega*sin_big_Omega)**2/(-1 + f2)**2 + (cos_obliquity*cos_big_Omega*sin_inc - sin_obliquity*(cos_inc*cos_big_Omega*sin_precession_plus_little_omega + cos_precession_plus_little_omega*sin_big_Omega))**2/(-1 + f1)**2)/r**2 + p_coeffs%p_yz = (2*(-((cos_inc*sin_obliquity - cos_obliquity*sin_inc*sin_precession_plus_little_omega)*(cos_big_Omega*(sin_inc*sin_obliquity + cos_inc*cos_obliquity*sin_precession_plus_little_omega) + cos_obliquity*cos_precession_plus_little_omega*sin_big_Omega)) + (cos_precession_plus_little_omega*sin_inc*(cos_inc*cos_precession_plus_little_omega*cos_big_Omega - sin_precession_plus_little_omega*sin_big_Omega))/(-1 + f2)**2 + ((cos_inc*cos_obliquity + sin_inc*sin_obliquity*sin_precession_plus_little_omega)*(-(cos_obliquity*cos_big_Omega*sin_inc) + sin_obliquity*(cos_inc*cos_big_Omega*sin_precession_plus_little_omega + cos_precession_plus_little_omega*sin_big_Omega)))/(-1 + f1)**2))/r**2 + p_coeffs%p_y0 = (2*a*(-1 + e**2)*(cos_ta_minus_precession*cos_obliquity*(cos_big_Omega*(sin_inc*sin_obliquity + cos_inc*cos_obliquity*sin_precession_plus_little_omega) + cos_obliquity*cos_precession_plus_little_omega*sin_big_Omega) + (sin_ta_minus_precession*(cos_inc*cos_precession_plus_little_omega*cos_big_Omega - sin_precession_plus_little_omega*sin_big_Omega))/(-1 + f2)**2 + (cos_ta_minus_precession*sin_obliquity*(-(cos_obliquity*cos_big_Omega*sin_inc) + sin_obliquity*(cos_inc*cos_big_Omega*sin_precession_plus_little_omega + cos_precession_plus_little_omega*sin_big_Omega)))/(-1 + f1)**2))/(r**2*(1 + e*cos_ta)) + p_coeffs%p_zz = ((cos_precession_plus_little_omega**2*sin_inc**2)/(-1 + f2)**2 + (cos_inc*sin_obliquity - cos_obliquity*sin_inc*sin_precession_plus_little_omega)**2 + (cos_inc*cos_obliquity + sin_inc*sin_obliquity*sin_precession_plus_little_omega)**2/(-1 + f1)**2)/r**2 + p_coeffs%p_z0 = (2*a*(-1 + e**2)*((cos_precession_plus_little_omega*sin_inc*sin_ta_minus_precession)/(-1 + f2)**2 + (cos_ta_minus_precession*(-((-2 + f1)*f1*cos_inc*cos_obliquity*sin_obliquity) + sin_inc*((-1 + f1)**2*cos_obliquity**2 + sin_obliquity**2)*sin_precession_plus_little_omega))/(-1 + f1)**2))/(r**2*(1 + e*cos_ta)) + p_coeffs%p_00 = (a**2*(-1 + e**2)**2*(sin_ta_minus_precession**2/(-1 + f2)**2 + (cos_ta_minus_precession**2*((-1 + f1)**2*cos_obliquity**2 + sin_obliquity**2))/(-1 + f1)**2))/(r + e*r*cos_ta)**2 + + end subroutine compute_3d_coeffs + + subroutine compute_2d_coeffs(p_coeffs, rho_coeffs) + implicit none + type(p_coefficients), intent(in) :: p_coeffs + type(rho_coefficients), intent(out) :: rho_coeffs + + rho_coeffs%rho_xx = p_coeffs%p_xx - p_coeffs%p_xz**2/(4.0*p_coeffs%p_zz) + rho_coeffs%rho_xy = p_coeffs%p_xy - (p_coeffs%p_xz*p_coeffs%p_yz)/(2.0*p_coeffs%p_zz) + rho_coeffs%rho_x0 = p_coeffs%p_x0 - (p_coeffs%p_xz*p_coeffs%p_z0)/(2.0*p_coeffs%p_zz) + rho_coeffs%rho_yy = p_coeffs%p_yy - p_coeffs%p_yz**2/(4.0*p_coeffs%p_zz) + rho_coeffs%rho_y0 = p_coeffs%p_y0 - (p_coeffs%p_yz*p_coeffs%p_z0)/(2.0*p_coeffs%p_zz) + rho_coeffs%rho_00 = p_coeffs%p_00 - p_coeffs%p_z0**2/(4.0*p_coeffs%p_zz) + + end subroutine compute_2d_coeffs + +end module three_d_coefficients diff --git a/fortran_implementation/read_in_files.f90 b/fortran_implementation/read_in_files.f90 new file mode 100644 index 0000000..a543201 --- /dev/null +++ b/fortran_implementation/read_in_files.f90 @@ -0,0 +1,51 @@ +module read_in_files + use, intrinsic :: iso_fortran_env, only: dp => real64 + implicit none + +contains + + function read_time_array(filename) result(times) + implicit none + character(len=*), intent(in) :: filename + real(dp), allocatable :: times(:) + integer :: io_unit, n_times, i, io_status + + ! Open file + open (newunit=io_unit, file=filename, status='old', action='read') + + ! Count lines + n_times = 0 + do + read (io_unit, *, iostat=io_status) + if (io_status /= 0) exit ! Exit if we hit end of file or error + n_times = n_times + 1 + end do + + ! Go back to start + rewind (io_unit) + + ! Read values + allocate (times(n_times)) + do i = 1, n_times + read (io_unit, *) times(i) + end do + + close (io_unit) + end function + + function read_change_of_basis_matrix(filename, dims) result(matrix) + implicit none + character(len=*), intent(in) :: filename + integer, intent(in) :: dims + real(dp), dimension((dims + 1), (dims + 1)) :: matrix + integer :: file_unit + + open (newunit=file_unit, file=filename, form='unformatted', access='stream', status='old') + + read (file_unit) matrix + + close (file_unit) + + end function + +end module read_in_files diff --git a/fortran_implementation/squishyplanet_2d.f90 b/fortran_implementation/squishyplanet_2d.f90 new file mode 100644 index 0000000..e9ee13b --- /dev/null +++ b/fortran_implementation/squishyplanet_2d.f90 @@ -0,0 +1,413 @@ +module squishyplanet_2d + use, intrinsic :: iso_fortran_env, only: dp => real64 + use constants, only: PI, TWO_PI + use model_types, only: orbit_parameters, planet_parameters_2d, rho_coefficients, skypos_positions, para_coefficients, para_helper_coeffs + use keplerian, only: kepler, t0_to_t_peri, skypos + use parametric_ellipse, only: calculate_rho_coefficients, poly_to_parametric, cartesian_intersection_to_parametric_angle + use intersection_pts, only: intersection_points + use solution_vecs, only: planet_solution_vec, star_solution_vec + implicit none + +contains + + subroutine squishyplanet_lightcurve_2d( & + orbit_params, & + planet_params, & + ld_u_coeffs, & + times, & + change_of_basis_matrix, & + fluxes & + ) + implicit none + + ! inputs that change with each sample + type(orbit_parameters), intent(in) :: orbit_params + type(planet_parameters_2d), intent(in) :: planet_params + real(dp), dimension(:), intent(in) :: ld_u_coeffs + + ! inputs that don't change with each sample + real(dp), dimension(:), intent(in) :: times + real(dp), dimension(:, :), intent(in) :: change_of_basis_matrix + real(dp), dimension(:), intent(out) :: fluxes + + ! things that only have to be computed once per lightcurve + real(dp) :: t_peri + real(dp) :: area + real(dp) :: r1 + real(dp) :: r2 + real(dp), dimension(size(ld_u_coeffs) + 1) :: padded_u + real(dp), allocatable :: g_coeffs(:) + real(dp) :: normalization_constant + + ! things associated with the loop over times + integer :: i, q, w, num_intersections + real(dp) :: tmp1 + real(dp) :: time_delta + real(dp) :: mean_anomaly + real(dp) :: true_anomaly + type(skypos_positions) :: pos + logical :: possibly_in_transit + + real(dp) :: planet_contribution + real(dp) :: star_contribution + + ! if it's plausibly transiting + type(rho_coefficients) :: rho + type(para_coefficients) :: para + real(dp), dimension(4, 2) :: pts + logical :: on_limb + + ! if it's on the limb + real(dp), dimension(4) :: alphas ! parametric angle on the planet of star intersection + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! compute everything that only has to be done once + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + t_peri = t0_to_t_peri( & + e=orbit_params%ecc, & + i=orbit_params%inc, & + omega=orbit_params%little_omega, & + period=orbit_params%period, & + t0=orbit_params%t0) + area = PI*planet_params%r_eff**2 + r1 = sqrt(area/((1 - planet_params%f_squish_proj)*PI)) + r2 = r1*(1 - planet_params%f_squish_proj) + + padded_u = -1 + padded_u(2:size(ld_u_coeffs) + 1) = ld_u_coeffs + g_coeffs = matmul(change_of_basis_matrix, padded_u) + + normalization_constant = 1._dp/(PI*(g_coeffs(1) + (2._dp/3._dp)*g_coeffs(2))) + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! the loop over times + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + do i = 1, size(times) + + ! print *, "timestep:", i + ! print *, "time:", times(i) + + time_delta = times(i) - t_peri + mean_anomaly = TWO_PI*time_delta/orbit_params%period + true_anomaly = kepler(M=mean_anomaly, ecc=orbit_params%ecc) + + pos = skypos(orbit_params=orbit_params, f=true_anomaly) + + ! if we're far from the star, don't bother doing anything else + possibly_in_transit = pos%x**2 + pos%y**2 <= (1.0 + r1*1.1)**2 .and. pos%z > 0 + if (.not. possibly_in_transit) then + fluxes(i) = 1.0_dp + ! print *, "not in transit, continuing" + ! print *, "" + cycle + else + ! print *, "in transit" + end if + + ! this one introduces a numerical difference w/ the jax version + rho = calculate_rho_coefficients( & + projected_r=r1, & + projected_f=planet_params%f_squish_proj, & + projected_theta=planet_params%theta_proj, & + xc=pos%x, & + yc=pos%y) + + para = poly_to_parametric(rho=rho) + + pts = intersection_points(rho=rho) + + ! check if we're on the limb + on_limb = .false. + num_intersections = 0 + do q = 1, 4 + if (pts(q, 1) .ne. 999._dp) then + num_intersections = num_intersections + 1 + end if + end do + on_limb = num_intersections > 0 + ! print *, "num_intersections:", num_intersections + + ! if we're not on the limb, we're either fully inside the star + if (on_limb .eqv. .false.) then + ! print *, "no intersections, so fully out or in transit" + + call not_on_limb( & + para=para, & + g_coeffs=g_coeffs, & + normalization_constant=normalization_constant, & + planet_contribution=planet_contribution, & + star_contribution=star_contribution & + ) + + ! if we're on the limb + else + ! print *, "on the limb" + + ! convert the x,y positions of the intersection to + ! parametric angles wrt the planet + alphas = cartesian_intersection_to_parametric_angle( & + xs=pts(:, 1), & + ys=pts(:, 2), & + para=para & + ) + ! filter them to only look at the ones corresponding to real intersections + do q = 1, 4 + if (pts(q, 1) .eq. 999._dp) then + alphas(q) = TWO_PI + end if + end do + + ! housekeeping to wrap them to [0, 2*pi) + do q = 1, 4 + if (alphas(q) .eq. 999._dp) then + alphas(q) = TWO_PI + end if + if (alphas(q) .lt. 0.0_dp) then + alphas(q) = alphas(q) + TWO_PI + end if + if (alphas(q) .gt. TWO_PI) then + alphas(q) = alphas(q) - TWO_PI + end if + end do + + ! sort them + do q = 1, 3 + do w = 1, 4 - q + if (alphas(w) > alphas(w + 1)) then + ! Swap elements + tmp1 = alphas(w) + alphas(w) = alphas(w + 1) + alphas(w + 1) = tmp1 + end if + end do + end do + + if (num_intersections == 2) then + ! print *, "two intersections, calling subroutine" + call two_intersections( & + alpha_1=alphas(1), & + alpha_2=alphas(2), & + para=para, & + g_coeffs=g_coeffs, & + normalization_constant=normalization_constant, & + planet_contribution=planet_contribution, & + star_contribution=star_contribution & + ) + else + ! print *, "four intersections" + call four_intersections( & + alphas=alphas, & + para=para, & + g_coeffs=g_coeffs, & + normalization_constant=normalization_constant, & + planet_contribution=planet_contribution, & + star_contribution=star_contribution & + ) + end if + end if ! on_limb + + fluxes(i) = 1.0_dp - (planet_contribution + star_contribution) + ! print *, "fluxes(i):", fluxes(i) + end do + + end subroutine squishyplanet_lightcurve_2d + + subroutine not_on_limb( & + para, & + g_coeffs, & + normalization_constant, & + planet_contribution, & + star_contribution & + ) + implicit none + type(para_coefficients), intent(in) :: para + real(dp), allocatable, intent(in) :: g_coeffs(:) + real(dp), intent(in) :: normalization_constant + real(dp), intent(out) :: planet_contribution + real(dp), intent(out) :: star_contribution + + real(dp), allocatable :: planet_solution_vector(:) + logical :: fully_inside_star + + ! first, we're not actually sure if we're inside the star or not: + ! we only know we're not on the limb + fully_inside_star = (para%c_x3*para%c_x3 + para%c_y3*para%c_y3) <= 1 + + if (fully_inside_star .neqv. .true.) then + ! print *, "actually, not in transit, fooled by the buffer" + planet_contribution = 0.0_dp + star_contribution = 0.0_dp + return + end if + + ! print *, "ok, we're fully inside the star, integrating just the planet" + + ! if we're fully inside the star, we just need to integrate the planet + ! from 0 to 2*pi + call planet_solution_vec( & + a=0.0_dp, & + b=TWO_PI, & + g_coeffs=g_coeffs, & + para=para, & + solution_vector=planet_solution_vector & + ) + + planet_contribution = dot_product(g_coeffs, planet_solution_vector)*normalization_constant + star_contribution = 0.0_dp + + end subroutine not_on_limb + + subroutine two_intersections( & + alpha_1, & + alpha_2, & + para, & + g_coeffs, & + normalization_constant, & + planet_contribution, & + star_contribution & + ) + implicit none + real(dp), intent(in) :: alpha_1 + real(dp), intent(in) :: alpha_2 + type(para_coefficients), intent(in) :: para + real(dp), allocatable, intent(in) :: g_coeffs(:) + real(dp), intent(in) :: normalization_constant + real(dp), intent(out) :: planet_contribution + real(dp), intent(out) :: star_contribution + + real(dp), allocatable :: planet_solution_vector(:), star_solution_vector(:) + real(dp) :: test_ang, test_val, tmp1, tmp2 + + planet_contribution = 0.0_dp + star_contribution = 0.0_dp + ! print *, "alpha_1:", alpha_1 + ! print *, "alpha_2:", alpha_2 + + ! ! check the orientation of the planet + test_ang = alpha_1 + (alpha_2 - alpha_1)/2.0_dp + if (test_ang > TWO_PI) then + test_ang = test_ang - TWO_PI + end if + tmp1 = dcos(test_ang) + tmp2 = dsin(test_ang) + + test_val = sqrt( & + (para%c_x1*tmp1 + para%c_x2*tmp2 + para%c_x3)**2 + & + (para%c_y1*tmp1 + para%c_y2*tmp2 + para%c_y3)**2 & + ) + + if (test_val > 1.0_dp) then + ! print *, "test_val is outside the star" + ! if you're outside the star, instead of integrating two legs separately, + ! you can just wrap passed 2pi + call planet_solution_vec( & + a=alpha_2, & + b=alpha_1 + TWO_PI, & + g_coeffs=g_coeffs, & + para=para, & + solution_vector=planet_solution_vector & + ) + planet_contribution = dot_product(g_coeffs, planet_solution_vector)*normalization_constant + else + ! print *, "test_val is inside the star" + call planet_solution_vec( & + a=alpha_1, & + b=alpha_2, & + g_coeffs=g_coeffs, & + para=para, & + solution_vector=planet_solution_vector & + ) + planet_contribution = dot_product(g_coeffs, planet_solution_vector)*normalization_constant + end if + + ! regardless, always integrate the star from alpha1 to alpha2 + ! (alpha is defined wrt the planet, but star_solution_vec converts it to the star's frame) + call star_solution_vec( & + a=alpha_1, & + b=alpha_2, & + g_coeffs=g_coeffs, & + para=para, & + solution_vector=star_solution_vector & + ) + star_contribution = dot_product(g_coeffs, star_solution_vector)*normalization_constant + + ! print *, "planet_contribution:", planet_contribution + ! print *, "star_contribution:", star_contribution + + end subroutine two_intersections + + subroutine four_intersections( & + alphas, & + para, & + g_coeffs, & + normalization_constant, & + planet_contribution, & + star_contribution & + ) + implicit none + real(dp), intent(in) :: alphas(4) + type(para_coefficients), intent(in) :: para + real(dp), allocatable, intent(in) :: g_coeffs(:) + real(dp), intent(in) :: normalization_constant + real(dp), intent(out) :: planet_contribution + real(dp), intent(out) :: star_contribution + + integer :: i + real(dp), dimension(4, 2) :: alpha_pairs + real(dp) :: a1, a2, test_ang, test_val, tmp1, tmp2 + logical :: is_planet_chunk + real(dp), allocatable :: planet_solution_vector(:), star_solution_vector(:) + + star_contribution = 0.0_dp + planet_contribution = 0.0_dp + + do i = 1, 4 + alpha_pairs(i, 1) = alphas(i) + alpha_pairs(i, 2) = alphas(mod(i, 4) + 1) + end do + + do i = 1, 4 + a1 = alpha_pairs(i, 1) + a2 = alpha_pairs(i, 2) + + ! figure out if we're looking at a chunk that's along the edge + ! of the planet or the star + test_ang = a1 + (a2 - a1)/2.0_dp + if (test_ang > TWO_PI) then + test_ang = test_ang - TWO_PI + end if + tmp1 = dcos(test_ang) + tmp2 = dsin(test_ang) + + test_val = sqrt( & + (para%c_x1*tmp1 + para%c_x2*tmp2 + para%c_x3)**2 + & + (para%c_y1*tmp1 + para%c_y2*tmp2 + para%c_y3)**2 & + ) + is_planet_chunk = test_val < 1.0_dp + + if (is_planet_chunk) then + call planet_solution_vec( & + a=a1, & + b=a2, & + g_coeffs=g_coeffs, & + para=para, & + solution_vector=planet_solution_vector & + ) + planet_contribution = planet_contribution + dot_product(g_coeffs, planet_solution_vector)*normalization_constant + star_contribution = star_contribution + 0.0_dp + else + call star_solution_vec( & + a=a1, & + b=a2, & + g_coeffs=g_coeffs, & + para=para, & + solution_vector=star_solution_vector & + ) + planet_contribution = planet_contribution + 0.0_dp + star_contribution = star_contribution + dot_product(g_coeffs, star_solution_vector)*normalization_constant + end if + end do + + end subroutine four_intersections + +end module squishyplanet_2d diff --git a/fortran_implementation/squishyplanet_3d.f90 b/fortran_implementation/squishyplanet_3d.f90 new file mode 100644 index 0000000..550d0fa --- /dev/null +++ b/fortran_implementation/squishyplanet_3d.f90 @@ -0,0 +1,422 @@ +module squishyplanet_3d + use, intrinsic :: iso_fortran_env, only: dp => real64 + use constants, only: PI, TWO_PI + use model_types, only: orbit_parameters, planet_parameters_3d, p_coefficients, rho_coefficients, skypos_positions, para_coefficients, para_helper_coeffs + use keplerian, only: kepler, t0_to_t_peri, skypos + use parametric_ellipse, only: calculate_rho_coefficients, poly_to_parametric, cartesian_intersection_to_parametric_angle + use intersection_pts, only: intersection_points + use solution_vecs, only: planet_solution_vec, star_solution_vec + use three_d_coefficients, only: compute_3d_coeffs, compute_2d_coeffs + implicit none + +contains + + subroutine squishyplanet_lightcurve_3d( & + orbit_params, & + planet_params, & + ld_u_coeffs, & + tidally_locked, & + times, & + change_of_basis_matrix, & + fluxes) + implicit none + + ! inputs that change with each sample + type(orbit_parameters), intent(in) :: orbit_params + type(planet_parameters_3d), intent(inout) :: planet_params ! might change the precession if tidally locked + real(dp), dimension(:), intent(in) :: ld_u_coeffs + + ! inputs that don't change with each sample + logical, intent(in) :: tidally_locked + real(dp), dimension(:), intent(in) :: times + real(dp), dimension(:, :), intent(in) :: change_of_basis_matrix + real(dp), dimension(:), intent(out) :: fluxes + + ! things that only have to be computed once per lightcurve + real(dp) :: t_peri + real(dp), dimension(size(ld_u_coeffs) + 1) :: padded_u + real(dp), allocatable :: g_coeffs(:) + real(dp) :: normalization_constant + + ! things associated with the loop over times + integer :: i, q, w, num_intersections + real(dp) :: tmp1 + real(dp) :: time_delta + real(dp) :: mean_anomaly + real(dp) :: true_anomaly + type(skypos_positions) :: pos + logical :: possibly_in_transit + + real(dp) :: planet_contribution + real(dp) :: star_contribution + + ! if it's plausibly transiting + type(p_coefficients) :: p_coeffs + type(rho_coefficients) :: rho + type(para_coefficients) :: para + real(dp), dimension(4, 2) :: pts + logical :: on_limb + + ! if it's on the limb + real(dp), dimension(4) :: alphas ! parametric angle on the planet of star intersection + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! compute everything that only has to be done once + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + t_peri = t0_to_t_peri( & + e=orbit_params%ecc, & + i=orbit_params%inc, & + omega=orbit_params%little_omega, & + period=orbit_params%period, & + t0=orbit_params%t0) + + padded_u = -1 + padded_u(2:size(ld_u_coeffs) + 1) = ld_u_coeffs + g_coeffs = matmul(change_of_basis_matrix, padded_u) + + normalization_constant = 1._dp/(PI*(g_coeffs(1) + (2._dp/3._dp)*g_coeffs(2))) + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! the loop over times + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + do i = 1, size(times) + + ! print *, "timestep:", i + ! print *, "time:", times(i) + + time_delta = times(i) - t_peri + mean_anomaly = TWO_PI*time_delta/orbit_params%period + true_anomaly = kepler(M=mean_anomaly, ecc=orbit_params%ecc) + + pos = skypos(orbit_params=orbit_params, f=true_anomaly) + + ! if we're far from the star, don't bother doing anything else + possibly_in_transit = pos%x**2 + pos%y**2 <= (1.0 + planet_params%r*1.1)**2 .and. pos%z > 0 + if (.not. possibly_in_transit) then + fluxes(i) = 1.0_dp + ! print *, "not in transit, continuing" + ! print *, "" + cycle + else + ! print *, "in transit" + end if + + ! force the planet to "precess" s.t. its nose always points towards the star + if (tidally_locked) then + planet_params%precession = true_anomaly + end if + + ! compute the p coefficients, the coeffs that describe the 3d xyz quadratic planet shape + call compute_3d_coeffs( & + orbit_params=orbit_params, & + planet_params=planet_params, & + true_anomaly=true_anomaly, & + p_coeffs=p_coeffs & + ) + + ! compute the rho coefficients, the coeffs that describe the 2d xy quadratic planet shape + call compute_2d_coeffs( & + p_coeffs=p_coeffs, & + rho_coeffs=rho & + ) + + ! from here on out, it's the exact same as the 2d version + + ! convert the 2d rho coefficients to parametric form, + ! describe x and y of planet's outline as 1D functions of angle + para = poly_to_parametric(rho=rho) + + ! find the intersection points of the planet with the star + pts = intersection_points(rho=rho) + + ! check if we're on the limb + on_limb = .false. + num_intersections = 0 + do q = 1, 4 + if (pts(q, 1) .ne. 999._dp) then + num_intersections = num_intersections + 1 + end if + end do + on_limb = num_intersections > 0 + ! print *, "num_intersections:", num_intersections + + ! if we're not on the limb, we're either fully inside or outside the star + if (on_limb .eqv. .false.) then + ! print *, "no intersections, so fully out or in transit" + + call not_on_limb( & + para=para, & + g_coeffs=g_coeffs, & + normalization_constant=normalization_constant, & + planet_contribution=planet_contribution, & + star_contribution=star_contribution & + ) + + ! if we're on the limb + else + ! print *, "on the limb" + + ! convert the x,y positions of the intersection to + ! parametric angles wrt the planet's frame + alphas = cartesian_intersection_to_parametric_angle( & + xs=pts(:, 1), & + ys=pts(:, 2), & + para=para & + ) + ! filter them to only look at the ones corresponding to real intersections + do q = 1, 4 + if (pts(q, 1) .eq. 999._dp) then + alphas(q) = TWO_PI + end if + end do + + ! housekeeping to wrap them to [0, 2*pi) + do q = 1, 4 + if (alphas(q) .eq. 999._dp) then + alphas(q) = TWO_PI + end if + if (alphas(q) .lt. 0.0_dp) then + alphas(q) = alphas(q) + TWO_PI + end if + if (alphas(q) .gt. TWO_PI) then + alphas(q) = alphas(q) - TWO_PI + end if + end do + + ! sort them + do q = 1, 3 + do w = 1, 4 - q + if (alphas(w) > alphas(w + 1)) then + ! Swap elements + tmp1 = alphas(w) + alphas(w) = alphas(w + 1) + alphas(w + 1) = tmp1 + end if + end do + end do + + if (num_intersections == 2) then + ! print *, "two intersections, calling subroutine" + call two_intersections( & + alpha_1=alphas(1), & + alpha_2=alphas(2), & + para=para, & + g_coeffs=g_coeffs, & + normalization_constant=normalization_constant, & + planet_contribution=planet_contribution, & + star_contribution=star_contribution & + ) + else + ! print *, "four intersections" + call four_intersections( & + alphas=alphas, & + para=para, & + g_coeffs=g_coeffs, & + normalization_constant=normalization_constant, & + planet_contribution=planet_contribution, & + star_contribution=star_contribution & + ) + end if + end if ! on_limb + + fluxes(i) = 1.0_dp - (planet_contribution + star_contribution) + ! print *, "fluxes(i):", fluxes(i) + end do + + end subroutine squishyplanet_lightcurve_3d + + subroutine not_on_limb( & + para, & + g_coeffs, & + normalization_constant, & + planet_contribution, & + star_contribution & + ) + implicit none + type(para_coefficients), intent(in) :: para + real(dp), allocatable, intent(in) :: g_coeffs(:) + real(dp), intent(in) :: normalization_constant + real(dp), intent(out) :: planet_contribution + real(dp), intent(out) :: star_contribution + + real(dp), allocatable :: planet_solution_vector(:) + logical :: fully_inside_star + + ! first, we're not actually sure if we're inside the star or not: + ! we only know we're not on the limb + fully_inside_star = (para%c_x3*para%c_x3 + para%c_y3*para%c_y3) <= 1 + + if (fully_inside_star .neqv. .true.) then + ! print *, "actually, not in transit, fooled by the buffer" + planet_contribution = 0.0_dp + star_contribution = 0.0_dp + return + end if + + ! print *, "ok, we're fully inside the star, integrating just the planet" + + ! if we're fully inside the star, we just need to integrate the planet + ! from 0 to 2*pi + call planet_solution_vec( & + a=0.0_dp, & + b=TWO_PI, & + g_coeffs=g_coeffs, & + para=para, & + solution_vector=planet_solution_vector & + ) + + planet_contribution = dot_product(g_coeffs, planet_solution_vector)*normalization_constant + star_contribution = 0.0_dp + + end subroutine not_on_limb + + subroutine two_intersections( & + alpha_1, & + alpha_2, & + para, & + g_coeffs, & + normalization_constant, & + planet_contribution, & + star_contribution & + ) + implicit none + real(dp), intent(in) :: alpha_1 + real(dp), intent(in) :: alpha_2 + type(para_coefficients), intent(in) :: para + real(dp), allocatable, intent(in) :: g_coeffs(:) + real(dp), intent(in) :: normalization_constant + real(dp), intent(out) :: planet_contribution + real(dp), intent(out) :: star_contribution + + real(dp), allocatable :: planet_solution_vector(:), star_solution_vector(:) + real(dp) :: test_ang, test_val, tmp1, tmp2 + + ! ! check the orientation of the planet + test_ang = alpha_1 + (alpha_2 - alpha_1)/2.0_dp + if (test_ang > TWO_PI) then + test_ang = test_ang - TWO_PI + end if + tmp1 = dcos(test_ang) + tmp2 = dsin(test_ang) + + test_val = sqrt( & + (para%c_x1*tmp1 + para%c_x2*tmp2 + para%c_x3)**2 + & + (para%c_y1*tmp1 + para%c_y2*tmp2 + para%c_y3)**2 & + ) + + if (test_val > 1.0_dp) then + ! print *, "test_val is outside the star" + ! if you're outside the star, instead of integrating two legs separately, + ! you can just wrap passed 2pi + call planet_solution_vec( & + a=alpha_2, & + b=alpha_1 + TWO_PI, & + g_coeffs=g_coeffs, & + para=para, & + solution_vector=planet_solution_vector & + ) + + planet_contribution = dot_product(g_coeffs, planet_solution_vector)*normalization_constant + else + ! print *, "test_val is inside the star" + call planet_solution_vec( & + a=alpha_1, & + b=alpha_2, & + g_coeffs=g_coeffs, & + para=para, & + solution_vector=planet_solution_vector & + ) + planet_contribution = dot_product(g_coeffs, planet_solution_vector)*normalization_constant + end if + + ! regardless, always integrate the star from alpha1 to alpha2 + ! (alpha is defined wrt the planet, but star_solution_vec converts it to the star's frame) + call star_solution_vec( & + a=alpha_1, & + b=alpha_2, & + g_coeffs=g_coeffs, & + para=para, & + solution_vector=star_solution_vector & + ) + star_contribution = dot_product(g_coeffs, star_solution_vector)*normalization_constant + + ! print *, "planet_contribution:", planet_contribution + ! print *, "star_contribution:", star_contribution + + end subroutine two_intersections + + subroutine four_intersections( & + alphas, & + para, & + g_coeffs, & + normalization_constant, & + planet_contribution, & + star_contribution & + ) + implicit none + real(dp), intent(in) :: alphas(4) + type(para_coefficients), intent(in) :: para + real(dp), allocatable, intent(in) :: g_coeffs(:) + real(dp), intent(in) :: normalization_constant + real(dp), intent(out) :: planet_contribution + real(dp), intent(out) :: star_contribution + + integer :: i + real(dp), dimension(4, 2) :: alpha_pairs + real(dp) :: a1, a2, test_ang, test_val, tmp1, tmp2 + logical :: is_planet_chunk + real(dp), allocatable :: planet_solution_vector(:), star_solution_vector(:) + + star_contribution = 0.0_dp + planet_contribution = 0.0_dp + + do i = 1, 4 + alpha_pairs(i, 1) = alphas(i) + alpha_pairs(i, 2) = alphas(mod(i, 4) + 1) + end do + + do i = 1, 4 + a1 = alpha_pairs(i, 1) + a2 = alpha_pairs(i, 2) + + ! figure out if we're looking at a chunk that's along the edge + ! of the planet or the star + test_ang = a1 + (a2 - a1)/2.0_dp + if (test_ang > TWO_PI) then + test_ang = test_ang - TWO_PI + end if + tmp1 = dcos(test_ang) + tmp2 = dsin(test_ang) + + test_val = sqrt( & + (para%c_x1*tmp1 + para%c_x2*tmp2 + para%c_x3)**2 + & + (para%c_y1*tmp1 + para%c_y2*tmp2 + para%c_y3)**2 & + ) + is_planet_chunk = test_val < 1.0_dp + + if (is_planet_chunk) then + call planet_solution_vec( & + a=a1, & + b=a2, & + g_coeffs=g_coeffs, & + para=para, & + solution_vector=planet_solution_vector & + ) + planet_contribution = planet_contribution + dot_product(g_coeffs, planet_solution_vector)*normalization_constant + star_contribution = star_contribution + 0.0_dp + else + call star_solution_vec( & + a=a1, & + b=a2, & + g_coeffs=g_coeffs, & + para=para, & + solution_vector=star_solution_vector & + ) + planet_contribution = planet_contribution + 0.0_dp + star_contribution = star_contribution + dot_product(g_coeffs, star_solution_vector)*normalization_constant + end if + end do + + end subroutine four_intersections + +end module squishyplanet_3d diff --git a/fortran_implementation/testing/2d_lightcurve.bin b/fortran_implementation/testing/2d_lightcurve.bin new file mode 100644 index 0000000..d4b1f91 Binary files /dev/null and b/fortran_implementation/testing/2d_lightcurve.bin differ diff --git a/fortran_implementation/testing/3d_lightcurve.bin b/fortran_implementation/testing/3d_lightcurve.bin new file mode 100644 index 0000000..7af764e Binary files /dev/null and b/fortran_implementation/testing/3d_lightcurve.bin differ diff --git a/fortran_implementation/testing/3d_lightcurve_tl.bin b/fortran_implementation/testing/3d_lightcurve_tl.bin new file mode 100644 index 0000000..490e73e Binary files /dev/null and b/fortran_implementation/testing/3d_lightcurve_tl.bin differ diff --git a/fortran_implementation/testing/scratch.ipynb b/fortran_implementation/testing/scratch.ipynb new file mode 100644 index 0000000..6715ff3 --- /dev/null +++ b/fortran_implementation/testing/scratch.ipynb @@ -0,0 +1,453 @@ +{ + "cells": [ + { + "cell_type": "code", + "execution_count": 1, + "metadata": {}, + "outputs": [], + "source": [ + "import jax\n", + "\n", + "jax.config.update(\"jax_enable_x64\", True)\n", + "import jax.numpy as jnp\n", + "import matplotlib.pyplot as plt" + ] + }, + { + "cell_type": "code", + "execution_count": 2, + "metadata": {}, + "outputs": [], + "source": [ + "with open(\"times.txt\", \"w\") as f:\n", + " for i in jnp.linspace(-1,1,100):\n", + " f.write(str(float(i)) + \"\\n\")" + ] + }, + { + "cell_type": "code", + "execution_count": 4, + "metadata": {}, + "outputs": [ + { + "data": { + "text/plain": [ + "[]" + ] + }, + "execution_count": 4, + "metadata": {}, + "output_type": "execute_result" + }, + { + "data": { + "image/png": "iVBORw0KGgoAAAANSUhEUgAAAncAAAFeCAYAAADngTkBAAAAOXRFWHRTb2Z0d2FyZQBNYXRwbG90bGliIHZlcnNpb24zLjkuMiwgaHR0cHM6Ly9tYXRwbG90bGliLm9yZy8hTgPZAAAACXBIWXMAAA9hAAAPYQGoP6dpAABRjUlEQVR4nO3deXxTZb4/8M9Jui9JW7qklFIFYSSopWBE4NYRuMAIDLjgwkvhCtYrYxDUcZhbhzvWuUhl9F4YNA4XkOXndHCuK6IUBriMw+ioBToMXKnLsJUCpUCbdEvbJM/vj/SkDemW0uZk+bxfr77anvOc5JscSr99lu8jCSEEiIiIiCgoqJQOgIiIiIj6DpM7IiIioiDC5I6IiIgoiDC5IyIiIgoiTO6IiIiIggiTOyIiIqIgwuSOiIiIKIiEKR2Av3I4HDh37hzi4+MhSZLS4RAREVGIE0KgtrYWAwcOhErVef8ck7tOnDt3DpmZmUqHQUREROSmvLwcgwYN6vQ8k7tOxMfHA3C+gRqNpl+ew2KxIDMzs1+fAwAMBgNKSkr67fF9+Tz9/Ry8J/73HL66J0BwvF++eo5g+lkJlufgPfG/5+nreyI/npyjdIbJXSfkoViNRtPvv1D6+znUanW/vwZfPY+vXgvviX89B+Cbn8Vgeb98dU+A4PhZCZbnkPGe+N/z9PU96W66GBdUhACj0Rg0z+Or19LfeE/8U7C8X7wnofkcvhJM71cw3Zf2JCGEUDoIf2SxWKDVamE2m/t1WLa/n4O8w3vif3hP/BPvi//hPfE/fX1Pevp47LlTUGRkJF544QVERkYqHQq14j3xP7wn/on3xf/wnvgfpe4Je+46wb+AiIiIyJ+w546IiIgoBF1Tcnfs2DGMHz8ekiTh1KlTvXqMt956CwaDAampqdDpdLj//vvx7bffdtq+rKwMc+bMgU6nQ2pqKgwGA4qKijptb7Va8cILL2DYsGFITU1FVlYWnn76aZjN5l7FS0REROTPepXcWa1W/OIXv8APf/hDfPfdd71+8uXLl+PRRx+F0WhEZWUlysrKYLPZYDAY8Pe//92jfWlpKW677TbY7XaUlZWhsrISRqMR8+fPR0FBgUf7lpYWTJ8+HevWrcPvf/97XLx4EXv37sXOnTuRm5sLi8XS69iJiIiI/JLohSeeeELMnj1blJeXix/+8IcCgDh58qRXj3Hw4EEhSZKYP3++2/GamhoRHx8vxowZIxwOh+u4w+EQ2dnZIj4+XtTU1LhdM2/ePKFSqURpaanb8f/8z/8UAMSmTZvcju/bt08AEM8880yn8ZnNZgFAmM1mr14XERERUX/oaW7Sq567/Px8fPjhh11ufdEdk8kEIQTmzp3rdlyr1eKuu+7CoUOH8Pnnn7uOHzhwAEeOHMH06dOh1Wrdrpk7dy4cDgdMJpPHc6jVatx///1uxydOnIi0tDRs3LgRVqu116+BiIiIyN/0KrnLysq65ifet28fAGDMmDEe5+Rje/bs6XX7kydP4sSJE/jBD36AuLg4t/aSJGH06NGora3FF198cY2vhIiIiMh/KLL9WENDA86cOYOIiAikpKR4nM/IyADgXDwhO378uNu59lJSUhAeHo7Tp0+jsbER0dHRXba/+jnuvPPOTmO9el5eZGRkn9SrqahpxN2mz675cYj6wsxb0vHCj0cqHQYRBYlf7yrDu4fOItRqrUWFq3Bg2aQ+e7ympiY0NTW5vu/pWgFFkruamhoAQExMTIfnY2NjAQDV1dUe18jn2pMkCTExMTCbzaipqUF0dHSX7Tt7jo5kZma6ff/CCy90uHjDWw6HQFVtU/cNiXxg82encNdN6bjt+iSlQyGiAPf9xVr89tN/IBSr6EaHq/v08QoLC/Hiiy96fZ0iyV0gKS8vdysU2FdVptM0UShemtsnj0V0Ld78y0m8e+gsXtp5HB8+Ob7bDamJiLryxn5nYjfxBylY9qMblQ7Hp/r6v8/8/Hw8++yzru8tFotHp1NHFEnuEhISADiHZztSX18PAEhMTPS4Rj7XnhDC9Vhyu67ad/YcHdFoNP2yQ0VEmAoj0rnzBSnv5z+6EcVHz+NIeQ0+/vt5/Dh7oNIhEVGAOnO5AduPnAMAPDNlOH/PXaPeTgVTZIeKmJgYDB48GM3NzaiqqvI4X1FRAQC48ca2jH/EiBFu59qrqqpCS0sLsrKyEB0d3W37zp6DKBSlxEdi0Q+HAgBW7SpDk82ucEREFKh+++k/YHcI3DE8BbcMSlA6nJCl2PZjkydPBgAcOnTI45x8bMqUKb1uf/3112PIkCH49ttvUVdX59ZeCIHS0lLEx8fj9ttvv8ZXQhT48nKHIE0TibPVjXjrr6eVDoeIAtB5cyPePVQOAHhq0g0KRxPa+j25E0KgvLzc47jRaIQkSdi2bZvbcbPZjOLiYowePRrjx493Hc/NzUV2djZ27tzpsXXYtm3boFKpYDQaPZ7DZrPhnXfecTu+f/9+XLhwAXl5eYiKirrWl0gU8KIj1PjplB8AAF773+9R09CscEREFGjW//kEWuwCt12fBMN1XJylpH5P7pYsWYLBgwdj6dKlbsfHjBmD559/Hr/73e+wdetWCCFgNpvx6KOPAgA2bdrkNrFbkiRs3rwZQggsWLAAZrMZQghs2bIFRUVFWL58OUaNGuX2HE899RTuvPNO/Nu//RtKSkoAAN999x1+8pOf4Oabb+6TVa9EweK+MYNwoy4e5sYWvP6/3ysdDhEFkEt1Tdj21RkA7LXzB71K7r766ivodDrodDrXLhIGgwE6nQ4//elP3dpmZmYiJiamw9UdK1aswObNm7F27VqkpaVh+PDhUKvVKCkpQXZ2tkf7nJwclJSUQJIkDB8+HKmpqXj99dexdevWDpcKh4eHo7i4GIsWLcJDDz2E1NRUTJ48GXfddRcOHDjQLwsliAKVWiXh3+5yzkH9f389jfIrHS94IiK62pt/OQlriwPZmQn4pxuSlQ4n5ElChGIlmu5ZLBZotVqYzWYmgRQyhBCY9+ZX+Mv3l/Dj7IF4bW6O0iERkZ+raWjGhJf/F/XNdmyYfyum6NOUDilo9TQ3UWxBBRH5H0mSsOxHzrl3u46dh83uUDgiIvJ3Wz4/hfpmO27UxWPyjalKh0NgckdEV7lpoBZR4Sq02AXKqxuVDoeI/Jw818448QaoVCyC7g+Y3BGRG5VKwvXJcQCAk5fqumlNRKGsur4ZlRbnVpqTR7DXzl8wuSMiD0OSnXsvn6jqeIcXIiIA+L7K+QdgRkI0YiK4o6m/YHJHRB6GpDiTu38wuSOiLnx/0ZncDU2NUzgSao/JXTcMBgP0ej1MJpPSoRD5jJzccViWiLoiJ3fDmNz1K5PJBL1eD4PB0KP27EPtRklJCUuhUMiR59xxWJaIuiIndzcwuetXRqMRRqPRVQqlO+y5IyIPcs/dxdom1FpbFI6GiPwVkzv/xOSOiDxoosKRHBcJADh1iTtVEJGn+iYbKmqc5ZJuSGFy50+Y3BFRh1wrZjnvjog6IE/bGBAbgcTYCIWjofaY3BFRh7hiloi68n1VLQCulPVHTO6IqENtK2aZ3BGRJ863819M7oioQ20rZjksS0SeXMkd59v5HSZ3RNSh9j13QgiFoyEif8OeO//F5I6IOjQ4KQZhKgkNzXbX3pFERADQYnfg9GXnSnomd/6HyR0RdShcrcLgpBgAHJolInenL9fD5hCIjVAjXRuldDh0FSZ3RNSp61vLofyDiyqIqJ32Q7KSJCkcDV2NyR0Rdco1747lUIione8qnckdy6D4JyZ3RNSpIa2r4FjImIja+76Kiyn8GZO7bhgMBuj1ephMJqVDIfI5eVj2BHvuiKgdlkHxLZPJBL1eD4PB0KP2Yf0cT8ArKSmBRqNROgwiRcjDsmerG9BksyMyTK1wRESkNIdD4B/sufMpo9EIo9EIi8UCrVbbbXv23BFRp1LiIhEfGQaHAM60lj0gotBWUdMIa4sDEe1W1JN/YXJHRJ2SJAnXc49ZImpHnm93XXIMwtRMI/wR7woRdWmIPO+OiyqICMA/uDOF32NyR0RdklfMshwKEQFcTBEImNwRUZdcK2ZZyJiI0Jbcscad/2JyR0RdklfMcgsyIhJC4DsOy/o9JndE1CW55666oQXV9c0KR0NESrpU1wxzYwskCRjKYVm/xeSOiLoUExHm2hicQ7NEoU0eks1MjEFUOOte+ismd0TULQ7NEhHAbccCBZM7IurWkOTWFbPsuSMKaSyDEhiY3BFRt7jHLBEBLIMSKJjcEVG3XMOyLGRMFNJYBiUwMLnrhsFggF6vh8lkUjoUIsXIq+JOXW6AwyEUjoaIlNDYbMcFixUAMLT1Dz7yDZPJBL1eD4PB0KP2Yf0cT8ArKSmBRqNROgwiRaVro6BWSWi2OVBV14Q0TZTSIRGRj52tbgAAxEeGQRsdrnA0ocVoNMJoNMJisUCr1Xbbnj13RNStMLUKutaErqKmUeFoiEgJ5a3J3aCkGEiSpHA01BUmd0TUIxkJ0QCAc0zuiELS2Wrnz35mYrTCkVB3mNwRUY8MTGjtuatmckcUisqvOHvuMpNiFI6EusPkjoh6ZCB77ohCWvkV9twFCiZ3RNQjGa3/oVfUWBWOhIiU4Jpzl8ieO3/H5I6IekTuueOCCqLQxGHZwNGr5K6srAxz5syBTqdDamoqDAYDioqKvHqMyspKLFmyBEOHDkVSUhKSk5Mxe/ZsHDp0qNNr3n//fUyaNAlJSUlITEyEXq/HypUr0dTU1OlzPPvssxgxYgTS0tIwaNAgTJ48GTt37vQqViLiggqiUGZubIHFagMADOKwrN/zOrkrLS3FbbfdBrvdjrKyMlRWVsJoNGL+/PkoKCjo0WOcPHkSOTk52LFjB95++21cuXIFx48fBwCMHz8ee/fu9bgmPz8f9913HwwGA86cOYNLly5h5cqVKCwsxKxZs2C3293aX7x4EaNHj8bvf/97bNy4EZWVlfjmm28wbNgwzJgxA6+88oq3L50opMk9d+bGFtQ12RSOhoh8Se61GxAbgdhIlsj1e8ILDodDZGdni/j4eFFTU+N2bt68eUKlUonS0tJuH2fmzJkCgNi+fbvbcbPZLLRarcjMzBRWq9V1/ODBgwKAyMnJ8XisgoICAUCYTCa34y+99JIAINasWeN2vLm5WaSkpIj4+HjR3NzcaYxms1kAEGazudvXQxQqbinYLbJ+/rH45oJF6VCIyIeKj54TWT//WMx6/S9KhxLSepqbeNVzd+DAARw5cgTTp0/3qJA8d+5cOByObrfpslqt2LVrFwBg6tSpbuc0Gg1yc3NRXl6OTz75xHX8gw8+6LA9AMycORMAsG7dOrfj5eXlAIDhw4e7HQ8PD8d1112H2tpaXLlypctYicgd590RhSbWuAssXiV3+/btAwCMGTPG45x8bM+ePV0+xuXLl2Gz2RAXF4eoKM8tjHQ6HQBnIimrrKwEAKSkpHTa/ujRozCbza7jt9xyCwDg66+/dmvf1NSEEydOIDU1FWlpaV3GSkTuOO+OKDRxMUVg8Sq5k+fFZWRkeJxLSUlBeHg4Tp8+jcbGzv/jT0pKglqtRl1dHRoaGjzOX7x4EYBzXp4sNTUVQFuS11H7q6957LHHMG3aNLz88svYu3cvbDYbLl26hEWLFqGhoQH//d//3d3LBQBYLBa3j84WbxCFggwWMiYKSeWtP/NcTOFbTU1NHnlIT3iV3NXU1AAAYmNjPc5JkoSYmBi3dh2Jjo7GxIkTAcBt6BUA6urq8Nlnn7m+lk2fPh0AUFxcDCGE2zXyEO/V10RERODDDz/EggULMGPGDMTGxiIlJQVHjx7Fn/70J9x9993dvFqnzMxMaLVa10dhYWGPriMKRixkTBSaXD13rHHnU4WFhW45SGZmZo+uU6TO3Zo1a6DVavHMM89g//79sNlsKC8vx8MPPwy1Wg3APYGcMGEC8vLycOzYMSxevBhVVVWwWq149913sXr1atf8v/bXfP/99xgzZgzeffdd7N69G3V1dbh06RKmTZuGO+64A2vXru1RrOXl5TCbza6P/Pz8PnwniAKLXMj4HAsZE4UMIUTbnDsOy/pUfn6+Ww4iryfojlfJXUJCAgCgvr7e45wQwjXMKrfrzMiRI3H48GFMnToVCxcuhE6nw4wZMzB27Fi8+uqrAID09HS3a9avX48NGzagtLQUI0aMwLBhw1BUVITi4mIMHDjQ45rHHnsMX3/9Nd58803ceeedCA8Px4ABA/DSSy9h0qRJWLp0Kfbv39/ta9ZoNG4fkZGR3V5DFKy4oIIo9Fyqa0Zjix2S1LbHNPlGZGSkRx7SE14VqxkxYgQAoKKiwuNcVVUVWlpakJWVhejo7sfkhwwZgk2bNnkcX716NQBg9OjRbsclSUJeXh7y8vI8rqmoqEB6erprcUV9fT0OHDiA8PBw3HHHHR7tJ0+ejOLiYnzwwQeuIWIi6p68oOKCxQqb3YEwNTe5IQp28rZjOk0UIsPUCkdDPeHV/8yTJ08GgA53kZCPTZky5ZoC+vLLLxEWFtbjOXFlZWWwWCy4//77XccaGho85ua1J0kSALitriWi7qXERSJcLcHuELhYy8VFRKGA8+0Cj1fJXW5uLrKzs7Fz506PxGjbtm1QqVQwGo2uY0KIDseHt2/fjlmzZnkcr6iowEcffYQnn3zStUJWNm3aNLfFE7I33ngDcXFxeO6551zHUlJSMGTIELS0tOCvf/2rxzV//vOfAQC33357N6+YiNpTqSSkazk0SxRK5Pl2g5K4UjZQeJXcSZKEzZs3QwiBBQsWwGw2QwiBLVu2oKioCMuXL8eoUaNc7ZcsWYLBgwdj6dKlbo9TXV2NHTt2YM2aNa5tw0pLSzFjxgyMGzeuwxWp33zzDZYtW4YTJ04AcA69rlq1Chs2bEBRUZHHCpLf/OY3UKvVePzxx3H48GEAQGNjI1555RVs374dOTk5WLBggTcvn4jQNueGK2aJQsPZ1mHZQey5CxheT5jJyclBSUkJJEnC8OHDkZqaitdffx1bt27Fiy++6NY2MzMTMTExHolXTk4OHnjgAaxduxYDBgzAoEGDsGjRIjz++OPYvXu3q6RKe4899hhiY2MxduxYpKWl4aabbsLXX3+Nw4cPd9gLOHPmTPz1r3/FLbfcgh//+MdISEhAWloafve736GgoAAHDhzosIgyEXWNiyqIQkv5Fe5OEWgk0dXktBBmsVig1WphNpt7vDqFKBT81x+/wdr//R6P3D4YK+6+WelwiKif/fCV/Th9uQFv/+vtuH3IAKXDCWk9zU241I2IvOLqueMuFURBz+4QrikYrHEXOJjcEZFX2napYCFjomB3wWJFi10gXC1Bp+FUpkDB5I6IvNK2SwV77oiCnVwGZWBCNNQqSeFoqKeY3BGRVwa2lkKpbbLB3NiicDRE1J9Y4y4wMbkjIq9ER6iRFBsBgL13RMHOVeOOK2UDCpO7bhgMBuj1ephMJqVDIfIbGQkcmiUKBfLWY1xMoSyTyQS9Xg+DwdCj9l7tLRuKSkpKWAqF6CoDE6JwtMLMWndEQe7sFfbc+QOj0Qij0egqhdId9twRkddYyJgoNLDnLjAxuSMir2WwHApR0Guy2XHB4vwZ54KKwMLkjoi8luEqZNygcCRE1F/O1VghBBAdrkZyXITS4ZAXmNwRkddYyJgo+MllUAYlRkOSWOMukDC5IyKvyYWMK2utaLE7FI6GiPqDPN+OiykCD5M7IvLagNgIRISpIARwwczeO6JgJNe442KKwMPkjoi8JklS27w7rpglCkrcnSJwMbkjol5hIWOi4Fbu6rnjsGygYXJHRL0yMCEKAFBRzeSOKBiddS2oYM9doGFyR0S94loxa2ZyRxRsGpptuFzfDIDDsoGIyR0R9UrbnDsuqCAKNvJ0i/jIMGhjwhWOhrzF5I6IeoWFjImCl/xHm9xDT4GFyV03DAYD9Ho9TCaT0qEQ+ZX2hYyFEApHQ0R9SZ5Lm8Ead37BZDJBr9fDYDD0qH1YP8cT8EpKSqDRaJQOg8jvpLcuqGhssaOmoQWJsdyeiChYyMOy8sIpUpbRaITRaITFYoFWq+22PXvuiKhXIsPa9ps8z0LGREFFrl+ZkcDFFIGIyR0R9ZpO6/yr/oKFK2aJgkkFe+4CGpM7Iuo1ncY5H4c9d0TBRZ5zx31lAxOTOyLqNfmveu4vSxQ87A6BCxaulg1kTO6IqNfkYdlzrHVHFDQqLVbYHQJhKgmp8RyWDURM7oio19I5544o6MgrZXXaKKhVksLRUG8wuSOiXuOcO6Lg07ZSlkOygYrJHRH1mqvnzsxCxkTBgsld4GNyR0S9Js+5a2i2w2K1KRwNEfUF7k4R+JjcEVGvRYWrkdi6qThXzBIFh7bdKZjcBSomd0R0TXRaed4dF1UQBQMOywY+JndEdE0Gtg7NclEFUeATQriGZdlzF7iY3HXDYDBAr9fDZDIpHQqRX9IxuSMKGpZGG+qb7QDYc+dPTCYT9Ho9DAZDj9qH9XM8Aa+kpAQajUbpMIj8VtuKWQ7LEgU6eUg2KTYC0RFqhaMhmdFohNFohMVigVar7bY9e+6I6Jq0zbljzx1RoON8u+DA5I6Irkn7WndEFNjaVspy27FAxuSOiK6JjskdUdBo67mLUTgSuhZM7ojomug0zuSutsmGWmuLwtEQ0bWoYM9dUGByR0TXJDYyDJoo59os9t4RBTa5DMog7k4R0JjcEdE1k+thcVEFUWDj7hTBoVfJXVlZGebMmQOdTofU1FQYDAYUFRV59RiVlZVYsmQJhg4diqSkJCQnJ2P27Nk4dOhQp9e8//77mDRpEpKSkpCYmAi9Xo+VK1eiqamp02vOnTuHxYsXY/jw4dDpdEhOTsaYMWOwZMkSr+Ilos5x3h1R4Guy2XGx1vn7lKtlA5vXyV1paSluu+022O12lJWVobKyEkajEfPnz0dBQUGPHuPkyZPIycnBjh078Pbbb+PKlSs4fvw4AGD8+PHYu3evxzX5+fm47777YDAYcObMGVy6dAkrV65EYWEhZs2aBbvd7nHNwYMHcdNNNyEpKQklJSW4cOECjh49Cq1Wi9dee83bl05EnUhnIWOigCf/cRYVrkJSbITC0dA1EV5wOBwiOztbxMfHi5qaGrdz8+bNEyqVSpSWlnb7ODNnzhQAxPbt292Om81modVqRWZmprBara7jBw8eFABETk6Ox2MVFBQIAMJkMrkdt1gsYtCgQWLhwoUe1xw5ckSMGTOmyxjNZrMAIMxmc7evhyjUrdnzrcj6+cfi3947onQoRNRLn31fJbJ+/rGY+Op+pUOhTvQ0N/Gq5+7AgQM4cuQIpk+f7lEhee7cuXA4HN1u02W1WrFr1y4AwNSpU93OaTQa5Obmory8HJ988onr+AcffNBhewCYOXMmAGDdunVuxzdu3IizZ8/iqaee8rjmlltuwcGDB7uMk4h6jj13RIFPXkzBIdnA51Vyt2/fPgDAmDFjPM7Jx/bs2dPlY1y+fBk2mw1xcXGIivJcaq3T6QA4E0lZZWUlACAlJaXT9kePHoXZbHYdf+eddxAdHY3s7Owu4yGia8c5d0SB71yN8+eXyV3g8yq5k+fFZWRkeJxLSUlBeHg4Tp8+jcbGzveYTEpKglqtRl1dHRoaGjzOX7x4EYBzXp4sNTUVQFuS11H79tc4HA787W9/Q3p6Oo4ePYoHH3wQgwcPRnJyMsaOHYvf/OY3Hc7R64jFYnH76GrxBlGoknvu5JV2RBR4Kmqcv5OZ3PmPpqYmjzykJ7xK7mpqagAAsbGxHuckSUJMTIxbu45ER0dj4sSJAOA29AoAdXV1+Oyzz1xfy6ZPnw4AKC4uhhDC7Rp5iLf9NdXV1WhsbERVVRUmT56MWbNmoaysDN9++y2mTZuGp59+Gvfccw8cDke3rzkzMxNardb1UVhY2O01RKFG7rmzWG2ob7IpHA0R9Ybcc8cyKP6jsLDQLQfJzMzs0XWK1Llbs2YNtFotnnnmGezfvx82mw3l5eV4+OGHoVarAbgnkBMmTEBeXh6OHTuGxYsXo6qqClarFe+++y5Wr17tmv8nXyP3HNbW1uInP/kJHn74YcTExCApKQm/+tWvMGXKFOzYsQPvvPNOt7GWl5fDbDa7PvLz8/v67SAKePFR4YiPbC1kbOHQLFEgcm09xgLGfiM/P98tBykvL+/RdV4ldwkJCQCA+vp6j3NCCNcwq9yuMyNHjsThw4cxdepULFy4EDqdDjNmzMDYsWPx6quvAgDS09Pdrlm/fj02bNiA0tJSjBgxAsOGDUNRURGKi4sxcOBAt2vaJ4bTpk3zeP5Zs2YBAD7++ONuX7NGo3H7iIyM7PYaolDEeXdEgUsI0W5fWSZ3/iIyMtIjD+mJMG+eZMSIEQCAiooKj3NVVVVoaWlBVlYWoqO7/4cxZMgQbNq0yeP46tWrAQCjR492Oy5JEvLy8pCXl+dxTUVFBdLT012LKxITE6HVamE2m5GcnOzRXm7X0Rw+IuodnTYK312s44pZogB0qa4ZzTYHJKntDzUKXF713E2ePBkAOtxFQj42ZcqUawroyy+/RFhYGO6+++4etS8rK4PFYsH999/vdjw3NxcAcOHCBY9r5EUYaWlp1xQrEbVJd/XccVEFUaCRF0OlxUchXM2dSQOdV3cwNzcX2dnZ2Llzp1vZEQDYtm0bVCoVjEaj65gQosPx4e3bt7uGRturqKjARx99hCeffNK1QlY2bdo0t8UTsjfeeANxcXF47rnn3I4vWrQIQMdDr8XFxQCAe+65p7OXSkRe0mm5vyxRoOJ8u+DiVXInSRI2b94MIQQWLFgAs9kMIQS2bNmCoqIiLF++HKNGjXK1X7JkCQYPHoylS5e6PU51dTV27NiBNWvWuEqSlJaWYsaMGRg3blyHK1K/+eYbLFu2DCdOnADgnPe3atUqbNiwAUVFRR4rSGbMmIEFCxbAZDJh27ZtsNlsaGxsxCuvvIKPP/4Yc+fOZXJH1IdYyJgocMk9d1wpGxy8mnMHADk5OSgpKcEvfvELDB8+HA6HA1lZWdi6dSseeeQRt7aZmZmIiYnxSLxycnLwwAMPYO3atSgoKEBcXBwyMjLw+OOP44knnkBYmGdYjz32GHbu3ImxY8dCpVIhJiYGd9xxBw4fPuyaC3i1jRs3wmAw4Ne//jWefPJJCCFw4403Yv369cjLy4MkSd6+fCLqhI7JHVHAOsvdKYKKJK4uHEcAnMWL5UUZPV2dQhTKyi5Y8KM1B5AYE47SX3puFUhE/utf/99B/PHrSvzH7JGYN+46pcOhTvQ0N+GsSSLqE+ka51/81Q0tsLb0bAcYIvIPnHMXXJjcEVGf0ESHISbCWYScte6IAgvn3AUXJndE1CckSeK8O6IA1NBsQ3VDCwDOuQsWTO6IqM+4at1ZWOuOKFDIvXbxUWGIjwpXOBrqC0zuiKjP6DSsdUcUaLhSNvgwueuGwWCAXq+HyWRSOhQiv+eqdVfD5I4oUJxr/Xllcue/TCYT9Ho9DAZDj9p7Xecu1JSUlLAUClEPcc4dUeCpqGkAwJWy/sxoNMJoNLpKoXSHPXdE1Gc4544o8FRUc6VssGFyR0R9Ru65YykUosDBYdngw+SOiPrMQK3zl8OlumY02VjImCgQsIBx8GFyR0R9JiEmHJFhzv9WKs1NCkdDRN2x2R24YGHPXbBhckdEfUaSpLYVs2bOuyPyd5W1TbA7BMLVElLiIpUOh/oIkzsi6lOueXcWzrsj8nfyYop0bTRUKknhaKivMLkjoj4lz7s7x1p3RH5P3p2CQ7LBhckdEfWpthWzHJYl8ndcTBGcmNwRUZ9Kb+0BOMdyKER+7yxr3AUlJndE1KfSNax1RxQo5GHZQUzuggqTOyLqU+kJXC1LFCjkYVn23AUXJndE1KfSWciYKCAIIdoWVHDOXVBhctcNg8EAvV4Pk8mkdChEASGRhYyJAkJNQwsamp1/gMn1Kck/mUwm6PV6GAyGHrUP6+d4Al5JSQk0Go3SYRAFDLmQ8anLDThvbsTgATFKh0REHZCHZJPjIhEVrlY4GuqK0WiE0WiExWKBVqvttj177oioz8lDs+e5qILIb7EMSvBickdEfa5tCzImd0T+St6dIiOBQ7LBhskdEfU5rpgl8n8V3J0iaDG5I6I+p+OwLJHfO8cyKEGLyR0R9bmBWvbcEfk79twFLyZ3RNTn2vaXZc8dkb9ijbvgxeSOiPrcQBYyJvJr1hY7LtU1A2DPXTBickdEfS6BhYyJ/Jo8JBsboYY2OlzhaKivMbkjoj4nSZJrkvY5zrsj8jvtF1NIkqRwNNTXmNwRUb/QaTjvjshfuWrccb5dUGJyR0T9Qq51x547Iv/DMijBjckdEfWLdK6YJfJbZ1kGJagxueuGwWCAXq+HyWRSOhSigCLvL3uuhskdkb+Rh2UHcVg2IJhMJuj1ehgMhh61D+vneAJeSUkJNBqN0mEQBRxXz52Fw7JE/kaeLsFh2cBgNBphNBphsVig1Wq7bc+eOyLqF3LP3Xn23BH5FbtDuH4uOSwbnJjcEVG/kHvuLtc3w9rCQsZE/qKqtgk2h4BaJSE1PlLpcKgfMLkjon6REBOOqPDWQsYW9t4R+YuKmgYAznJFYWqmAcGId5WI+oUkSW1Ds1wxS+Q3zrLGXdBjckdE/UYemj3PWndEfuMc59sFPSZ3RNRvdK7kjj13RP5CHpZlche8epXclZWVYc6cOdDpdEhNTYXBYEBRUZFXj1FZWYklS5Zg6NChSEpKQnJyMmbPno1Dhw51es3777+PSZMmISkpCYmJidDr9Vi5ciWamrrfmLympgaZmZmQJAl/+tOfvIqViHpnIFfMEvkducYdy6AEL6+Tu9LSUtx2222w2+0oKytDZWUljEYj5s+fj4KCgh49xsmTJ5GTk4MdO3bg7bffxpUrV3D8+HEAwPjx47F3716Pa/Lz83HffffBYDDgzJkzuHTpElauXInCwkLMmjULdnvXq/EWL16Ms2fPevtyiegasOeOyP+4hmU55y5oeZXcCSGwYMECAMCWLVuQkJAASZLw6KOP4uGHH8Z//Md/4G9/+1u3j7NkyRKcP38ev/nNb1zVllNSUvDWW28hOjoaCxcudOuNO3ToEF5++WXk5ORg1apViIuLg1qtxt13343nnnsOf/zjH/Hf//3fnT7fe++9h927d+NHP/qRNy+XiK7RwAQWMibyJ0IIVLi2HotSOBrqL14ldwcOHMCRI0cwffp0jwrJc+fOhcPh6HabLqvVil27dgEApk6d6nZOo9EgNzcX5eXl+OSTT1zHP/jggw7bA8DMmTMBAOvWrevw+SorK7Fo0SKsW7cOaWlp3bxCIupLOg2HZYn8icVqQ12TDQCHZYOZV8ndvn37AABjxozxOCcf27NnT5ePcfnyZdhsNsTFxSEqyvOvBp1OB8CZSMoqKysBOHv3Omt/9OhRmM1mj/N5eXmYNm0a7rvvvi7jIqK+J/fcsZAxkX84W+1cTJEYE46YCO5AGqy8urPyvLiMjAyPcykpKQgPD8fp06fR2NiI6OiO/yJISkqCWq1GXV0dGhoaEBMT43b+4sWLAJzz8mSpqakA2pK8jtrL14waNcr1/caNG1FaWopjx4718BV6slgsbt9HRkYiMpIVvYl6QhvtLGRsbXGg0mJF1oBYpUMiCmlyjbvMpJhuWpI/aGpqcpumdnVO0hmveu5qamoAALGxnv9BS5LkStTkdh2Jjo7GxIkTAcBt6BUA6urq8Nlnn7m+lk2fPh0AUFxcDCGE2zXyEO/V15w6dQo//elPsWnTJiQkJHTzyjqXmZkJrVbr+igsLOz1YxGFGkmS2lbMclEFkeLKrzh77jITmdwFgsLCQrccJDMzs0fXKVLnbs2aNdBqtXjmmWewf/9+2Gw2lJeX4+GHH4ZarQbgnkBOmDABeXl5OHbsGBYvXoyqqipYrVa8++67WL16tWv+n3yNw+FwLfLoaJ6eN8rLy2E2m10f+fn51/R4RKFGx0LGRH5D7rkblMT5doEgPz/fLQcpLy/v0XVeDcvKPWD19fUe54QQaGhocGvXmZEjR+Lw4cNYsWIFFi5ciNraWgwcOBAPPfQQ5syZg/nz5yM9Pd3tmvXr12Ps2LHYtGkTRowYgejoaNx6660oLi7GvHnzYDabXdesXr0aZ8+e9egZ7A2NRgONRnPNj0MUqrgFGZH/kOfcDWLPXUDo7VQwr5K7ESNGAAAqKio8zlVVVaGlpQVZWVmdzrdrb8iQIdi0aZPH8dWrVwMARo8e7XZckiTk5eUhLy/P45qKigqkp6e7Fle89957uHLlCoYOHerWTl5wce+99yIiIgJRUVE4depUt7ESUe+5tiDjilkixZVfaZ1zxxp3Qc2rYdnJkycDQIe7SMjHpkyZck0BffnllwgLC8Pdd9/do/ZlZWWwWCy4//77Xcc+//xzXLlyBRcuXHD7ePDBBwE4d7q4cOECEzsiH0hPYCFjIn8ghEB5a88dF1QEN6+Su9zcXGRnZ2Pnzp0eZUe2bdsGlUoFo9HoOiaE6HB8ePv27Zg1a5bH8YqKCnz00Ud48sknXStkZdOmTXNbPCF74403EBcXh+eee86bl0JEPpLOOXdEfqG6oQUNzc6SRNxXNrh5ldxJkoTNmze7dqowm80QQmDLli0oKirC8uXL3UqRLFmyBIMHD8bSpUvdHqe6uho7duzAmjVrXNuGlZaWYsaMGRg3blyHK1K/+eYbLFu2DCdOnADgnPe3atUqbNiwAUVFRT1eQUJEviXPubvAnjsiRckrZVPjIxEVrlY4GupPXq+WzcnJQUlJCSRJwvDhw5GamorXX38dW7duxYsvvujWNjMzEzExMR6JV05ODh544AGsXbsWAwYMwKBBg7Bo0SI8/vjj2L17t0ftOwB47LHHEBsbi7FjxyItLQ033XQTvv76axw+fLjDXsD2brnlFuh0OvzhD38A4Jxzp9Pp8NJLL3n78onIS3LPHQsZEymLQ7KhQxJXF44jAM5CgVqtFmazmatlia6BEAL6X+5GY4sdf3ruTlyXzELGREpY9+k/8HJxGe4eNRBrHspROhzqhZ7mJorUuSOi0CFJkmtRxTnOuyNSjDwsyzIowY/JHRH1O3nytlxAlYh8r9y19RgXUwQ7JndE1O8GtdbUqmByR6SYs9x6LGQwuSOifif33FXUMLkjUoLDIXC29eePw7LBj8kdEfW7DPbcESmqqq4JzTYHVFJbYXEKXkzuumEwGKDX62EymZQOhShgyT0F7LkjUoa8mCJdG41wNX/1BxqTyQS9Xg+DwdCj9l7tLRuKSkpKWAqF6BrJw7LnzY1wOARUKknhiIhCi7yYaRD3lA1IRqMRRqPRVQqlO0zfiajfpWmiEKaS0GIXuFjbpHQ4RCFH7rljAePQwOSOiPqdWiVB17pTRUVNg8LREIUe1+4UXEwREpjcEZFPsNYdkXLOssZdSGFyR0Q+Ia+YZXJH5Htyzx3LoIQGJndE5BODWOuOSBE2uwPnaqwA2HMXKpjcEZFPsNYdkTLOm62wOwTC1RLS4lnjLhQwuSMin8hIYK07IiXIUyEyEqJZhihEMLkjIp9ov7+sEELhaIhCh2ulLMughAwmd0TkE/KWR40tdlQ3tCgcDVHoOHuFiylCDZM7IvKJyDA1UuMjAXDeHZEvcXeK0MPkjoh8xrWogoWMiXyGw7Khh8kdEfkMCxkT+V75ldYCxuy5CxlM7rphMBig1+thMpmUDoUo4LGQMZFvNdnsqKyVa9yx5y5QmUwm6PV6GAyGHrUP6+d4Al5JSQk0Go3SYRAFBRYyJvKtczVWCAFEh6sxIDZC6XCol4xGI4xGIywWC7Rabbft2XNHRD7DQsZEvlXuWikbDUlijbtQweSOiHyGhYyJfIuLKUITkzsi8hm5587c2IK6JpvC0RAFP5ZBCU1M7ojIZ+Iiw5AQEw6AQ7NEviAPy2aygHFIYXJHRD6VkcBad0S+Ut76R1RmEnvuQgmTOyLyKVdyx547on5XUc2tx0IRkzsi8inWuiPyjYZmGy7VNQPgsGyoYXJHRD7l2qWCK2aJ+pX8B1R8VBi0rXNdKTQwuSMinxrEWndEPnH6snNIdjDLoIQcJndE5FOsdUfkGycv1QEArk+OVTgS8jUmd0TkU/Kcu6raJlhb7ApHQxS8Tl5y9twNYXIXcpjcEZFPJcaEIyZCDQA4b7YqHA1R8JJ77q5jchdymNx1w2AwQK/Xw2QyKR0KUVCQJInlUIh84OSlegAclg0GJpMJer0eBoOhR+3D+jmegFdSUgKNRqN0GERBJSMxGt9drGMhY6J+Ut9kQ6WlCQCTu2BgNBphNBphsVig1Wq7bc+eOyLyOfbcEfWvU5edvXaJMeFIiIlQOBryNSZ3RORzLGRM1L9OtS6m4Hy70MTkjoh8joWMifoXy6CENiZ3RORzLGRM1L9YBiW0MbkjIp+TCxlfsFhhszsUjoYo+LAMSmjrVXJXVlaGOXPmQKfTITU1FQaDAUVFRV49RmVlJZYsWYKhQ4ciKSkJycnJmD17Ng4dOtTpNe+//z4mTZqEpKQkJCYmQq/XY+XKlWhqavJoe/bsWaxYsQK33norBgwYgISEBNxwww1YvHgxzp8/7/VrJqK+kxofiXC1BLtDoLLW8+eXiK4Ny6CENq+Tu9LSUtx2222w2+0oKytDZWUljEYj5s+fj4KCgh49xsmTJ5GTk4MdO3bg7bffxpUrV3D8+HEAwPjx47F3716Pa/Lz83HffffBYDDgzJkzuHTpElauXInCwkLMmjULdrt7pXu9Xo+1a9di5cqVqKqqwpUrV/Daa69h27ZtGDVqFP7xj394+9KJqI+oVBIGyvPurrAcClFfqmloRnVDCwDgugFM7kKS8ILD4RDZ2dkiPj5e1NTUuJ2bN2+eUKlUorS0tNvHmTlzpgAgtm/f7nbcbDYLrVYrMjMzhdVqdR0/ePCgACBycnI8HqugoEAAECaTye14bGys2Lhxo0f7119/XQAQDz74YJcxms1mAUCYzeZuXw8Ree+RjV+IrJ9/LP7w1RmlQyEKKodPXxFZP/9Y3PbSHqVDoT7W09zEq567AwcO4MiRI5g+fbpHEb25c+fC4XB0u5OD1WrFrl27AABTp051O6fRaJCbm4vy8nJ88sknruMffPBBh+0BYObMmQCAdevWuR3/+c9/jh//+Mce7XNzcwEAn3/+eZdxElH/kid6n2gdPiKiviHXuGOvXejyKrnbt28fAGDMmDEe5+Rje/bs6fIxLl++DJvNhri4OERFRXmc1+l0AJyJpKyyshIAkJKS0mn7o0ePwmw2u47/+7//O1JTUz3aNzc3AwAGDBjQZZxE1L/kid6nmNwR9amTVc6fqSEpTO5ClVfJnTwvLiMjw+NcSkoKwsPDcfr0aTQ2dl7eICkpCWq1GnV1dWho8Jxrc/HiRQDOeXkyOUmTk7yO2l99TWfkHru5c+d225aI+o880fskkzuiPnXysvN3KxdThC6vkruamhoAQGys5z8YSZIQExPj1q4j0dHRmDhxIgC4Db0CQF1dHT777DPX17Lp06cDAIqLiyGEcLtGHuK9+pqOWK1WmEwm3HjjjVi8eHGXbWUWi8Xto6OVuUTkPfkXz6nL9XA4RDetiainXGVQOCwb8JqamjzykJ5QpM7dmjVroNVq8cwzz2D//v2w2WwoLy/Hww8/DLVaDcA9gZwwYQLy8vJw7NgxLF68GFVVVbBarXj33XexevVq1/y/jpLO9pYtW4aqqiq88847rkS0O5mZmdBqta6PwsLCXr5qImovIyEa4WoJTTYHzlusSodDFBSEEByWDSKFhYVuOUhmZmaPrvMquUtISAAA1Nd7DqMIIVzDrHK7zowcORKHDx/G1KlTsXDhQuh0OsyYMQNjx47Fq6++CgBIT093u2b9+vXYsGEDSktLMWLECAwbNgxFRUUoLi7GwIEDO7ymvVWrVmHz5s3YuXMnbrrppp6+ZJSXl8NsNrs+8vPze3wtEXUuTK1CZpLzjyzOuyPqG1V1TahvtkMlwfXzRYErPz/fLQcpLy/v0XVh3jzJiBEjAAAVFRUe56qqqtDS0oKsrCxER0d3+1hDhgzBpk2bPI6vXr0aADB69Gi345IkIS8vD3l5eR7XVFRUID093bW44mqvvPIKCgsLsXv3btx+++3dxtaeRqOBRqPx6hoi6pkhybE4UVWPE5fqMeGGZKXDIQp4cq9dRmI0IsPUCkdD1yoyMhKRkZFeX+dVz93kyZMBoMNdJORjU6ZM8TqI9r788kuEhYXh7rvv7lH7srIyWCwW3H///R2eX7FiBVatWoV9+/Zh/PjxruMHDx50rZwlImXIc4LYc0fUN+QyKNcnxykcCSnJq+QuNzcX2dnZ2Llzp1vZEQDYtm0bVCoVjEaj65gQosMuxO3bt2PWrFkexysqKvDRRx/hySef9ChjMm3aNLfFE7I33ngDcXFxeO655zzOLV++HK+99hr279/vUb7FYDDg3LlzXb9gIupX16dwxSxRX5LrRl4/gEOyocyr5E6SJGzevBlCCCxYsABmsxlCCGzZsgVFRUVYvnw5Ro0a5Wq/ZMkSDB48GEuXLnV7nOrqauzYsQNr1qxxbRtWWlqKGTNmYNy4cR0uWvjmm2+wbNkynDhxAoBz3t+qVauwYcMGFBUVeUwy/NnPfoaXXnoJkyZNwnvvvYeCggK3DyJS3vXsuSPqU6e4pyzByzl3AJCTk4OSkhL84he/wPDhw+FwOJCVlYWtW7fikUcecWubmZmJmJgYj8QrJycHDzzwANauXYuCggLExcUhIyMDjz/+OJ544gmEhXmG9dhjj2Hnzp0YO3YsVCoVYmJicMcdd+Dw4cOuuYCympoa18KMt99+29uXSEQ+IvfcnbnSAJvdgTC1Igv4iYKG3At+HZO7kCaJqwvHEQBnfTutVguz2cwFFUT9xOEQ0L+wC9YWB/703J38hUR0DRwOgRt/uQvNNgf+/LOJGMyh2aDT09yEfyYTkWJUKsm1qILz7oiuzTlzI5ptDoSrJQxM8Nzek0IHkzsiUhS3ISPqG/LP0OCkGE5xCHG8+0SkKCZ3RH2jbTEFy6CEOiZ3RKSo69rtMUtEvecqg5LMuXahjskdESlqSGtyd6KKyR3RtWDPHcmY3HXDYDBAr9fDZDIpHQpRUJJ77s6ZG2FtsSscDVHgaiuDwp67YGMymaDX62EwGHrU3us6d6GmpKSEpVCI+tGA2AjER4Wh1mrDmSsNGJ4Wr3RIRAGnxe5AeXUjAGAIe+6CjtFohNFodJVC6Q577ohIUZIkcVEF0TUqv9IAu0MgOlyNNI33G81TcGFyR0SKY3JHdG3+UdW2M4UkSQpHQ0pjckdEinMVMuaiCqJe+b9zZgDAiHROayAmd0TkB4a07jF7kuVQiHrl/85ZAAAjB3Y/H4uCH5M7IlIctyAjujZfu5I7LgAkJndE5AfkcihVtU2oa7IpHA1RYKmub0ZFjXOlrJ7JHYHJHRH5AW10OAbERgBoK8RKRD3z9Xlnr93gpBhoosIVjob8AZM7IvILXDFL1DvyYgoOyZKMyR0R+YXrmNwR9cr/cb4dXYXJHRH5BbnnjsOyRN7hSlm6GpM7IvILcnJ3gskdUY81NttxoqoOAHvuqA2TOyLyC66eO9a6I+qx4xcscAggOS4SqZoopcMhP8HkrhsGgwF6vR4mk0npUIiCmlzrrqahBdX1zQpHQxQYON8uNJhMJuj1ehgMhh61D+vneAJeSUkJNBr+0BD1t+gINdK1UThvtuLk5XoktpZGIaLOfc2VsiHBaDTCaDTCYrFAq+1+biV77ojIbwxNiQMAHG+t20VEXeNiCuoIkzsi8hujMhMAAIdP1ygaB1EgaLE7UHahFgB3piB3TO6IyG+MyUoEAJSeqVY4EiL/d6KqHs02B+Iiw5CVFKN0OORHmNwRkd/IGZwAwFkOhYsqiLom70wxIj0eKpWkcDTkT5jcEZHfSIiJwJAU56rZ0nL23hF1hfPtqDNM7ojIr4we7ByaPXSayR1RV+SeO863o6sxuSMivyInd1xUQdQ5IQS+Zo076gSTOyLyK6OzEgAAR87WwGZ3KBsMkZ86W90Ii9WGcLWEYanxSodDfobJHRH5lWGp8YiPDENDsx3fVNYqHQ6RX5KHZIenxSMijL/KyR3/RRCRX1GrJIxqXTV7+EyNorEQ+StuO0ZdYXJHRH4nxzXvjosqiDrClbLUFSZ3ROR3Rrt67pjcEXXk/7inLHWByV03DAYD9Ho9TCaT0qEQhYycTGfP3enLDbhU16RwNET+5VJdEyotTZAkYEQ6k7tQYDKZoNfrYTAYetQ+rJ/jCXglJSXQaPjDQ+RL2phw3JAah+8v1qH0TA2m6NOUDonIb/z9bA0A4PoBsYiN5K/xUGA0GmE0GmGxWKDVdj8Uz547IvJLY+R5dxyaJXKz7atyAMD4GwYoHAn5KyZ3ROSX5Hp3XFRB1ObkpXrsPV4JAHh0/PUKR0P+iskdEfkleaeKI2dr0MJixkQAgE1/OQkhgEk3puKG1DilwyE/xeSOiPzS0JQ4aKLCYG1xoOw8ixkTVdc3451DziHZvFz22lHnmNwRkV9SqSSM4rw7IpeiL0/D2uLAyIEajBvC+XbUOSZ3ROS3WO+OyKnJZsfWv54G4Oy1kyRJ4YjIn/UquSsrK8OcOXOg0+mQmpoKg8GAoqIirx6jsrISS5YswdChQ5GUlITk5GTMnj0bhw4d6vSa999/H5MmTUJSUhISExOh1+uxcuVKNDV1XgfrrbfegsFgQGpqKnQ6He6//358++23XsVKRMoYk8WeOyIA+Ohv51BV2wSdJgozbxmodDjk57xO7kpLS3HbbbfBbrejrKwMlZWVMBqNmD9/PgoKCnr0GCdPnkROTg527NiBt99+G1euXMHx48cBAOPHj8fevXs9rsnPz8d9990Hg8GAM2fO4NKlS1i5ciUKCwsxa9Ys2O12j2uWL1+ORx99FEajEZWVlSgrK4PNZoPBYMDf//53b186EfnYqMwESBJQfqURF2utSodDpAghBN78y0kAwKMTrkO4moNu1A3hBYfDIbKzs0V8fLyoqalxOzdv3jyhUqlEaWlpt48zc+ZMAUBs377d7bjZbBZarVZkZmYKq9XqOn7w4EEBQOTk5Hg8VkFBgQAgTCaT2/GDBw8KSZLE/Pnz3Y7X1NSI+Ph4MWbMGOFwODqN0Ww2CwDCbDZ3+3qIqP9M/a9PRdbPPxbz3/xSHD1b0/0FREHmz99eFFk//1iM+PdiUVPfrHQ4pKCe5iZepf8HDhzAkSNHMH36dI8KyXPnzoXD4eh2my6r1Ypdu3YBAKZOnep2TqPRIDc3F+Xl5fjkk09cxz/44IMO2wPAzJkzAQDr1q1zO24ymSCEwNy5c92Oa7Va3HXXXTh06BA+//zzLmMlIuU99k/XQ5KAT7+twszX/oLHtpTgSHmN0mER+cyGA85euwduzYQ2JlzhaCgQeLVvyb59+wAAY8aM8TgnH9uzZ0+Xj3H58mXYbDbExcUhKirK47xOpwPgTCTvvfdeAM75eQCQkpLSafujR4/CbDa7ks7uYv2f//kf7NmzBxMmTOgyXiJS1gOGTIzOSsDr//s9PjpyDvvKLmJf2UVMuGEAhqXGIyEmHAnR4UiIiYA2OhxxUWGIjQhDfFQYYiPDEBupRoRaxQno5DccDoHGFjsamu2otbagrsmGWqv80YLqhmZcrm/GlTrn5z9/WwWVBCycwPIn1DNeJXfyvLiMjAyPcykpKQgPD8fp06fR2NiI6OjoDh8jKSkJarUadXV1aGhoQExMjNv5ixcvAnDOy5OlpqYCaEvyOmovXzNq1Cg0NDTgzJkziIiI6DAhlOMvKyvr8vUCgMVicfs+MjISkZGR3V5HRH3nhtR4rHkoB09NHgbT/u/xYWkFPvv+Mj77/nKPrlerJESHqxEdoXZ+DlcjKlyFyDA1Itt/VqsQrlYhIqztI1ytQoRaQpja/eswlYQwtYQwlQrhrZ/VaglhKglqVev3KkCtcrZVSc72KkmCSnLGpJIk12eVClBL8tfONqrW7yXX13B9H0rJqhACQgAOIeBo/dz2vYDD4fzafvX3DnHVZ8DucH5vczjgEAI2u/y983OL3eH87BCw2R2w2QVaHK2f7Q60uD470Gx3oMUm0Gy3o6nF+X2zzflhtdlhbXHA2mJv/XC0JnQ2WFu8L8o9/eZ0DB4Q031DCipNTU1ui0avzkk641VyV1NTAwCIjY31OCdJEmJiYmA2m1FTU9NpchcdHY2JEydi7969+OSTT3D//fe7ztXV1eGzzz5zfS2bPn06Vq5cieLiYqxatcrtPzV5iLf9NXKcVyeOMjn+6uruV+BlZma6ff/CCy/0eOEIEfWtoSlx+K8HRmHJpGHYe7wSV+qbUdPYAnNDC8yNLahpbEZ9kx21Vhvqm2xobHEutLI7BOqabKhrsin8CvqWW7IHOelr9zWc/zdLAND++9b/QuXv276WH9kzcbw6lxTC7Tu3YwLOhKzta/ka4Wwp2trI5x3tzjlcx53JXDCLjwxDXJSzpzkuMgzxUeFIio1AYkwEBsRFICk2AslxkZjAfWRDUmFhIV588UWvr/Mquesra9aswYQJE/DMM88gOTkZubm5OH/+PBYvXgy1Wg3APYGcMGEC8vLysHHjRixevBgFBQWIj4/Hxx9/jNWrV0Or1cJsNneYdF6r8vJyaDQa1/fstSNS3nXJscjLHdJtO7tDoL7ZhsZmu/OjdSissdmOJpsdTTaH83NrD0v7npem1q876rFpsTt7fuRzcq9PWw+Q85y9tWfIIYRbG4fDeU7uUWrfG+UN+TqnIM+CesjV49na+6lu/Vqtklxfy72r6nbH3XtjncfDXcfaemfb9+aGq1UID1MhorW3NzKs7XNUuBqRYSpEhqsRFebsKY6JCENMhLMHOSbCeVylCp0eWPJefn4+nn32Wdf3FovFo9OpI14ldwkJCQCA+vp6j3NCCDQ0NLi168zIkSNx+PBhrFixAgsXLkRtbS0GDhyIhx56CHPmzMH8+fORnp7uds369esxduxYbNq0CSNGjEB0dDRuvfVWFBcXY968eTCbza5r5OeX47maHH9iYmK3r1mj0bgld0QUONQqCZqocGiiAmMSumiX6NkdVw09CudcrfY9Wq7PcLYVcLZxPpZ7D1hbD1rbeVda2C4vFB0kiZ0lnR2NDLf2E7p6DtvaefYmtu9llNu1H4qW4NypRELbcbiGtOE2ZK0OweFqCn69nQrmVXI3YsQIAEBFRYXHuaqqKrS0tCArK6vTIdn2hgwZgk2bNnkcX716NQBg9OjRbsclSUJeXh7y8vI8rqmoqEB6erprcUVMTAwGDx6MM2fOoKqqymPenRz/jTfe2G2cRES+IkkS1BKghoRwtdLREFGg8qoUyuTJkwGgw10k5GNTpky5poC+/PJLhIWF4e677+5R+7KyMlgsFre5e76KlYiIiMjfeJXc5ebmIjs7Gzt37oTZbHY7t23bNqhUKhiNRtcxIQTKy8s9Hmf79u2YNWuWx/GKigp89NFHePLJJ10rZGXTpk1zWzwhe+ONNxAXF4fnnnvO7bjRaIQkSdi2bZvbcbPZjOLiYowePRrjx4/v/kUTERERBRCvkjtJkrB582YIIbBgwQKYzWYIIbBlyxYUFRVh+fLlGDVqlKv9kiVLMHjwYCxdutTtcaqrq7Fjxw6sWbPGtW1YaWkpZsyYgXHjxqGwsNDjub/55hssW7YMJ06cAOCcN7dq1Sps2LABRUVFHhMMx4wZg+effx6/+93vsHXrVgghYDab8eijjwIANm3axLkZREREFHS83qAuJycHJSUlkCQJw4cPR2pqKl5//XVs3brVY7luZmYmYmJiPBKvnJwcPPDAA1i7di0GDBiAQYMGYdGiRXj88cexe/fuDkuYPPbYY4iNjcXYsWORlpaGm266CV9//TUOHz7cYS8gAKxYsQKbN2/G2rVrkZaWhuHDh0OtVqOkpATZ2dnevnQiIiIivycJ4e3i+9BgsVhcJVa4WpaIiIiU1tPcxOueOyIiIiLyX0zuFNTU1ISCggK3rUVIWbwn/of3xD/xvvgf3hP/o9Q94bBsJ3wxLMuhX//De+J/eE/8E++L/+E98T99fU84LEsuJpMpaJ7HV6+lv/Ge+Kdgeb94T0LzOXwlmN6vYLov7TG5CwHB9EMSLD+IvCf+KVjeL96T0HwOXwmm9yuY7kt7Xm0/Fkrk0erRo0dDrVbj8ccfx7/+67/26XNYLBa3z/3Fbrf3+3P46nn6+zl4T/zvOXx1T4DgeL989RzB9LMSLM/Be+J/z9NX92T9+vXYsGGDqzZwdzPqOOeuE2fPnvWoz0dERESktPLycgwaNKjT80zuOuFwOHDu3DnEx8dzJwsiIiJSnBACtbW1GDhwIFSqzmfWMbkjIiIiCiJcUEFEREQURJjcEREREQURJndEREREQYTJnQLKysowZ84c6HQ6pKamwmAwoKioSOmwglpTUxP+8Ic/YObMmdDpdBgwYABSUlIwY8YM7N27t8NrrFYrXnjhBQwbNgypqanIysrC008/DbPZ7OPoQ8vixYshSRIeffTRDs/zvvQ/u92ON954A+PGjcPgwYORkJCAoUOH4qGHHsKRI0fc2vJ++IbdbsfWrVsxbtw4DBw4EGlpabjlllvw0ksvoa6uzqM970vfO3bsGMaPHw9JknDq1KlO2/Xmvd+5cyfuuOMOpKamIi0tDXfddRe++uqr3gcryKcOHz4s4uPjxd133y2qq6uFw+EQmzdvFiqVSrzwwgtKhxe0nnrqKQFA5OfnC4vFIoQQ4vTp0+Kf//mfBQDx2muvubVvbm4WEydOFKmpqeKrr74SQgjx7bffimHDhombb75ZmM1mn7+GULBnzx4hSZIAIP7lX/7F4zzvS/9rbGwUU6ZMEePGjRPHjh0TQgjR0tIiXn31VQFAbN682dWW98N38vLyBADxq1/9SjQ1NQmHwyE+/vhjER0dLXJyckRTU5OrLe9L32psbBTPP/+8SEpKEsnJyQKAOHnyZIdte/Peb9iwQQAQK1asEC0tLaKhoUH85Cc/EeHh4eKPf/xjr2JmcudDDodDZGdni/j4eFFTU+N2bt68eUKlUonS0lJlggtyRqNR5ObmehyvqqoS0dHRIjIyUlRXV7uO/+d//qcAIDZt2uTWft++fQKAeOaZZ/o75JBTXV0tBg0aJObNm9dpcsf70v+WLl0qBgwY4PbzILv33nvFjh07XN/zfvjG2bNnBQAxatQoj3NPP/20ACC2bdvmOsb70reeeOIJMXv2bFFeXi5++MMfdpncefvenz17VkRHR4s77rjD7XhLS4sYMmSIyMjIEA0NDV7HzOTOhz799FMBQDz44IMe53bu3CkAiLy8PAUiC347duwQu3bt6vBcTk6OACD27dvnOjZkyBChVqtFbW2tW1uHwyHS0tJEfHy8aGxs7NeYQ83DDz8sZs6cKfbv399pcsf70r8qKytFWFiYWLp0aY/a8374xhdffCEAiAceeMDjnMlkEgDEyy+/7DrG+9K3Tp065fq6u+TO2/f+xRdfFADEb3/7W4/HWrZsmQAgfve733kdM+fc+dC+ffsAAGPGjPE4Jx/bs2ePT2MKFTNnzsS0adM6PNfc3AwAGDBgAADg5MmTOHHiBH7wgx8gLi7Ora0kSRg9ejRqa2vxxRdf9G/QIeS9997D7t27sWHDhk7b8L70vw8//BA2mw233357t215P3xn+PDhiIqKwvHjxz3OycduvvlmALwv/SErK6tH7Xrz3vdXXsDkzofkH8KMjAyPcykpKQgPD8fp06fR2Njo69BC1qVLl/Ddd99Br9fjlltuAdD1fWp/vKyszDdBBrnKykosWrQIv/3tb6HT6Tptx/vS/w4dOgQA0Gq1+OUvf4mRI0ciJSUFw4YNw6JFi3DmzBlXW94P30lMTMRrr72GsrIyPP/887BYLGhubsY777yDDRs2YO7cuZg+fToA3hcl9ea97+qaa7lXTO58qKamBgAQGxvrcU6SJMTExLi1o/63du1a2Gw2rF271rXNXFf3qf3x6upqn8QY7PLy8jB16lTMmTOny3a8L/3v3LlzAIB/+Zd/wZkzZ7B3716cO3cOJpMJH374IUaPHo1vvvkGAO+Hr+Xl5eHdd9/F22+/Da1Wi7i4ODz++ONYuXIlfv/737va8b4opzfvfVfXXMu9YnJHIeuLL77Ayy+/jF/96leYPHmy0uGEpDfffBOHDx/G66+/rnQoBLhGDeLi4rBx40akp6cjPDwcU6dOxX/913/h8uXLePrpp5UNMgQJIfDEE0/gnnvuwaJFi1BdXY3a2lr8/ve/xyuvvILp06ezU4DcMLnzoYSEBABAfX29xzkhBBoaGtzaUf/5+uuvMXPmTCxZsgS/+MUv3M51dZ/aH09MTOzXGIPdqVOn8Oyzz+LNN9/s0XvJ+9L/5J6CyZMnIywszO3crFmzAAB79+6F1Wrl/fChLVu2YP369XjkkUewbNkyJCQkIDIyEtOnT8dvfvMbFBcXu5Ju3hfl9Oa97+qaa7lXTO58aMSIEQCAiooKj3NVVVVoaWlBVlYWoqOjfR1aSDl27BgmTZqEhQsX4tVXX/U439V9an/8xhtv7L8gQ8DOnTvhcDjw6KOPQqfTuT7uvfdeAMAf/vAH17Ht27fzvvjAddddBwBITk72OBcXF4fY2FjYbDZcuXKF98OHdu3aBQAdjjDIxz744AMA/P9LSb1577u65lruFZM7H5J/COVJy+3Jx6ZMmeLTmEJNaWkpJk6ciEWLFuHXv/616/ipU6dc842uv/56DBkyBN9++61H5XchBEpLSxEfH9+jFYXUuSeffBK1tbW4cOGC28f7778PAHjwwQddx2bPns374gN33HEHAODChQse5xoaGlBfX4+wsDAkJSXxfviQ/P7K84Lbk4/V1dXBbrfzviioN+99f+UFTO58KDc3F9nZ2di5c6fHNiTbtm2DSqWC0WhUKLrgV1JSgsmTJ+NnP/sZCgoK3M4VFBRg/fr1ru+NRiNsNhveeecdt3b79+/HhQsXkJeXh6ioKF+ETe3wvvSvGTNmYNCgQdizZ4+rRJCsuLgYAHDXXXe53mPeD9+Qk4FPP/3U49yf//xnAMCtt94KtVoNgPdFSd6+9wsXLkR0dDS2bdvm1t5ms+Hdd99FRkYG7rnnHu8D8boyHl2Tw4cPi7i4OHHPPfeImpoat+3HfvnLXyodXtD67LPPhEajETfeeKN44YUXPD6ys7Pdtn9rbm4Wd955p8cWMsOHD+f2Pf2sqyLGvC/9749//KOIiIgQjzzyiLh8+bJwOBzi888/F4MGDRLp6enixIkTrra8H75RXV0tfvCDHwi1Wi3WrVsnrFarcDgc4sCBA2Lw4MEiMjJSfPrpp672vC/9p7sixr1579evXy8AiJdeeknYbDbR2NgofvKTn4iwsDCxe/fuXsXJ5E4Bx48fF/fee69ITU0VycnJYsyYMeKtt95SOqygNnv2bAGgy4+r9/ZtbGwUv/zlL8WQIUNESkqKyMzMFEuXLvXYOo76xooVK0RaWppITEwUAERUVJRIS0sTN998s1s73pf+d/DgQTFr1iyRlJQkEhISxPXXXy+eeuopceHCBY+2vB++UVNTI55//nkxcuRIER8fL7RarRg0aJB4+OGHxZEjRzza8770nS+//FKkpaWJtLQ0ER4eLgCI5ORkkZaWJp599lmP9r157z/55BPxT//0TyI5OVmkpKSIadOmiS+++KLXMUtCCOF9fx8RERER+SPOuSMiIiIKIkzuiIiIiIIIkzsiIiKiIMLkjoiIiCiIMLkjIiIiCiJM7oiIiIiCCJM7IiIioiDC5I6IiIgoiDC5IyIiIgoiTO6IiIiIggiTOyIiIqIgwuSOiIiIKIj8f4jAfvW9t0F/AAAAAElFTkSuQmCC", + "text/plain": [ + "
" + ] + }, + "metadata": {}, + "output_type": "display_data" + } + ], + "source": [ + "from squishyplanet import OblateSystem\n", + "\n", + "state = {\n", + " \"times\" : jnp.linspace(-1,1,100),\n", + " \"a\" : 200.0,\n", + " \"e\" : 0.3,\n", + " \"i\" : 89.75 * jnp.pi / 180,\n", + " \"Omega\" : 95 * jnp.pi / 180,\n", + " \"omega\" : jnp.pi / 3.5,\n", + " \"period\" : 1001.0,\n", + " \"t0\" : 0.2,\n", + " \"parameterize_with_projected_ellipse\" : True,\n", + " \"projected_effective_r\" : 0.1,\n", + " \"projected_f\" : 0.3,\n", + " \"projected_theta\" : 0.2,\n", + " \"tidally_locked\" : False,\n", + " \"ld_u_coeffs\" : jnp.array([0.008, 0.007, 0.006, 0.005, 0.004, 0.003, 0.002, 0.001])\n", + "}\n", + "\n", + "p = OblateSystem(**state)\n", + "\n", + "g = p.lightcurve()\n", + "\n", + "plt.plot(g)" + ] + }, + { + "cell_type": "code", + "execution_count": 3, + "metadata": {}, + "outputs": [ + { + "name": "stdout", + "output_type": "stream", + "text": [ + "12.3 ms ± 118 μs per loop (mean ± std. dev. of 7 runs, 100 loops each)\n" + ] + } + ], + "source": [ + "%timeit p.lightcurve().block_until_ready()\n", + "# the fortran version is ~5ms" + ] + }, + { + "cell_type": "code", + "execution_count": 7, + "metadata": {}, + "outputs": [ + { + "name": "stdout", + "output_type": "stream", + "text": [ + "(100,)\n" + ] + }, + { + "data": { + "text/plain": [ + "[]" + ] + }, + "execution_count": 7, + "metadata": {}, + "output_type": "execute_result" + }, + { + "data": { + "image/png": "iVBORw0KGgoAAAANSUhEUgAAAncAAAFeCAYAAADngTkBAAAAOXRFWHRTb2Z0d2FyZQBNYXRwbG90bGliIHZlcnNpb24zLjkuMiwgaHR0cHM6Ly9tYXRwbG90bGliLm9yZy8hTgPZAAAACXBIWXMAAA9hAAAPYQGoP6dpAABRjUlEQVR4nO3deXxTZb4/8M9Jui9JW7qklFIFYSSopWBE4NYRuMAIDLjgwkvhCtYrYxDUcZhbhzvWuUhl9F4YNA4XkOXndHCuK6IUBriMw+ioBToMXKnLsJUCpUCbdEvbJM/vj/SkDemW0uZk+bxfr77anvOc5JscSr99lu8jCSEEiIiIiCgoqJQOgIiIiIj6DpM7IiIioiDC5I6IiIgoiDC5IyIiIgoiTO6IiIiIggiTOyIiIqIgwuSOiIiIKIiEKR2Av3I4HDh37hzi4+MhSZLS4RAREVGIE0KgtrYWAwcOhErVef8ck7tOnDt3DpmZmUqHQUREROSmvLwcgwYN6vQ8k7tOxMfHA3C+gRqNpl+ew2KxIDMzs1+fAwAMBgNKSkr67fF9+Tz9/Ry8J/73HL66J0BwvF++eo5g+lkJlufgPfG/5+nreyI/npyjdIbJXSfkoViNRtPvv1D6+znUanW/vwZfPY+vXgvviX89B+Cbn8Vgeb98dU+A4PhZCZbnkPGe+N/z9PU96W66GBdUhACj0Rg0z+Or19LfeE/8U7C8X7wnofkcvhJM71cw3Zf2JCGEUDoIf2SxWKDVamE2m/t1WLa/n4O8w3vif3hP/BPvi//hPfE/fX1Pevp47LlTUGRkJF544QVERkYqHQq14j3xP7wn/on3xf/wnvgfpe4Je+46wb+AiIiIyJ+w546IiIgoBF1Tcnfs2DGMHz8ekiTh1KlTvXqMt956CwaDAampqdDpdLj//vvx7bffdtq+rKwMc+bMgU6nQ2pqKgwGA4qKijptb7Va8cILL2DYsGFITU1FVlYWnn76aZjN5l7FS0REROTPepXcWa1W/OIXv8APf/hDfPfdd71+8uXLl+PRRx+F0WhEZWUlysrKYLPZYDAY8Pe//92jfWlpKW677TbY7XaUlZWhsrISRqMR8+fPR0FBgUf7lpYWTJ8+HevWrcPvf/97XLx4EXv37sXOnTuRm5sLi8XS69iJiIiI/JLohSeeeELMnj1blJeXix/+8IcCgDh58qRXj3Hw4EEhSZKYP3++2/GamhoRHx8vxowZIxwOh+u4w+EQ2dnZIj4+XtTU1LhdM2/ePKFSqURpaanb8f/8z/8UAMSmTZvcju/bt08AEM8880yn8ZnNZgFAmM1mr14XERERUX/oaW7Sq567/Px8fPjhh11ufdEdk8kEIQTmzp3rdlyr1eKuu+7CoUOH8Pnnn7uOHzhwAEeOHMH06dOh1Wrdrpk7dy4cDgdMJpPHc6jVatx///1uxydOnIi0tDRs3LgRVqu116+BiIiIyN/0KrnLysq65ifet28fAGDMmDEe5+Rje/bs6XX7kydP4sSJE/jBD36AuLg4t/aSJGH06NGora3FF198cY2vhIiIiMh/KLL9WENDA86cOYOIiAikpKR4nM/IyADgXDwhO378uNu59lJSUhAeHo7Tp0+jsbER0dHRXba/+jnuvPPOTmO9el5eZGRkn9SrqahpxN2mz675cYj6wsxb0vHCj0cqHQYRBYlf7yrDu4fOItRqrUWFq3Bg2aQ+e7ympiY0NTW5vu/pWgFFkruamhoAQExMTIfnY2NjAQDV1dUe18jn2pMkCTExMTCbzaipqUF0dHSX7Tt7jo5kZma6ff/CCy90uHjDWw6HQFVtU/cNiXxg82encNdN6bjt+iSlQyGiAPf9xVr89tN/IBSr6EaHq/v08QoLC/Hiiy96fZ0iyV0gKS8vdysU2FdVptM0UShemtsnj0V0Ld78y0m8e+gsXtp5HB8+Ob7bDamJiLryxn5nYjfxBylY9qMblQ7Hp/r6v8/8/Hw8++yzru8tFotHp1NHFEnuEhISADiHZztSX18PAEhMTPS4Rj7XnhDC9Vhyu67ad/YcHdFoNP2yQ0VEmAoj0rnzBSnv5z+6EcVHz+NIeQ0+/vt5/Dh7oNIhEVGAOnO5AduPnAMAPDNlOH/PXaPeTgVTZIeKmJgYDB48GM3NzaiqqvI4X1FRAQC48ca2jH/EiBFu59qrqqpCS0sLsrKyEB0d3W37zp6DKBSlxEdi0Q+HAgBW7SpDk82ucEREFKh+++k/YHcI3DE8BbcMSlA6nJCl2PZjkydPBgAcOnTI45x8bMqUKb1uf/3112PIkCH49ttvUVdX59ZeCIHS0lLEx8fj9ttvv8ZXQhT48nKHIE0TibPVjXjrr6eVDoeIAtB5cyPePVQOAHhq0g0KRxPa+j25E0KgvLzc47jRaIQkSdi2bZvbcbPZjOLiYowePRrjx493Hc/NzUV2djZ27tzpsXXYtm3boFKpYDQaPZ7DZrPhnXfecTu+f/9+XLhwAXl5eYiKirrWl0gU8KIj1PjplB8AAF773+9R09CscEREFGjW//kEWuwCt12fBMN1XJylpH5P7pYsWYLBgwdj6dKlbsfHjBmD559/Hr/73e+wdetWCCFgNpvx6KOPAgA2bdrkNrFbkiRs3rwZQggsWLAAZrMZQghs2bIFRUVFWL58OUaNGuX2HE899RTuvPNO/Nu//RtKSkoAAN999x1+8pOf4Oabb+6TVa9EweK+MYNwoy4e5sYWvP6/3ysdDhEFkEt1Tdj21RkA7LXzB71K7r766ivodDrodDrXLhIGgwE6nQ4//elP3dpmZmYiJiamw9UdK1aswObNm7F27VqkpaVh+PDhUKvVKCkpQXZ2tkf7nJwclJSUQJIkDB8+HKmpqXj99dexdevWDpcKh4eHo7i4GIsWLcJDDz2E1NRUTJ48GXfddRcOHDjQLwsliAKVWiXh3+5yzkH9f389jfIrHS94IiK62pt/OQlriwPZmQn4pxuSlQ4n5ElChGIlmu5ZLBZotVqYzWYmgRQyhBCY9+ZX+Mv3l/Dj7IF4bW6O0iERkZ+raWjGhJf/F/XNdmyYfyum6NOUDilo9TQ3UWxBBRH5H0mSsOxHzrl3u46dh83uUDgiIvJ3Wz4/hfpmO27UxWPyjalKh0NgckdEV7lpoBZR4Sq02AXKqxuVDoeI/Jw818448QaoVCyC7g+Y3BGRG5VKwvXJcQCAk5fqumlNRKGsur4ZlRbnVpqTR7DXzl8wuSMiD0OSnXsvn6jqeIcXIiIA+L7K+QdgRkI0YiK4o6m/YHJHRB6GpDiTu38wuSOiLnx/0ZncDU2NUzgSao/JXTcMBgP0ej1MJpPSoRD5jJzccViWiLoiJ3fDmNz1K5PJBL1eD4PB0KP27EPtRklJCUuhUMiR59xxWJaIuiIndzcwuetXRqMRRqPRVQqlO+y5IyIPcs/dxdom1FpbFI6GiPwVkzv/xOSOiDxoosKRHBcJADh1iTtVEJGn+iYbKmqc5ZJuSGFy50+Y3BFRh1wrZjnvjog6IE/bGBAbgcTYCIWjofaY3BFRh7hiloi68n1VLQCulPVHTO6IqENtK2aZ3BGRJ863819M7oioQ20rZjksS0SeXMkd59v5HSZ3RNSh9j13QgiFoyEif8OeO//F5I6IOjQ4KQZhKgkNzXbX3pFERADQYnfg9GXnSnomd/6HyR0RdShcrcLgpBgAHJolInenL9fD5hCIjVAjXRuldDh0FSZ3RNSp61vLofyDiyqIqJ32Q7KSJCkcDV2NyR0Rdco1747lUIione8qnckdy6D4JyZ3RNSpIa2r4FjImIja+76Kiyn8GZO7bhgMBuj1ephMJqVDIfI5eVj2BHvuiKgdlkHxLZPJBL1eD4PB0KP2Yf0cT8ArKSmBRqNROgwiRcjDsmerG9BksyMyTK1wRESkNIdD4B/sufMpo9EIo9EIi8UCrVbbbXv23BFRp1LiIhEfGQaHAM60lj0gotBWUdMIa4sDEe1W1JN/YXJHRJ2SJAnXc49ZImpHnm93XXIMwtRMI/wR7woRdWmIPO+OiyqICMA/uDOF32NyR0RdklfMshwKEQFcTBEImNwRUZdcK2ZZyJiI0Jbcscad/2JyR0RdklfMcgsyIhJC4DsOy/o9JndE1CW55666oQXV9c0KR0NESrpU1wxzYwskCRjKYVm/xeSOiLoUExHm2hicQ7NEoU0eks1MjEFUOOte+ismd0TULQ7NEhHAbccCBZM7IurWkOTWFbPsuSMKaSyDEhiY3BFRt7jHLBEBLIMSKJjcEVG3XMOyLGRMFNJYBiUwMLnrhsFggF6vh8lkUjoUIsXIq+JOXW6AwyEUjoaIlNDYbMcFixUAMLT1Dz7yDZPJBL1eD4PB0KP2Yf0cT8ArKSmBRqNROgwiRaVro6BWSWi2OVBV14Q0TZTSIRGRj52tbgAAxEeGQRsdrnA0ocVoNMJoNMJisUCr1Xbbnj13RNStMLUKutaErqKmUeFoiEgJ5a3J3aCkGEiSpHA01BUmd0TUIxkJ0QCAc0zuiELS2Wrnz35mYrTCkVB3mNwRUY8MTGjtuatmckcUisqvOHvuMpNiFI6EusPkjoh6ZCB77ohCWvkV9twFCiZ3RNQjGa3/oVfUWBWOhIiU4Jpzl8ieO3/H5I6IekTuueOCCqLQxGHZwNGr5K6srAxz5syBTqdDamoqDAYDioqKvHqMyspKLFmyBEOHDkVSUhKSk5Mxe/ZsHDp0qNNr3n//fUyaNAlJSUlITEyEXq/HypUr0dTU1OlzPPvssxgxYgTS0tIwaNAgTJ48GTt37vQqViLiggqiUGZubIHFagMADOKwrN/zOrkrLS3FbbfdBrvdjrKyMlRWVsJoNGL+/PkoKCjo0WOcPHkSOTk52LFjB95++21cuXIFx48fBwCMHz8ee/fu9bgmPz8f9913HwwGA86cOYNLly5h5cqVKCwsxKxZs2C3293aX7x4EaNHj8bvf/97bNy4EZWVlfjmm28wbNgwzJgxA6+88oq3L50opMk9d+bGFtQ12RSOhoh8Se61GxAbgdhIlsj1e8ILDodDZGdni/j4eFFTU+N2bt68eUKlUonS0tJuH2fmzJkCgNi+fbvbcbPZLLRarcjMzBRWq9V1/ODBgwKAyMnJ8XisgoICAUCYTCa34y+99JIAINasWeN2vLm5WaSkpIj4+HjR3NzcaYxms1kAEGazudvXQxQqbinYLbJ+/rH45oJF6VCIyIeKj54TWT//WMx6/S9KhxLSepqbeNVzd+DAARw5cgTTp0/3qJA8d+5cOByObrfpslqt2LVrFwBg6tSpbuc0Gg1yc3NRXl6OTz75xHX8gw8+6LA9AMycORMAsG7dOrfj5eXlAIDhw4e7HQ8PD8d1112H2tpaXLlypctYicgd590RhSbWuAssXiV3+/btAwCMGTPG45x8bM+ePV0+xuXLl2Gz2RAXF4eoKM8tjHQ6HQBnIimrrKwEAKSkpHTa/ujRozCbza7jt9xyCwDg66+/dmvf1NSEEydOIDU1FWlpaV3GSkTuOO+OKDRxMUVg8Sq5k+fFZWRkeJxLSUlBeHg4Tp8+jcbGzv/jT0pKglqtRl1dHRoaGjzOX7x4EYBzXp4sNTUVQFuS11H7q6957LHHMG3aNLz88svYu3cvbDYbLl26hEWLFqGhoQH//d//3d3LBQBYLBa3j84WbxCFggwWMiYKSeWtP/NcTOFbTU1NHnlIT3iV3NXU1AAAYmNjPc5JkoSYmBi3dh2Jjo7GxIkTAcBt6BUA6urq8Nlnn7m+lk2fPh0AUFxcDCGE2zXyEO/V10RERODDDz/EggULMGPGDMTGxiIlJQVHjx7Fn/70J9x9993dvFqnzMxMaLVa10dhYWGPriMKRixkTBSaXD13rHHnU4WFhW45SGZmZo+uU6TO3Zo1a6DVavHMM89g//79sNlsKC8vx8MPPwy1Wg3APYGcMGEC8vLycOzYMSxevBhVVVWwWq149913sXr1atf8v/bXfP/99xgzZgzeffdd7N69G3V1dbh06RKmTZuGO+64A2vXru1RrOXl5TCbza6P/Pz8PnwniAKLXMj4HAsZE4UMIUTbnDsOy/pUfn6+Ww4iryfojlfJXUJCAgCgvr7e45wQwjXMKrfrzMiRI3H48GFMnToVCxcuhE6nw4wZMzB27Fi8+uqrAID09HS3a9avX48NGzagtLQUI0aMwLBhw1BUVITi4mIMHDjQ45rHHnsMX3/9Nd58803ceeedCA8Px4ABA/DSSy9h0qRJWLp0Kfbv39/ta9ZoNG4fkZGR3V5DFKy4oIIo9Fyqa0Zjix2S1LbHNPlGZGSkRx7SE14VqxkxYgQAoKKiwuNcVVUVWlpakJWVhejo7sfkhwwZgk2bNnkcX716NQBg9OjRbsclSUJeXh7y8vI8rqmoqEB6erprcUV9fT0OHDiA8PBw3HHHHR7tJ0+ejOLiYnzwwQeuIWIi6p68oOKCxQqb3YEwNTe5IQp28rZjOk0UIsPUCkdDPeHV/8yTJ08GgA53kZCPTZky5ZoC+vLLLxEWFtbjOXFlZWWwWCy4//77XccaGho85ua1J0kSALitriWi7qXERSJcLcHuELhYy8VFRKGA8+0Cj1fJXW5uLrKzs7Fz506PxGjbtm1QqVQwGo2uY0KIDseHt2/fjlmzZnkcr6iowEcffYQnn3zStUJWNm3aNLfFE7I33ngDcXFxeO6551zHUlJSMGTIELS0tOCvf/2rxzV//vOfAQC33357N6+YiNpTqSSkazk0SxRK5Pl2g5K4UjZQeJXcSZKEzZs3QwiBBQsWwGw2QwiBLVu2oKioCMuXL8eoUaNc7ZcsWYLBgwdj6dKlbo9TXV2NHTt2YM2aNa5tw0pLSzFjxgyMGzeuwxWp33zzDZYtW4YTJ04AcA69rlq1Chs2bEBRUZHHCpLf/OY3UKvVePzxx3H48GEAQGNjI1555RVs374dOTk5WLBggTcvn4jQNueGK2aJQsPZ1mHZQey5CxheT5jJyclBSUkJJEnC8OHDkZqaitdffx1bt27Fiy++6NY2MzMTMTExHolXTk4OHnjgAaxduxYDBgzAoEGDsGjRIjz++OPYvXu3q6RKe4899hhiY2MxduxYpKWl4aabbsLXX3+Nw4cPd9gLOHPmTPz1r3/FLbfcgh//+MdISEhAWloafve736GgoAAHDhzosIgyEXWNiyqIQkv5Fe5OEWgk0dXktBBmsVig1WphNpt7vDqFKBT81x+/wdr//R6P3D4YK+6+WelwiKif/fCV/Th9uQFv/+vtuH3IAKXDCWk9zU241I2IvOLqueMuFURBz+4QrikYrHEXOJjcEZFX2napYCFjomB3wWJFi10gXC1Bp+FUpkDB5I6IvNK2SwV77oiCnVwGZWBCNNQqSeFoqKeY3BGRVwa2lkKpbbLB3NiicDRE1J9Y4y4wMbkjIq9ER6iRFBsBgL13RMHOVeOOK2UDCpO7bhgMBuj1ephMJqVDIfIbGQkcmiUKBfLWY1xMoSyTyQS9Xg+DwdCj9l7tLRuKSkpKWAqF6CoDE6JwtMLMWndEQe7sFfbc+QOj0Qij0egqhdId9twRkddYyJgoNLDnLjAxuSMir2WwHApR0Guy2XHB4vwZ54KKwMLkjoi8luEqZNygcCRE1F/O1VghBBAdrkZyXITS4ZAXmNwRkddYyJgo+MllUAYlRkOSWOMukDC5IyKvyYWMK2utaLE7FI6GiPqDPN+OiykCD5M7IvLagNgIRISpIARwwczeO6JgJNe442KKwMPkjoi8JklS27w7rpglCkrcnSJwMbkjol5hIWOi4Fbu6rnjsGygYXJHRL0yMCEKAFBRzeSOKBiddS2oYM9doGFyR0S94loxa2ZyRxRsGpptuFzfDIDDsoGIyR0R9UrbnDsuqCAKNvJ0i/jIMGhjwhWOhrzF5I6IeoWFjImCl/xHm9xDT4GFyV03DAYD9Ho9TCaT0qEQ+ZX2hYyFEApHQ0R9SZ5Lm8Ead37BZDJBr9fDYDD0qH1YP8cT8EpKSqDRaJQOg8jvpLcuqGhssaOmoQWJsdyeiChYyMOy8sIpUpbRaITRaITFYoFWq+22PXvuiKhXIsPa9ps8z0LGREFFrl+ZkcDFFIGIyR0R9ZpO6/yr/oKFK2aJgkkFe+4CGpM7Iuo1ncY5H4c9d0TBRZ5zx31lAxOTOyLqNfmveu4vSxQ87A6BCxaulg1kTO6IqNfkYdlzrHVHFDQqLVbYHQJhKgmp8RyWDURM7oio19I5544o6MgrZXXaKKhVksLRUG8wuSOiXuOcO6Lg07ZSlkOygYrJHRH1mqvnzsxCxkTBgsld4GNyR0S9Js+5a2i2w2K1KRwNEfUF7k4R+JjcEVGvRYWrkdi6qThXzBIFh7bdKZjcBSomd0R0TXRaed4dF1UQBQMOywY+JndEdE0Gtg7NclEFUeATQriGZdlzF7iY3HXDYDBAr9fDZDIpHQqRX9IxuSMKGpZGG+qb7QDYc+dPTCYT9Ho9DAZDj9qH9XM8Aa+kpAQajUbpMIj8VtuKWQ7LEgU6eUg2KTYC0RFqhaMhmdFohNFohMVigVar7bY9e+6I6Jq0zbljzx1RoON8u+DA5I6Irkn7WndEFNjaVspy27FAxuSOiK6JjskdUdBo67mLUTgSuhZM7ojomug0zuSutsmGWmuLwtEQ0bWoYM9dUGByR0TXJDYyDJoo59os9t4RBTa5DMog7k4R0JjcEdE1k+thcVEFUWDj7hTBoVfJXVlZGebMmQOdTofU1FQYDAYUFRV59RiVlZVYsmQJhg4diqSkJCQnJ2P27Nk4dOhQp9e8//77mDRpEpKSkpCYmAi9Xo+VK1eiqamp02vOnTuHxYsXY/jw4dDpdEhOTsaYMWOwZMkSr+Ilos5x3h1R4Guy2XGx1vn7lKtlA5vXyV1paSluu+022O12lJWVobKyEkajEfPnz0dBQUGPHuPkyZPIycnBjh078Pbbb+PKlSs4fvw4AGD8+PHYu3evxzX5+fm47777YDAYcObMGVy6dAkrV65EYWEhZs2aBbvd7nHNwYMHcdNNNyEpKQklJSW4cOECjh49Cq1Wi9dee83bl05EnUhnIWOigCf/cRYVrkJSbITC0dA1EV5wOBwiOztbxMfHi5qaGrdz8+bNEyqVSpSWlnb7ODNnzhQAxPbt292Om81modVqRWZmprBara7jBw8eFABETk6Ox2MVFBQIAMJkMrkdt1gsYtCgQWLhwoUe1xw5ckSMGTOmyxjNZrMAIMxmc7evhyjUrdnzrcj6+cfi3947onQoRNRLn31fJbJ+/rGY+Op+pUOhTvQ0N/Gq5+7AgQM4cuQIpk+f7lEhee7cuXA4HN1u02W1WrFr1y4AwNSpU93OaTQa5Obmory8HJ988onr+AcffNBhewCYOXMmAGDdunVuxzdu3IizZ8/iqaee8rjmlltuwcGDB7uMk4h6jj13RIFPXkzBIdnA51Vyt2/fPgDAmDFjPM7Jx/bs2dPlY1y+fBk2mw1xcXGIivJcaq3T6QA4E0lZZWUlACAlJaXT9kePHoXZbHYdf+eddxAdHY3s7Owu4yGia8c5d0SB71yN8+eXyV3g8yq5k+fFZWRkeJxLSUlBeHg4Tp8+jcbGzveYTEpKglqtRl1dHRoaGjzOX7x4EYBzXp4sNTUVQFuS11H79tc4HA787W9/Q3p6Oo4ePYoHH3wQgwcPRnJyMsaOHYvf/OY3Hc7R64jFYnH76GrxBlGoknvu5JV2RBR4Kmqcv5OZ3PmPpqYmjzykJ7xK7mpqagAAsbGxHuckSUJMTIxbu45ER0dj4sSJAOA29AoAdXV1+Oyzz1xfy6ZPnw4AKC4uhhDC7Rp5iLf9NdXV1WhsbERVVRUmT56MWbNmoaysDN9++y2mTZuGp59+Gvfccw8cDke3rzkzMxNardb1UVhY2O01RKFG7rmzWG2ob7IpHA0R9Ybcc8cyKP6jsLDQLQfJzMzs0XWK1Llbs2YNtFotnnnmGezfvx82mw3l5eV4+OGHoVarAbgnkBMmTEBeXh6OHTuGxYsXo6qqClarFe+++y5Wr17tmv8nXyP3HNbW1uInP/kJHn74YcTExCApKQm/+tWvMGXKFOzYsQPvvPNOt7GWl5fDbDa7PvLz8/v67SAKePFR4YiPbC1kbOHQLFEgcm09xgLGfiM/P98tBykvL+/RdV4ldwkJCQCA+vp6j3NCCNcwq9yuMyNHjsThw4cxdepULFy4EDqdDjNmzMDYsWPx6quvAgDS09Pdrlm/fj02bNiA0tJSjBgxAsOGDUNRURGKi4sxcOBAt2vaJ4bTpk3zeP5Zs2YBAD7++ONuX7NGo3H7iIyM7PYaolDEeXdEgUsI0W5fWSZ3/iIyMtIjD+mJMG+eZMSIEQCAiooKj3NVVVVoaWlBVlYWoqO7/4cxZMgQbNq0yeP46tWrAQCjR492Oy5JEvLy8pCXl+dxTUVFBdLT012LKxITE6HVamE2m5GcnOzRXm7X0Rw+IuodnTYK312s44pZogB0qa4ZzTYHJKntDzUKXF713E2ePBkAOtxFQj42ZcqUawroyy+/RFhYGO6+++4etS8rK4PFYsH999/vdjw3NxcAcOHCBY9r5EUYaWlp1xQrEbVJd/XccVEFUaCRF0OlxUchXM2dSQOdV3cwNzcX2dnZ2Llzp1vZEQDYtm0bVCoVjEaj65gQosPx4e3bt7uGRturqKjARx99hCeffNK1QlY2bdo0t8UTsjfeeANxcXF47rnn3I4vWrQIQMdDr8XFxQCAe+65p7OXSkRe0mm5vyxRoOJ8u+DiVXInSRI2b94MIQQWLFgAs9kMIQS2bNmCoqIiLF++HKNGjXK1X7JkCQYPHoylS5e6PU51dTV27NiBNWvWuEqSlJaWYsaMGRg3blyHK1K/+eYbLFu2DCdOnADgnPe3atUqbNiwAUVFRR4rSGbMmIEFCxbAZDJh27ZtsNlsaGxsxCuvvIKPP/4Yc+fOZXJH1IdYyJgocMk9d1wpGxy8mnMHADk5OSgpKcEvfvELDB8+HA6HA1lZWdi6dSseeeQRt7aZmZmIiYnxSLxycnLwwAMPYO3atSgoKEBcXBwyMjLw+OOP44knnkBYmGdYjz32GHbu3ImxY8dCpVIhJiYGd9xxBw4fPuyaC3i1jRs3wmAw4Ne//jWefPJJCCFw4403Yv369cjLy4MkSd6+fCLqhI7JHVHAOsvdKYKKJK4uHEcAnMWL5UUZPV2dQhTKyi5Y8KM1B5AYE47SX3puFUhE/utf/99B/PHrSvzH7JGYN+46pcOhTvQ0N+GsSSLqE+ka51/81Q0tsLb0bAcYIvIPnHMXXJjcEVGf0ESHISbCWYScte6IAgvn3AUXJndE1CckSeK8O6IA1NBsQ3VDCwDOuQsWTO6IqM+4at1ZWOuOKFDIvXbxUWGIjwpXOBrqC0zuiKjP6DSsdUcUaLhSNvgwueuGwWCAXq+HyWRSOhQiv+eqdVfD5I4oUJxr/Xllcue/TCYT9Ho9DAZDj9p7Xecu1JSUlLAUClEPcc4dUeCpqGkAwJWy/sxoNMJoNLpKoXSHPXdE1Gc4544o8FRUc6VssGFyR0R9Ru65YykUosDBYdngw+SOiPrMQK3zl8OlumY02VjImCgQsIBx8GFyR0R9JiEmHJFhzv9WKs1NCkdDRN2x2R24YGHPXbBhckdEfUaSpLYVs2bOuyPyd5W1TbA7BMLVElLiIpUOh/oIkzsi6lOueXcWzrsj8nfyYop0bTRUKknhaKivMLkjoj4lz7s7x1p3RH5P3p2CQ7LBhckdEfWpthWzHJYl8ndcTBGcmNwRUZ9Kb+0BOMdyKER+7yxr3AUlJndE1KfSNax1RxQo5GHZQUzuggqTOyLqU+kJXC1LFCjkYVn23AUXJndE1KfSWciYKCAIIdoWVHDOXVBhctcNg8EAvV4Pk8mkdChEASGRhYyJAkJNQwsamp1/gMn1Kck/mUwm6PV6GAyGHrUP6+d4Al5JSQk0Go3SYRAFDLmQ8anLDThvbsTgATFKh0REHZCHZJPjIhEVrlY4GuqK0WiE0WiExWKBVqvttj177oioz8lDs+e5qILIb7EMSvBickdEfa5tCzImd0T+St6dIiOBQ7LBhskdEfU5rpgl8n8V3J0iaDG5I6I+p+OwLJHfO8cyKEGLyR0R9bmBWvbcEfk79twFLyZ3RNTn2vaXZc8dkb9ijbvgxeSOiPrcQBYyJvJr1hY7LtU1A2DPXTBickdEfS6BhYyJ/Jo8JBsboYY2OlzhaKivMbkjoj4nSZJrkvY5zrsj8jvtF1NIkqRwNNTXmNwRUb/QaTjvjshfuWrccb5dUGJyR0T9Qq51x547Iv/DMijBjckdEfWLdK6YJfJbZ1kGJagxueuGwWCAXq+HyWRSOhSigCLvL3uuhskdkb+Rh2UHcVg2IJhMJuj1ehgMhh61D+vneAJeSUkJNBqN0mEQBRxXz52Fw7JE/kaeLsFh2cBgNBphNBphsVig1Wq7bc+eOyLqF3LP3Xn23BH5FbtDuH4uOSwbnJjcEVG/kHvuLtc3w9rCQsZE/qKqtgk2h4BaJSE1PlLpcKgfMLkjon6REBOOqPDWQsYW9t4R+YuKmgYAznJFYWqmAcGId5WI+oUkSW1Ds1wxS+Q3zrLGXdBjckdE/UYemj3PWndEfuMc59sFPSZ3RNRvdK7kjj13RP5CHpZlche8epXclZWVYc6cOdDpdEhNTYXBYEBRUZFXj1FZWYklS5Zg6NChSEpKQnJyMmbPno1Dhw51es3777+PSZMmISkpCYmJidDr9Vi5ciWamrrfmLympgaZmZmQJAl/+tOfvIqViHpnIFfMEvkducYdy6AEL6+Tu9LSUtx2222w2+0oKytDZWUljEYj5s+fj4KCgh49xsmTJ5GTk4MdO3bg7bffxpUrV3D8+HEAwPjx47F3716Pa/Lz83HffffBYDDgzJkzuHTpElauXInCwkLMmjULdnvXq/EWL16Ms2fPevtyiegasOeOyP+4hmU55y5oeZXcCSGwYMECAMCWLVuQkJAASZLw6KOP4uGHH8Z//Md/4G9/+1u3j7NkyRKcP38ev/nNb1zVllNSUvDWW28hOjoaCxcudOuNO3ToEF5++WXk5ORg1apViIuLg1qtxt13343nnnsOf/zjH/Hf//3fnT7fe++9h927d+NHP/qRNy+XiK7RwAQWMibyJ0IIVLi2HotSOBrqL14ldwcOHMCRI0cwffp0jwrJc+fOhcPh6HabLqvVil27dgEApk6d6nZOo9EgNzcX5eXl+OSTT1zHP/jggw7bA8DMmTMBAOvWrevw+SorK7Fo0SKsW7cOaWlp3bxCIupLOg2HZYn8icVqQ12TDQCHZYOZV8ndvn37AABjxozxOCcf27NnT5ePcfnyZdhsNsTFxSEqyvOvBp1OB8CZSMoqKysBOHv3Omt/9OhRmM1mj/N5eXmYNm0a7rvvvi7jIqK+J/fcsZAxkX84W+1cTJEYE46YCO5AGqy8urPyvLiMjAyPcykpKQgPD8fp06fR2NiI6OiO/yJISkqCWq1GXV0dGhoaEBMT43b+4sWLAJzz8mSpqakA2pK8jtrL14waNcr1/caNG1FaWopjx4718BV6slgsbt9HRkYiMpIVvYl6QhvtLGRsbXGg0mJF1oBYpUMiCmlyjbvMpJhuWpI/aGpqcpumdnVO0hmveu5qamoAALGxnv9BS5LkStTkdh2Jjo7GxIkTAcBt6BUA6urq8Nlnn7m+lk2fPh0AUFxcDCGE2zXyEO/V15w6dQo//elPsWnTJiQkJHTzyjqXmZkJrVbr+igsLOz1YxGFGkmS2lbMclEFkeLKrzh77jITmdwFgsLCQrccJDMzs0fXKVLnbs2aNdBqtXjmmWewf/9+2Gw2lJeX4+GHH4ZarQbgnkBOmDABeXl5OHbsGBYvXoyqqipYrVa8++67WL16tWv+n3yNw+FwLfLoaJ6eN8rLy2E2m10f+fn51/R4RKFGx0LGRH5D7rkblMT5doEgPz/fLQcpLy/v0XVeDcvKPWD19fUe54QQaGhocGvXmZEjR+Lw4cNYsWIFFi5ciNraWgwcOBAPPfQQ5syZg/nz5yM9Pd3tmvXr12Ps2LHYtGkTRowYgejoaNx6660oLi7GvHnzYDabXdesXr0aZ8+e9egZ7A2NRgONRnPNj0MUqrgFGZH/kOfcDWLPXUDo7VQwr5K7ESNGAAAqKio8zlVVVaGlpQVZWVmdzrdrb8iQIdi0aZPH8dWrVwMARo8e7XZckiTk5eUhLy/P45qKigqkp6e7Fle89957uHLlCoYOHerWTl5wce+99yIiIgJRUVE4depUt7ESUe+5tiDjilkixZVfaZ1zxxp3Qc2rYdnJkycDQIe7SMjHpkyZck0BffnllwgLC8Pdd9/do/ZlZWWwWCy4//77Xcc+//xzXLlyBRcuXHD7ePDBBwE4d7q4cOECEzsiH0hPYCFjIn8ghEB5a88dF1QEN6+Su9zcXGRnZ2Pnzp0eZUe2bdsGlUoFo9HoOiaE6HB8ePv27Zg1a5bH8YqKCnz00Ud48sknXStkZdOmTXNbPCF74403EBcXh+eee86bl0JEPpLOOXdEfqG6oQUNzc6SRNxXNrh5ldxJkoTNmze7dqowm80QQmDLli0oKirC8uXL3UqRLFmyBIMHD8bSpUvdHqe6uho7duzAmjVrXNuGlZaWYsaMGRg3blyHK1K/+eYbLFu2DCdOnADgnPe3atUqbNiwAUVFRT1eQUJEviXPubvAnjsiRckrZVPjIxEVrlY4GupPXq+WzcnJQUlJCSRJwvDhw5GamorXX38dW7duxYsvvujWNjMzEzExMR6JV05ODh544AGsXbsWAwYMwKBBg7Bo0SI8/vjj2L17t0ftOwB47LHHEBsbi7FjxyItLQ033XQTvv76axw+fLjDXsD2brnlFuh0OvzhD38A4Jxzp9Pp8NJLL3n78onIS3LPHQsZEymLQ7KhQxJXF44jAM5CgVqtFmazmatlia6BEAL6X+5GY4sdf3ruTlyXzELGREpY9+k/8HJxGe4eNRBrHspROhzqhZ7mJorUuSOi0CFJkmtRxTnOuyNSjDwsyzIowY/JHRH1O3nytlxAlYh8r9y19RgXUwQ7JndE1O8GtdbUqmByR6SYs9x6LGQwuSOifif33FXUMLkjUoLDIXC29eePw7LBj8kdEfW7DPbcESmqqq4JzTYHVFJbYXEKXkzuumEwGKDX62EymZQOhShgyT0F7LkjUoa8mCJdG41wNX/1BxqTyQS9Xg+DwdCj9l7tLRuKSkpKWAqF6BrJw7LnzY1wOARUKknhiIhCi7yYaRD3lA1IRqMRRqPRVQqlO0zfiajfpWmiEKaS0GIXuFjbpHQ4RCFH7rljAePQwOSOiPqdWiVB17pTRUVNg8LREIUe1+4UXEwREpjcEZFPsNYdkXLOssZdSGFyR0Q+Ia+YZXJH5Htyzx3LoIQGJndE5BODWOuOSBE2uwPnaqwA2HMXKpjcEZFPsNYdkTLOm62wOwTC1RLS4lnjLhQwuSMin8hIYK07IiXIUyEyEqJZhihEMLkjIp9ov7+sEELhaIhCh2ulLMughAwmd0TkE/KWR40tdlQ3tCgcDVHoOHuFiylCDZM7IvKJyDA1UuMjAXDeHZEvcXeK0MPkjoh8xrWogoWMiXyGw7Khh8kdEfkMCxkT+V75ldYCxuy5CxlM7rphMBig1+thMpmUDoUo4LGQMZFvNdnsqKyVa9yx5y5QmUwm6PV6GAyGHrUP6+d4Al5JSQk0Go3SYRAFBRYyJvKtczVWCAFEh6sxIDZC6XCol4xGI4xGIywWC7Rabbft2XNHRD7DQsZEvlXuWikbDUlijbtQweSOiHyGhYyJfIuLKUITkzsi8hm5587c2IK6JpvC0RAFP5ZBCU1M7ojIZ+Iiw5AQEw6AQ7NEviAPy2aygHFIYXJHRD6VkcBad0S+Ut76R1RmEnvuQgmTOyLyKVdyx547on5XUc2tx0IRkzsi8inWuiPyjYZmGy7VNQPgsGyoYXJHRD7l2qWCK2aJ+pX8B1R8VBi0rXNdKTQwuSMinxrEWndEPnH6snNIdjDLoIQcJndE5FOsdUfkGycv1QEArk+OVTgS8jUmd0TkU/Kcu6raJlhb7ApHQxS8Tl5y9twNYXIXcpjcEZFPJcaEIyZCDQA4b7YqHA1R8JJ77q5jchdymNx1w2AwQK/Xw2QyKR0KUVCQJInlUIh84OSlegAclg0GJpMJer0eBoOhR+3D+jmegFdSUgKNRqN0GERBJSMxGt9drGMhY6J+Ut9kQ6WlCQCTu2BgNBphNBphsVig1Wq7bc+eOyLyOfbcEfWvU5edvXaJMeFIiIlQOBryNSZ3RORzLGRM1L9OtS6m4Hy70MTkjoh8joWMifoXy6CENiZ3RORzLGRM1L9YBiW0MbkjIp+TCxlfsFhhszsUjoYo+LAMSmjrVXJXVlaGOXPmQKfTITU1FQaDAUVFRV49RmVlJZYsWYKhQ4ciKSkJycnJmD17Ng4dOtTpNe+//z4mTZqEpKQkJCYmQq/XY+XKlWhqavJoe/bsWaxYsQK33norBgwYgISEBNxwww1YvHgxzp8/7/VrJqK+kxofiXC1BLtDoLLW8+eXiK4Ny6CENq+Tu9LSUtx2222w2+0oKytDZWUljEYj5s+fj4KCgh49xsmTJ5GTk4MdO3bg7bffxpUrV3D8+HEAwPjx47F3716Pa/Lz83HffffBYDDgzJkzuHTpElauXInCwkLMmjULdrt7pXu9Xo+1a9di5cqVqKqqwpUrV/Daa69h27ZtGDVqFP7xj394+9KJqI+oVBIGyvPurrAcClFfqmloRnVDCwDgugFM7kKS8ILD4RDZ2dkiPj5e1NTUuJ2bN2+eUKlUorS0tNvHmTlzpgAgtm/f7nbcbDYLrVYrMjMzhdVqdR0/ePCgACBycnI8HqugoEAAECaTye14bGys2Lhxo0f7119/XQAQDz74YJcxms1mAUCYzeZuXw8Ree+RjV+IrJ9/LP7w1RmlQyEKKodPXxFZP/9Y3PbSHqVDoT7W09zEq567AwcO4MiRI5g+fbpHEb25c+fC4XB0u5OD1WrFrl27AABTp051O6fRaJCbm4vy8nJ88sknruMffPBBh+0BYObMmQCAdevWuR3/+c9/jh//+Mce7XNzcwEAn3/+eZdxElH/kid6n2gdPiKiviHXuGOvXejyKrnbt28fAGDMmDEe5+Rje/bs6fIxLl++DJvNhri4OERFRXmc1+l0AJyJpKyyshIAkJKS0mn7o0ePwmw2u47/+7//O1JTUz3aNzc3AwAGDBjQZZxE1L/kid6nmNwR9amTVc6fqSEpTO5ClVfJnTwvLiMjw+NcSkoKwsPDcfr0aTQ2dl7eICkpCWq1GnV1dWho8Jxrc/HiRQDOeXkyOUmTk7yO2l99TWfkHru5c+d225aI+o880fskkzuiPnXysvN3KxdThC6vkruamhoAQGys5z8YSZIQExPj1q4j0dHRmDhxIgC4Db0CQF1dHT777DPX17Lp06cDAIqLiyGEcLtGHuK9+pqOWK1WmEwm3HjjjVi8eHGXbWUWi8Xto6OVuUTkPfkXz6nL9XA4RDetiainXGVQOCwb8JqamjzykJ5QpM7dmjVroNVq8cwzz2D//v2w2WwoLy/Hww8/DLVaDcA9gZwwYQLy8vJw7NgxLF68GFVVVbBarXj33XexevVq1/y/jpLO9pYtW4aqqiq88847rkS0O5mZmdBqta6PwsLCXr5qImovIyEa4WoJTTYHzlusSodDFBSEEByWDSKFhYVuOUhmZmaPrvMquUtISAAA1Nd7DqMIIVzDrHK7zowcORKHDx/G1KlTsXDhQuh0OsyYMQNjx47Fq6++CgBIT093u2b9+vXYsGEDSktLMWLECAwbNgxFRUUoLi7GwIEDO7ymvVWrVmHz5s3YuXMnbrrppp6+ZJSXl8NsNrs+8vPze3wtEXUuTK1CZpLzjyzOuyPqG1V1TahvtkMlwfXzRYErPz/fLQcpLy/v0XVh3jzJiBEjAAAVFRUe56qqqtDS0oKsrCxER0d3+1hDhgzBpk2bPI6vXr0aADB69Gi345IkIS8vD3l5eR7XVFRUID093bW44mqvvPIKCgsLsXv3btx+++3dxtaeRqOBRqPx6hoi6pkhybE4UVWPE5fqMeGGZKXDIQp4cq9dRmI0IsPUCkdD1yoyMhKRkZFeX+dVz93kyZMBoMNdJORjU6ZM8TqI9r788kuEhYXh7rvv7lH7srIyWCwW3H///R2eX7FiBVatWoV9+/Zh/PjxruMHDx50rZwlImXIc4LYc0fUN+QyKNcnxykcCSnJq+QuNzcX2dnZ2Llzp1vZEQDYtm0bVCoVjEaj65gQosMuxO3bt2PWrFkexysqKvDRRx/hySef9ChjMm3aNLfFE7I33ngDcXFxeO655zzOLV++HK+99hr279/vUb7FYDDg3LlzXb9gIupX16dwxSxRX5LrRl4/gEOyocyr5E6SJGzevBlCCCxYsABmsxlCCGzZsgVFRUVYvnw5Ro0a5Wq/ZMkSDB48GEuXLnV7nOrqauzYsQNr1qxxbRtWWlqKGTNmYNy4cR0uWvjmm2+wbNkynDhxAoBz3t+qVauwYcMGFBUVeUwy/NnPfoaXXnoJkyZNwnvvvYeCggK3DyJS3vXsuSPqU6e4pyzByzl3AJCTk4OSkhL84he/wPDhw+FwOJCVlYWtW7fikUcecWubmZmJmJgYj8QrJycHDzzwANauXYuCggLExcUhIyMDjz/+OJ544gmEhXmG9dhjj2Hnzp0YO3YsVCoVYmJicMcdd+Dw4cOuuYCympoa18KMt99+29uXSEQ+IvfcnbnSAJvdgTC1Igv4iYKG3At+HZO7kCaJqwvHEQBnfTutVguz2cwFFUT9xOEQ0L+wC9YWB/703J38hUR0DRwOgRt/uQvNNgf+/LOJGMyh2aDT09yEfyYTkWJUKsm1qILz7oiuzTlzI5ptDoSrJQxM8Nzek0IHkzsiUhS3ISPqG/LP0OCkGE5xCHG8+0SkKCZ3RH2jbTEFy6CEOiZ3RKSo69rtMUtEvecqg5LMuXahjskdESlqSGtyd6KKyR3RtWDPHcmY3HXDYDBAr9fDZDIpHQpRUJJ77s6ZG2FtsSscDVHgaiuDwp67YGMymaDX62EwGHrU3us6d6GmpKSEpVCI+tGA2AjER4Wh1mrDmSsNGJ4Wr3RIRAGnxe5AeXUjAGAIe+6CjtFohNFodJVC6Q577ohIUZIkcVEF0TUqv9IAu0MgOlyNNI33G81TcGFyR0SKY3JHdG3+UdW2M4UkSQpHQ0pjckdEinMVMuaiCqJe+b9zZgDAiHROayAmd0TkB4a07jF7kuVQiHrl/85ZAAAjB3Y/H4uCH5M7IlIctyAjujZfu5I7LgAkJndE5AfkcihVtU2oa7IpHA1RYKmub0ZFjXOlrJ7JHYHJHRH5AW10OAbERgBoK8RKRD3z9Xlnr93gpBhoosIVjob8AZM7IvILXDFL1DvyYgoOyZKMyR0R+YXrmNwR9cr/cb4dXYXJHRH5BbnnjsOyRN7hSlm6GpM7IvILcnJ3gskdUY81NttxoqoOAHvuqA2TOyLyC66eO9a6I+qx4xcscAggOS4SqZoopcMhP8HkrhsGgwF6vR4mk0npUIiCmlzrrqahBdX1zQpHQxQYON8uNJhMJuj1ehgMhh61D+vneAJeSUkJNBr+0BD1t+gINdK1UThvtuLk5XoktpZGIaLOfc2VsiHBaDTCaDTCYrFAq+1+biV77ojIbwxNiQMAHG+t20VEXeNiCuoIkzsi8hujMhMAAIdP1ygaB1EgaLE7UHahFgB3piB3TO6IyG+MyUoEAJSeqVY4EiL/d6KqHs02B+Iiw5CVFKN0OORHmNwRkd/IGZwAwFkOhYsqiLom70wxIj0eKpWkcDTkT5jcEZHfSIiJwJAU56rZ0nL23hF1hfPtqDNM7ojIr4we7ByaPXSayR1RV+SeO863o6sxuSMivyInd1xUQdQ5IQS+Zo076gSTOyLyK6OzEgAAR87WwGZ3KBsMkZ86W90Ii9WGcLWEYanxSodDfobJHRH5lWGp8YiPDENDsx3fVNYqHQ6RX5KHZIenxSMijL/KyR3/RRCRX1GrJIxqXTV7+EyNorEQ+StuO0ZdYXJHRH4nxzXvjosqiDrClbLUFSZ3ROR3Rrt67pjcEXXk/7inLHWByV03DAYD9Ho9TCaT0qEQhYycTGfP3enLDbhU16RwNET+5VJdEyotTZAkYEQ6k7tQYDKZoNfrYTAYetQ+rJ/jCXglJSXQaPjDQ+RL2phw3JAah+8v1qH0TA2m6NOUDonIb/z9bA0A4PoBsYiN5K/xUGA0GmE0GmGxWKDVdj8Uz547IvJLY+R5dxyaJXKz7atyAMD4GwYoHAn5KyZ3ROSX5Hp3XFRB1ObkpXrsPV4JAHh0/PUKR0P+iskdEfkleaeKI2dr0MJixkQAgE1/OQkhgEk3puKG1DilwyE/xeSOiPzS0JQ4aKLCYG1xoOw8ixkTVdc3451DziHZvFz22lHnmNwRkV9SqSSM4rw7IpeiL0/D2uLAyIEajBvC+XbUOSZ3ROS3WO+OyKnJZsfWv54G4Oy1kyRJ4YjIn/UquSsrK8OcOXOg0+mQmpoKg8GAoqIirx6jsrISS5YswdChQ5GUlITk5GTMnj0bhw4d6vSa999/H5MmTUJSUhISExOh1+uxcuVKNDV1XgfrrbfegsFgQGpqKnQ6He6//358++23XsVKRMoYk8WeOyIA+Ohv51BV2wSdJgozbxmodDjk57xO7kpLS3HbbbfBbrejrKwMlZWVMBqNmD9/PgoKCnr0GCdPnkROTg527NiBt99+G1euXMHx48cBAOPHj8fevXs9rsnPz8d9990Hg8GAM2fO4NKlS1i5ciUKCwsxa9Ys2O12j2uWL1+ORx99FEajEZWVlSgrK4PNZoPBYMDf//53b186EfnYqMwESBJQfqURF2utSodDpAghBN78y0kAwKMTrkO4moNu1A3hBYfDIbKzs0V8fLyoqalxOzdv3jyhUqlEaWlpt48zc+ZMAUBs377d7bjZbBZarVZkZmYKq9XqOn7w4EEBQOTk5Hg8VkFBgQAgTCaT2/GDBw8KSZLE/Pnz3Y7X1NSI+Ph4MWbMGOFwODqN0Ww2CwDCbDZ3+3qIqP9M/a9PRdbPPxbz3/xSHD1b0/0FREHmz99eFFk//1iM+PdiUVPfrHQ4pKCe5iZepf8HDhzAkSNHMH36dI8KyXPnzoXD4eh2my6r1Ypdu3YBAKZOnep2TqPRIDc3F+Xl5fjkk09cxz/44IMO2wPAzJkzAQDr1q1zO24ymSCEwNy5c92Oa7Va3HXXXTh06BA+//zzLmMlIuU99k/XQ5KAT7+twszX/oLHtpTgSHmN0mER+cyGA85euwduzYQ2JlzhaCgQeLVvyb59+wAAY8aM8TgnH9uzZ0+Xj3H58mXYbDbExcUhKirK47xOpwPgTCTvvfdeAM75eQCQkpLSafujR4/CbDa7ks7uYv2f//kf7NmzBxMmTOgyXiJS1gOGTIzOSsDr//s9PjpyDvvKLmJf2UVMuGEAhqXGIyEmHAnR4UiIiYA2OhxxUWGIjQhDfFQYYiPDEBupRoRaxQno5DccDoHGFjsamu2otbagrsmGWqv80YLqhmZcrm/GlTrn5z9/WwWVBCycwPIn1DNeJXfyvLiMjAyPcykpKQgPD8fp06fR2NiI6OjoDh8jKSkJarUadXV1aGhoQExMjNv5ixcvAnDOy5OlpqYCaEvyOmovXzNq1Cg0NDTgzJkziIiI6DAhlOMvKyvr8vUCgMVicfs+MjISkZGR3V5HRH3nhtR4rHkoB09NHgbT/u/xYWkFPvv+Mj77/nKPrlerJESHqxEdoXZ+DlcjKlyFyDA1Itt/VqsQrlYhIqztI1ytQoRaQpja/eswlYQwtYQwlQrhrZ/VaglhKglqVev3KkCtcrZVSc72KkmCSnLGpJIk12eVClBL8tfONqrW7yXX13B9H0rJqhACQgAOIeBo/dz2vYDD4fzafvX3DnHVZ8DucH5vczjgEAI2u/y983OL3eH87BCw2R2w2QVaHK2f7Q60uD470Gx3oMUm0Gy3o6nF+X2zzflhtdlhbXHA2mJv/XC0JnQ2WFu8L8o9/eZ0DB4Q031DCipNTU1ui0avzkk641VyV1NTAwCIjY31OCdJEmJiYmA2m1FTU9NpchcdHY2JEydi7969+OSTT3D//fe7ztXV1eGzzz5zfS2bPn06Vq5cieLiYqxatcrtPzV5iLf9NXKcVyeOMjn+6uruV+BlZma6ff/CCy/0eOEIEfWtoSlx+K8HRmHJpGHYe7wSV+qbUdPYAnNDC8yNLahpbEZ9kx21Vhvqm2xobHEutLI7BOqabKhrsin8CvqWW7IHOelr9zWc/zdLAND++9b/QuXv276WH9kzcbw6lxTC7Tu3YwLOhKzta/ka4Wwp2trI5x3tzjlcx53JXDCLjwxDXJSzpzkuMgzxUeFIio1AYkwEBsRFICk2AslxkZjAfWRDUmFhIV588UWvr/Mquesra9aswYQJE/DMM88gOTkZubm5OH/+PBYvXgy1Wg3APYGcMGEC8vLysHHjRixevBgFBQWIj4/Hxx9/jNWrV0Or1cJsNneYdF6r8vJyaDQa1/fstSNS3nXJscjLHdJtO7tDoL7ZhsZmu/OjdSissdmOJpsdTTaH83NrD0v7npem1q876rFpsTt7fuRzcq9PWw+Q85y9tWfIIYRbG4fDeU7uUWrfG+UN+TqnIM+CesjV49na+6lu/Vqtklxfy72r6nbH3XtjncfDXcfaemfb9+aGq1UID1MhorW3NzKs7XNUuBqRYSpEhqsRFebsKY6JCENMhLMHOSbCeVylCp0eWPJefn4+nn32Wdf3FovFo9OpI14ldwkJCQCA+vp6j3NCCDQ0NLi168zIkSNx+PBhrFixAgsXLkRtbS0GDhyIhx56CHPmzMH8+fORnp7uds369esxduxYbNq0CSNGjEB0dDRuvfVWFBcXY968eTCbza5r5OeX47maHH9iYmK3r1mj0bgld0QUONQqCZqocGiiAmMSumiX6NkdVw09CudcrfY9Wq7PcLYVcLZxPpZ7D1hbD1rbeVda2C4vFB0kiZ0lnR2NDLf2E7p6DtvaefYmtu9llNu1H4qW4NypRELbcbiGtOE2ZK0OweFqCn69nQrmVXI3YsQIAEBFRYXHuaqqKrS0tCArK6vTIdn2hgwZgk2bNnkcX716NQBg9OjRbsclSUJeXh7y8vI8rqmoqEB6erprcUVMTAwGDx6MM2fOoKqqymPenRz/jTfe2G2cRES+IkkS1BKghoRwtdLREFGg8qoUyuTJkwGgw10k5GNTpky5poC+/PJLhIWF4e677+5R+7KyMlgsFre5e76KlYiIiMjfeJXc5ebmIjs7Gzt37oTZbHY7t23bNqhUKhiNRtcxIQTKy8s9Hmf79u2YNWuWx/GKigp89NFHePLJJ10rZGXTpk1zWzwhe+ONNxAXF4fnnnvO7bjRaIQkSdi2bZvbcbPZjOLiYowePRrjx4/v/kUTERERBRCvkjtJkrB582YIIbBgwQKYzWYIIbBlyxYUFRVh+fLlGDVqlKv9kiVLMHjwYCxdutTtcaqrq7Fjxw6sWbPGtW1YaWkpZsyYgXHjxqGwsNDjub/55hssW7YMJ06cAOCcN7dq1Sps2LABRUVFHhMMx4wZg+effx6/+93vsHXrVgghYDab8eijjwIANm3axLkZREREFHS83qAuJycHJSUlkCQJw4cPR2pqKl5//XVs3brVY7luZmYmYmJiPBKvnJwcPPDAA1i7di0GDBiAQYMGYdGiRXj88cexe/fuDkuYPPbYY4iNjcXYsWORlpaGm266CV9//TUOHz7cYS8gAKxYsQKbN2/G2rVrkZaWhuHDh0OtVqOkpATZ2dnevnQiIiIivycJ4e3i+9BgsVhcJVa4WpaIiIiU1tPcxOueOyIiIiLyX0zuFNTU1ISCggK3rUVIWbwn/of3xD/xvvgf3hP/o9Q94bBsJ3wxLMuhX//De+J/eE/8E++L/+E98T99fU84LEsuJpMpaJ7HV6+lv/Ge+Kdgeb94T0LzOXwlmN6vYLov7TG5CwHB9EMSLD+IvCf+KVjeL96T0HwOXwmm9yuY7kt7Xm0/Fkrk0erRo0dDrVbj8ccfx7/+67/26XNYLBa3z/3Fbrf3+3P46nn6+zl4T/zvOXx1T4DgeL989RzB9LMSLM/Be+J/z9NX92T9+vXYsGGDqzZwdzPqOOeuE2fPnvWoz0dERESktPLycgwaNKjT80zuOuFwOHDu3DnEx8dzJwsiIiJSnBACtbW1GDhwIFSqzmfWMbkjIiIiCiJcUEFEREQURJjcEREREQURJndEREREQYTJnQLKysowZ84c6HQ6pKamwmAwoKioSOmwglpTUxP+8Ic/YObMmdDpdBgwYABSUlIwY8YM7N27t8NrrFYrXnjhBQwbNgypqanIysrC008/DbPZ7OPoQ8vixYshSRIeffTRDs/zvvQ/u92ON954A+PGjcPgwYORkJCAoUOH4qGHHsKRI0fc2vJ++IbdbsfWrVsxbtw4DBw4EGlpabjlllvw0ksvoa6uzqM970vfO3bsGMaPHw9JknDq1KlO2/Xmvd+5cyfuuOMOpKamIi0tDXfddRe++uqr3gcryKcOHz4s4uPjxd133y2qq6uFw+EQmzdvFiqVSrzwwgtKhxe0nnrqKQFA5OfnC4vFIoQQ4vTp0+Kf//mfBQDx2muvubVvbm4WEydOFKmpqeKrr74SQgjx7bffimHDhombb75ZmM1mn7+GULBnzx4hSZIAIP7lX/7F4zzvS/9rbGwUU6ZMEePGjRPHjh0TQgjR0tIiXn31VQFAbN682dWW98N38vLyBADxq1/9SjQ1NQmHwyE+/vhjER0dLXJyckRTU5OrLe9L32psbBTPP/+8SEpKEsnJyQKAOHnyZIdte/Peb9iwQQAQK1asEC0tLaKhoUH85Cc/EeHh4eKPf/xjr2JmcudDDodDZGdni/j4eFFTU+N2bt68eUKlUonS0lJlggtyRqNR5ObmehyvqqoS0dHRIjIyUlRXV7uO/+d//qcAIDZt2uTWft++fQKAeOaZZ/o75JBTXV0tBg0aJObNm9dpcsf70v+WLl0qBgwY4PbzILv33nvFjh07XN/zfvjG2bNnBQAxatQoj3NPP/20ACC2bdvmOsb70reeeOIJMXv2bFFeXi5++MMfdpncefvenz17VkRHR4s77rjD7XhLS4sYMmSIyMjIEA0NDV7HzOTOhz799FMBQDz44IMe53bu3CkAiLy8PAUiC347duwQu3bt6vBcTk6OACD27dvnOjZkyBChVqtFbW2tW1uHwyHS0tJEfHy8aGxs7NeYQ83DDz8sZs6cKfbv399pcsf70r8qKytFWFiYWLp0aY/a8374xhdffCEAiAceeMDjnMlkEgDEyy+/7DrG+9K3Tp065fq6u+TO2/f+xRdfFADEb3/7W4/HWrZsmQAgfve733kdM+fc+dC+ffsAAGPGjPE4Jx/bs2ePT2MKFTNnzsS0adM6PNfc3AwAGDBgAADg5MmTOHHiBH7wgx8gLi7Ora0kSRg9ejRqa2vxxRdf9G/QIeS9997D7t27sWHDhk7b8L70vw8//BA2mw233357t215P3xn+PDhiIqKwvHjxz3OycduvvlmALwv/SErK6tH7Xrz3vdXXsDkzofkH8KMjAyPcykpKQgPD8fp06fR2Njo69BC1qVLl/Ddd99Br9fjlltuAdD1fWp/vKyszDdBBrnKykosWrQIv/3tb6HT6Tptx/vS/w4dOgQA0Gq1+OUvf4mRI0ciJSUFw4YNw6JFi3DmzBlXW94P30lMTMRrr72GsrIyPP/887BYLGhubsY777yDDRs2YO7cuZg+fToA3hcl9ea97+qaa7lXTO58qKamBgAQGxvrcU6SJMTExLi1o/63du1a2Gw2rF271rXNXFf3qf3x6upqn8QY7PLy8jB16lTMmTOny3a8L/3v3LlzAIB/+Zd/wZkzZ7B3716cO3cOJpMJH374IUaPHo1vvvkGAO+Hr+Xl5eHdd9/F22+/Da1Wi7i4ODz++ONYuXIlfv/737va8b4opzfvfVfXXMu9YnJHIeuLL77Ayy+/jF/96leYPHmy0uGEpDfffBOHDx/G66+/rnQoBLhGDeLi4rBx40akp6cjPDwcU6dOxX/913/h8uXLePrpp5UNMgQJIfDEE0/gnnvuwaJFi1BdXY3a2lr8/ve/xyuvvILp06ezU4DcMLnzoYSEBABAfX29xzkhBBoaGtzaUf/5+uuvMXPmTCxZsgS/+MUv3M51dZ/aH09MTOzXGIPdqVOn8Oyzz+LNN9/s0XvJ+9L/5J6CyZMnIywszO3crFmzAAB79+6F1Wrl/fChLVu2YP369XjkkUewbNkyJCQkIDIyEtOnT8dvfvMbFBcXu5Ju3hfl9Oa97+qaa7lXTO58aMSIEQCAiooKj3NVVVVoaWlBVlYWoqOjfR1aSDl27BgmTZqEhQsX4tVXX/U439V9an/8xhtv7L8gQ8DOnTvhcDjw6KOPQqfTuT7uvfdeAMAf/vAH17Ht27fzvvjAddddBwBITk72OBcXF4fY2FjYbDZcuXKF98OHdu3aBQAdjjDIxz744AMA/P9LSb1577u65lruFZM7H5J/COVJy+3Jx6ZMmeLTmEJNaWkpJk6ciEWLFuHXv/616/ipU6dc842uv/56DBkyBN9++61H5XchBEpLSxEfH9+jFYXUuSeffBK1tbW4cOGC28f7778PAHjwwQddx2bPns374gN33HEHAODChQse5xoaGlBfX4+wsDAkJSXxfviQ/P7K84Lbk4/V1dXBbrfzviioN+99f+UFTO58KDc3F9nZ2di5c6fHNiTbtm2DSqWC0WhUKLrgV1JSgsmTJ+NnP/sZCgoK3M4VFBRg/fr1ru+NRiNsNhveeecdt3b79+/HhQsXkJeXh6ioKF+ETe3wvvSvGTNmYNCgQdizZ4+rRJCsuLgYAHDXXXe53mPeD9+Qk4FPP/3U49yf//xnAMCtt94KtVoNgPdFSd6+9wsXLkR0dDS2bdvm1t5ms+Hdd99FRkYG7rnnHu8D8boyHl2Tw4cPi7i4OHHPPfeImpoat+3HfvnLXyodXtD67LPPhEajETfeeKN44YUXPD6ys7Pdtn9rbm4Wd955p8cWMsOHD+f2Pf2sqyLGvC/9749//KOIiIgQjzzyiLh8+bJwOBzi888/F4MGDRLp6enixIkTrra8H75RXV0tfvCDHwi1Wi3WrVsnrFarcDgc4sCBA2Lw4MEiMjJSfPrpp672vC/9p7sixr1579evXy8AiJdeeknYbDbR2NgofvKTn4iwsDCxe/fuXsXJ5E4Bx48fF/fee69ITU0VycnJYsyYMeKtt95SOqygNnv2bAGgy4+r9/ZtbGwUv/zlL8WQIUNESkqKyMzMFEuXLvXYOo76xooVK0RaWppITEwUAERUVJRIS0sTN998s1s73pf+d/DgQTFr1iyRlJQkEhISxPXXXy+eeuopceHCBY+2vB++UVNTI55//nkxcuRIER8fL7RarRg0aJB4+OGHxZEjRzza8770nS+//FKkpaWJtLQ0ER4eLgCI5ORkkZaWJp599lmP9r157z/55BPxT//0TyI5OVmkpKSIadOmiS+++KLXMUtCCOF9fx8RERER+SPOuSMiIiIKIkzuiIiIiIIIkzsiIiKiIMLkjoiIiCiIMLkjIiIiCiJM7oiIiIiCCJM7IiIioiDC5I6IiIgoiDC5IyIiIgoiTO6IiIiIggiTOyIiIqIgwuSOiIiIKIj8f4jAfvW9t0F/AAAAAElFTkSuQmCC", + "text/plain": [ + "
" + ] + }, + "metadata": {}, + "output_type": "display_data" + } + ], + "source": [ + "import numpy as np\n", + "\n", + "data = np.fromfile('2d_lightcurve.bin', dtype=np.float64)\n", + "print(data.shape)\n", + "\n", + "plt.plot(data)" + ] + }, + { + "cell_type": "code", + "execution_count": 8, + "metadata": {}, + "outputs": [ + { + "data": { + "text/plain": [ + "[]" + ] + }, + "execution_count": 8, + "metadata": {}, + "output_type": "execute_result" + }, + { + "data": { + "image/png": "iVBORw0KGgoAAAANSUhEUgAAAlwAAAFxCAYAAACmxnbFAAAAOXRFWHRTb2Z0d2FyZQBNYXRwbG90bGliIHZlcnNpb24zLjkuMiwgaHR0cHM6Ly9tYXRwbG90bGliLm9yZy8hTgPZAAAACXBIWXMAAA9hAAAPYQGoP6dpAABQiElEQVR4nO3deXhU5dk/8O+ZJZN1AtmBhFUWwyZgqNCKIu7iWhSt2KKv7yuaVi1VW7SvgLVgrbZv1VSrteLPfUGxKm64tqIlEkQBwY0lENaQZLLN/vz+mDlnzmTOLElmn+/nurhMZs7MPM7Jcue+73M/khBCgIiIiIhiRpfoBRARERGlOwZcRERERDHGgIuIiIgoxhhwEREREcUYAy4iIiKiGGPARURERBRjDLiIiIiIYowBFxEREVGMMeAiIiIiirGUD7i2bNmCmTNnQpIk7Nq1K9HL8dPc3Iwrr7wSkiRh1apVQY/btWsX9Ho9KioqNP89/fTT8Vs0ERERRZ0h0QvoK6vVit/97nd46KGHoNMlX9z4xBNP4KabbkJOTk5Ex1dVVSVdwEhERETRkXyRSoRuvPFGbN26FZs3b8b48eMTvRw/zz77LO6++26sWbMGCxcuTPRyiIiIKMFSNsO1ZMkSDBs2LNHL0DRr1iz8+Mc/htFoxFtvvZXo5RAREVGCpWyGq7fB1nvvvYfTTz8dRUVFKCoqwtixY7FkyRK0t7dHfW2DBw+G0WiM+vMSERFRakrZgKs3Hn30UZx66qmorq5GY2Mjmpub8dBDD+HRRx/FrFmz0NXVlegloqurC4sXL8b48eNRXl6OkSNH4ic/+Qnq6+sTvTQiIiLqp7QPuJqamlBbW4sJEybgT3/6E/Ly8iBJEmbPno2lS5fi888/xwMPPJDoZaKlpQUVFRX497//jaamJqxZswaNjY2YMWNGyCsciYiIKPmlbA9XpF544QXYbDacddZZAVczzpgxAwDwz3/+E7fccgsAT6bp7rvv7tVr3HjjjRgwYECf11hVVYX9+/ejpKREuW3SpEl45ZVXMHLkSFx33XU466yzUF5e3ufXICIiosRJ+4Brx44dAIAHH3wQjz/+uN99Qgjk5eXhyJEjym1dXV1Yvnx5r15j4cKF/Qq49Hq9X7AlKyoqwimnnIKXX34Za9euxZVXXtnn1yAiIqLESfuAS7ZkyRIsWbIk7HElJSUQQsRhRZEZPHgwAGD//v0JXgkRERH1Vdr3cI0bNw4A0NjYqHn/l19+iU2bNsVzSQFWrVoVtDm+qakJAFBWVhbPJREREVEUpX3AdfHFFyM7Oxtr1qyB3W73u89ms+GMM87AunXrErQ6j1WrVuGxxx4LuL21tRUffPABsrKycOaZZyZgZURERBQNaR9wDRo0CA8++CAOHjyI//mf/8HRo0cBeDJH8+fPR3l5Oa655poErxJ45JFH8Pe//10JCr/77jvMmzcPra2t+OMf/4jKysoEr5CIiIj6ShLJ1LDUCxs2bMB5550HADh69CgcDgdKSkqg1+tx+eWX49577/U7/qOPPsJdd92FDRs2ICsrCwUFBbjgggvw61//GkVFRVFfX2VlJZxOJzo6OtDZ2Qmz2YycnByMGDECn3zyid+xO3bswLPPPos33ngDjY2N6O7uhtFoxIwZM3DDDTdg9uzZUV8fERERxU/KBlxEREREqSLtS4pEREREicaAi4iIiCjGUmoOl9vtRlNTEwoKCiBJUqKXQ0RERBlOCIH29nYMHjw4YEcbtZQKuJqamlBVVZXoZRARERH5aWxsDDlRIKUCroKCAgCe/ymz2RyT17BYLKiqqorpawBATU1N0GGnqfQa8XgdnpPke510Oifxep10OSdAerxf8XqNdPpeSZfXiPY5kZ9PjlGCSamASy4jms3mmP9AifVr6PX6mP8/xOM14vk6PCfJ9zrpcE7i9Trpck6A9Hm/4nVOgPT4XkmX15BF+5yEa3Vi03yC1NbWpsVrxPN1Yo3nJPmk0/uVLucESJ/3i+ckM18jUVJqDpfFYkFhYSHa2tpiWlKM9WtQ7/CcJB+ek+TDc5KceF6ST7TPSaTPxwxXDyaTCUuXLoXJZEr0UsiL5yT58JwkH56T5MTzknwSdU5SMsM1ZswY6PV61NbWpnX6kYiIiJJTXV0d6urq4HK58PXXX4fNcKVkwMXULBERESUDlhSJiIiIkgQDLiIiIqIYY8BFREREFGMMuIiIiIhijAEXERERUYwx4CKiXvvda9tw1ap6uN0pc5EzEVFCpdReikSUHJ78dDdsTjf2HO3C8JK8RC+HiCjpMcNFRL0ihIDN6QYA5b9ERBQaAy4i6hV1kGVzuhK4EiKi1MGAi4h6xeZQB1zMcBERRSIlA66amhpUV1ejrq4u0UshyjjqrJadARcRZai6ujpUV1ejpqYmouNTsmm+vr6eeykSxcCWfW3IMugwprwg6DEsKRIRAbW1taitrVX2UgwnJTNcRBR93XYXLn7oE8z/2ychxz1YHb4gS11eJCKi4FIyw0VE0dfW7UC3w4Vuhwt2lxvZOr3mcf4ZLgZcRESRYIaLiAD4lwfVWaxQx7GkSEQUGQZcRAQAsKrKg9YQpUIrr1IkIuo1BlxEBCDyzJXfcezhIiKKCAMuIgLgn60KleHyn8PFkiIRUSQYcBERAP9AKnQPF0uKRES9xYCLiAD0GPcQIpCK9DgiIvJhwEVEAHqWFCPMcIU4joiIfBhwERGAvo6FYIaLiCgSKRlwcS9FouiLdNwDx0IQEXEvRSLqIw4+JSKKHPdSJKI+8evhCpG58hsLwTlcREQRYcBFRAB6BlIcC0FEFE0MuIgIAGCNsBnefywES4pERJFgwEVEADj4lIgolhhwERGAyMc9cC9FIqLeY8BFRAD8xz2EynBZuZciEVGvMeAiIgCRZ644+JSIqPcYcBERgJ5jIdjDRUQUTQy4iAiAfxkx0pKinQEXEVFEUjLg4tY+RNEXaeaKk+aJiLi1DxH1kV9JMdRYCFWGy+EScLkF9DoppmsjIko23NqHiPrE5ldSDJXh8r+PZUUiovAYcBERgF6UFHtkv1hWJCIKjwEXEQHwD6Qi3UtR63MiIgoU94DLZrPhueeew9y5c1FRUYHi4mKUlpbinHPOwbp16+K9HCLyiqSHy+0WsLt6BFycNk9EFFbcA66bb74Zl156KSZNmoRvvvkGzc3N2LhxI+x2O0477TQ88MAD8V4SEaHnptTaQZT6dpNB572NJUUionDiHnC53W6ceOKJWLFiBQoKCgAAQ4cOxTPPPIOcnBzcdNNNaG1tjfeyiDJeJBkudXBlzjEGPI6IiLTFPeA688wzcdtttwXcXlJSgnHjxsFms6GhoSHeyyLKaE6XG063UD63hslw6XUS8rL03tuY4SIiCifuc7jmzp0b9D673Q4AKC4ujtdyiAgI6MtyuQWcLjcMev+/yeR+rWyDDllySZE9XEREYSXNVYpHjhzBN998g+rqakyaNCnRyyHKKFpzt7SyXPIeiyajHiaDnOFiwEVEFE7STJq/77774HQ6cd9990GSQk+ttlgsfp+bTCaYTKZYLo8orcllQYNOUkqLVocL+Sb/HxFyNstk0LFpnogyks1mg81mUz7vGZMEkxQZrk8//RR33XUX7rjjDsyZMyfs8VVVVSgsLFT+rVy5Mg6rJEpfciCVY9T7SoUamSs5uDIZdDAZgx9HRJSuVq5c6ReDVFVVRfS4hGe4tm3bhrlz5+L666/XbKbX0tjY6LeXIrNbRP3jKxXqAMmzXY/WlYpy6TFbXVJkDxcRZZAlS5Zg8eLFyucWiyWioCuhAdeWLVtw6qmn4qqrrsLdd98d8ePMZjM3ryaKIl+pUA9JktBudWoGUn4ZLpYUiSgD9bWNKWElxU2bNmH27NlYtGiRX7C1a9cuNDU1JWpZRBlJLguaDDpke0uFVo1AynecXhVwMcNFRBROQgKu+vp6zJkzBzfffDOWLVvmd9+yZcvw8MMPJ2JZRBlLLh+qrz7UKinaVKVHXqVIRBS5uJcU169fj7POOguDBw9GV1dXQMD1+eefY/jw4fFeFlFGU2e45NFbWoGUVVV6VJrmQ2x0TUREHnEPuO6++25YLBZYLBYsX75c85gLLrggvosiynDq3iyD2zOWRSuQsjnUGS6WFImIIhX3gGvNmjXxfkkiCsOmuvrQ6fZ8rDUMVZ0JY0mRiChyCR8LQUSJZ9XKcGk0zfuPheBVikREkWLARUS+sRBGPdzKpHkOPiUiihYGXETkVyp0q7b2CX4c91IkIuoNBlxEpARX2UYdXN74SfsqRd9xSkmRk+aJiMJKir0Ue6umpgbV1dWoq6tL9FKI0oI6c6UMPg2X4TKyh4uIMlddXR2qq6tRU1MT0fEpmeGqr6/n1j5EUaTuzfJWFHmVIhFRCLW1taitrYXFYkFhYWHY41My4CKi6JKDpmyjHm4hvLcFn8Plf5UiAy4ionAYcBGRb2sfgw5CuU2jh0srw8VJ80REYTHgIiK/UqEScIXIcJmMvrEQdma4iIjCYsBFRH5zuHre5nec31gIlhSJiCLFgIuIlH6tbKMO3hauIJPm1WMh9EGPIyIifwy4iMiX4TKEznDZVRmuLM7hIiKKGAMuIvIbCyF5tlLU7uHya5pnSZGIKFIMuIjIb1Nq321aAVfgWAi7yw23W0Cnk+KwUiKi1JSSk+aJKLrUGa7sEJtSWx2qDJcqOLO7mOUiIgqFARcRaW5KHSrDZVLtpQiwj4uIKJyUDLi4lyJRdPkmzetUeyn6B1Eut4DD5bmE0WTQw6CTIFcReaUiEWUa7qVIRL3mmzSvV5rmewZR6s+zjTpIkgSTQY9uh4uN80SUcXq7l2JKZriIKLqUkqJRpzTOWx1uCHkoF/zLhll6nXK85/HMcBERhcKAiyjDOV1uuNxyqdC3ZQ/g3zgvf2zQSTDIAZdBu/xIRET+GHARZTirKqjKNuqRrR5+qrrPN2Xed79v2jwDLiKiUBhwEWU4m+pqxCy9Dka9qhledZ966KnMN/yUJUUiolAYcBFlODmQytLroNNJSjM84F8qVM/qkplCzOwiIiIfBlxEGU7dMC/L1miG942OCCwp2hlwERGFxICLKMOpR0LI1Fcq9jwuS7OkyICLiCgUBlxEGS5Ub5Z6A2t5LITJL8PlDbg0ptITEZEPAy6iDCcHS/4lRe/Vh47AsRD+gRmvUiQiikRKBlzc2ocoeuSxEOpxEL75Wr7MleZYCDbNE1GG4tY+RNQrWhkuuWyoNfiUYyGIiLi1DxH1klYg5WuaV1+lqDEWwhBYeiQiokAMuIgynPa4B42m+RDHsaRIRBQaAy6iDOcbCxG6aV7rOG5eTUQUGQZcRBnOV1JUzeEKkeEyGbiXIhFRbzHgIspwcnYq2xiYufLb2scROJE+S5nDxYCLiCgUBlxEGU4OqvwzXHLmSjUWQg7MNMZHsKRIRBQaAy6iDKd19aHm4FONDBdLikREkWHARZThtAOpwMGn2mMheJUiEVEkGHARZTibRqkwO8TgU81J89xLkYgoJAZcRBlOK8OVbQzMcGmOhWBJkYgoIikZcHEvRaLoCTXuwb+kqHUcS4pElJm4lyIR9UqosRDaJUXupUhExL0UiahXNMdCaO2lqJQU1T1c3EuRiCgSDLiIMlyoqw/9Bp86g1/NyJIiEVFoDLiIMpxWIOW7SlErw8WSIhFRbyU04NqyZQtmzpwJSZKwa9euRC6FKGPJZUOtCfLqDJdVcywEr1IkIopEQgIuq9WK2267DSeddBK++eabRCyBiLxCZ7jUk+aDZ7jsTjeEEDFfKxFRqkpIwHXjjTdi69at2Lx5M8aPH5+IJRCRly1E07wtwrEQAGB3MctFRBRMQsZCLFmyBMOGDUvESxNRD5pjIeSSovc+p8sNp1toHOcLvmxOt9/nRETkk5AMF4MtouQRaiyEwyXgcgu/0qL6OKNegiR5PuZoCCKi4HiVIlEGE0JojoVQZ7FsTpdfwJWlOk6SJF6pSEQUgZScNG+xWPw+N5lMMJlMCVoNUepyugW8lULNrX0ATwZMDqaMegl6neT3HCaD3nsMM1xElP5sNhtsNpvyec+YJJiUzHBVVVWhsLBQ+bdy5cpEL4koJaknyauvUtTrJBj1nsDK5nQpZcdsjR4tJcPFkiIRZYCVK1f6xSBVVVURPS4lM1yNjY1+eykyu0XUN/69Wf5/f2Ub9HC4nH4ZLnVQpjzOyJIiEWWOJUuWYPHixcrnFosloqArJQMus9nMzauJokAOuLIMOkhSj1KhUYd2mycLZtcYCaEcZ+DwUyLKHH1tY0rJgIuIosM3ZV4jc6UKpOwaw1F9x3E/RSKicBhwEWUwZeipMTBzJV+pGD7DJfdwsaRIRBQMAy6iDKY1EkImB1dWhwsOlwh6XBYzXEREYSXkKsUNGzagoqICFRUVWL9+PQCgpqYGFRUV+NWvfpWIJRFlJJvGhtSybKMvkIokMGPARUQUXEIyXNOnT8eBAwcS8dJEpGLV2JBaJgdh6gyXVmDGwadEROGxpEiUwXwbUodohne44XCHOE7Z6JoZLiKiYBhwEWUwW4hmeDmbZXOqerhCZrgYcBERBcOAiyiDKWMhNMY9+EqKvgyX9vgIlhSJiMJJya19ampqUF1djbq6ukQvhSilhcpwqQMp3/gINs0TxctBixUuebNTSjp1dXWorq5GTU1NRMenZIarvr6ek+aJokCenaUVSKkzXE63PBZCIzAzci9FomjbtKcFF/51PX7yg6FYceHERC+HNNTW1qK2thYWiwWFhYVhj0/JgIuIokMZCxEiw2V1uOAS8lWKLCkSxcPG3S0AgB0H2hO8EooWBlxEGSxUhku5+tAZJsPFkiJR1DUe7QIAdFidCV4JRQsDLqIMFmoshHprHznDFXJ8BAMuoqjZIwdcNgZc6YIBF1EGC9007+3hcrrhDhVwGbmXIlG0NbZ0AwA67Qy40gUDLqIMFnoshC+QcotQk+Y9t9ldzHARRYMQAntbPBmuTpsTQghIkpTgVVF/peRYCCKKjpCDT1UZLuW4UE3zvEqRKCoOd9hg9X4/OVyC5fo0wYCLKIMpm1JrNs37eriUOVxh5nURUf81Hu32+7yTfVxpgQEXUQaT/4rWGguRrbr6UA6mNMdCGHmVIlE0yeVEWaeNf8ykA/ZwEWWwUBkuZS9FhwveFq4wGS4GXETRsKfZP+BqtzkStBKKJgZcRBnMVyoMXVJUbuNeikQx18gMV1pKyZIi91Ikio5ImuZt6qb5UINP2TRPFBXs4UoN3EuRiCJmDbmXYmCGS7uHiyVFomiSM1wmgw42p5vDT5NUb/dSTMkMFxFFR0SDTx3hMlwsKRJFi9Plxv42KwBgTHkBAE6bTxcMuIgymNI0H2prH6crzBwuX+lRyN31RNQn+9uscLkFsgw6DC/JA8CSYrpgwEWUwZSxEFoT5L23CQG4vJtXa42PyPIGa0J4hjQSUd/Jm1ZXDsyBOdvT9cMMV3pgwEWUwUJluEJduRjsOJYVifpH3rS6amAu8k2egIsZrvTAgIsoQwkhItqyRy1LHy7gYuM8UX/IDfNVRTnIMzHDlU4YcBFlKIdLKANNtUqKkiT5BVNZBh10usANdCVJUsqKDLiI+kceCVE1MFcVcDFznA4YcBFlKKsz9EBTwD8QC3aM+j6bg78YiGSNR7tw+ytbAibHh3yMkuHKRUEEJUW3W+APb27Hu18d7N9iKeYYcBFlKPWgUq1SIeA/d0trJETP+5jhIvJ5tn4P/t8nu/HQR99F/Bg5wzW0KDeikuKmxlY8+MF3uPP1r/q3WIo5BlxEGUrdMC9JgaVCz329zHAx4CJStHR59kDcsq8touO77S4c6bABkEuKnu+/DmvwgKvZe7z8X0peDLiIMlSokRAydYZLa8q8TJk2z5IikUIuBW4/0A6HK/wfI3I5sSDbgMJco+8qRXvwgMviDcbabU643RzLksxSMuDiXopE/RdqJITMv4eLJUWi3pADLrvTjW8PdYQ9vlE1EgIA8rPD93C1dXuyaEJ4gi6KH+6lSEQRCTUSQqYOxiI5jgEXkY+692rLvjYcOyj07y0l4CrKAQDkZXl+RbeHKClavAGX/HFhjrHP66Xe4V6KRBQRuWlea3q8TJ3hCnVcsP0UnS633+bXRJlEHXBtbbKEPb6xxdcwD0ApKdqcbjiDlCTbVAGX+mNKPgy4iDKUPBYidOZKVVIM2cPlLSk6/H8pLH5+M46/cx32tXb3Z6lEKalTNT9ra1P4xnlfhssTcMlXKfZ8LjWL1aH5MSUfBlxEGUoOjkL2ZvmNhQhfUrSr/gp3utx4a+sBdNic+Pc3h/u7XKKU0zPDFa6pXc5wyT1cWQadMlS4I0jjfM+SIiUvBlxEGSqipnlDpE3zgVcpfne4U+np2rIvfDmFKN2om9277C7sbO4MeqwQAnt79HABvrJisNEQLCmmDgZcRBnKFs2xEBpXKapnD22JoJxClE5cboEuu+cPkGHFnoxVqD6u1i6HcpVhpTfDBcA3iyvIFYiWbqfmx5R8GHARZahIMlymSDNcxsCrFNW/XL7ab4GLM4Iog6hnZ/1gRBEAYGuIAajyDK6yApPfH0HylYrBRkMww5U6GHARZShlLETIOVy96+FSX6WozmpZHW58fzj8HCKidCEHSAadhKlDBwIInelVNq0uyvW7vSDMLC42zacOBlxEGUoe1xC6pKjX/LgnpaToLVO63QLbvBmuorwsALErK+5p7sLyV7cqV3gRJQO55yo/24AJQzwzmrbss0AI7Uyvsmn1wBy/2+UrFbWGmjpcbqVsCTDDlewYcBFlqEgyXH6DT3uxl+Luo13osDlhMuhw9sQKALFpnG+3OrBw1QY89vEurHyDm/dS8pB7rvKyDBhdng+jXkJbtyPoiJSeIyFkcsClleHqeVUir1JMbgy4iDKUb9J8ZBmu0HO4/EuK8syhcYPMmFw5AEDkG/hGSgiBW178At8f9lz59c62g9zAl5KGPDcr32SAyaDHmPICAMH/8Og5EkKWH6KHq2dGixmu5JaSARf3UiTqP3mEQ6QZrohKij3GQIwfbMb4wZ5yyrYI5hD1xt//tRNvbDkAo15CVVEOHC6Blzfti9rzE/WHkuHyXmU4wft9EGwAqpzhqizyLynK+yl2aAw+ZcCVWL3dSzElA676+nps27YNtbW1iV4KUcqyRjQWQn2VYgQlRe9zyr9UJgwuxOjyfGTpdWi3OZU+lf76z/fNuOvN7QCA2+dWY9FJowAAz9U3Bu2RIYonOeDKz/bsbTh+iGcfRa3REG63wL4e2/rI5JJihy0wmLJ4+8T0Osnvc4qP2tpabNu2DfX19REdn5IBFxH1X0SDT/2uUgwemGWprlIUQii/VCYMMcOo12HcoNDllN44aLGi9ulNcLkFLjhuMBacMAznTR6MHKMe3xzqQMOe1n6/BlF/ySXAfG+GS870apXWD7ZbYXe5YdBJGFTYI8PlfbzW1j5yRmvwgGy/zyk5MeAiylCRNc33MsPldGN/mxVHO+0w6CSlb0X5ZdPPKxUdLjdqn2rAkQ4bxpYXYMVFEyFJEgqyjTh74iAAwPP1jUEf321P7o20HS43djd3Bvxr78fl/pH+P/fnNSJlc7qCbsIcS4nYRF3dNA8Axw4qgE4CDrXbcKjd6nesPBJi8IAcJVslyzcZ/Z5PTW6Sl/u+7E5uFp/MEhZwbd++HfPmzUNFRQXKyspQU1ODp556KlHLIco48g/mUE3zJmPve7jkv+CPKctXHjN+cPBySm+sXLsdn+1uQYHJgIeumIbcLN/mvpdOrwIAvPpFk+Yvp5ca9mLyHW/j1pe/TMqyoxAC8x76BCf98YOAfz9Y8W6vx14IIfCb1V9g8h1vY02Y3rY/v/M1Ji57Gy98FjxY7a/Go12Yesc7uPG5z2P2Glq67E78+MH1mP77dTjcHr+LKjqVHi7P12hulgEjS/MBBH4fbG5sBeC/pY9MmTSvUS6UM1qDCnMgx2m8UjF5JSTg2rRpE6ZPnw6Xy4Xt27fj4MGDqK2txU9/+lMsW7YsEUsiyjiRDT6NMMOlukpxi1JOLFTulz/euq+tz8HOa1804R8f7wQA3HPJZIwoyfO7//hhAzGyNA9ddhde/6LJ774t+9qw5KUvYXe68fR/9uDJT3f3aQ2xVL+rBZsbWyFJQF6WXvln1Evosrvw9IY9vXq+x9fvwrP1jbA73fj16i+UuWg9vb31AP7y7jcAgIc/+j5mwehbWw+g0+7Ca1/sx+4QewpGkxACt728BZv3tsFideKDHYfi8rqALyMlDy4FgAnyHx6qsuLWpjbc8/YOAMAp48oDnkfeS7FTY/NqedDpgFwjzDlGv9so+cQ94BJC4MorrwQArFq1CgMGDIAkSVi4cCEuv/xy/O53v8Pnn38e72URZRxfwBV+U2ogzFgIVdP8NqVh3qzcP66iAHqdhOZOOw5YrJrPEcq3h9pxy4tfAAAWnTQKZ4yvCDhGkiRccrwny/WsqqzY1uXAtU9thM3pxuBCT6/LHa9tQ8Oell6vI5ae86754mmV2HrHmcq/+y6dAgBYvXFvxOW4jbuP4s7XPXPJhgzIgc3pxrVPbQzo8dl5pBO/en6z8vk3hzqwyZttibaPvz2ifPx8DDNpak9+utvvytX13zXH5XUB9VWKqoBLNQAV8HxtLnrS87U5e2wprpw5POB5fE3zwUuK5mwjzN7mfPZxJa+4B1z/+te/sHnzZpx99tkoLCz0u++yyy6D2+3muAeiOJCb5kNtSu2f4Yq0pBiY4co26jG6zFNO6W3jfIfNiWue2IguuwszRhbjptPHBD32oqlDYNBJ2LSnFd8cbIfbLfDL5z9H49FuVA7MwdobTsRZEyrgcAnUPtWQNHO7LFYH1n65HwAwv6bK7745x5ajOC8Lh9pt+GDH4bDPdbjdhuueaoDTLXDOpEF47Rc/wpABOdjd3IVfPf+5Mpqjy+7EtU9uRLvNieOHDcS5kwcDCN0D11cOlxsbdh5VPn+xF8FjXzXsacEdr20DAJwx3pM5Wv/dkbiVk3uWFAH/XsaeX5t/nn8cdD36twBVhksz4PLcVphjQGEOA65kF/eA69133wUATJs2LeA++bZ33nknrmsiykTyWIhQgZT/1j7hM1yH2q04YLFCkoBjB5n9jqlW+rgib5wXQuDXL36B7w53osKcjft/MgUGffB1lBVk45RxZQA8GaO697/Fe9sPIcugw0MLpmFAbhbunjcJI0vzsL/Niuuf3ZQUm2q/urkJ3Q4XjinLV/bdk2UZdLho6hAA/pk7LU6XG794pgEHLTaMKs3DH348CQPzsvDggqnI0uuw7qtDePDD75RS2/YD7SjJN6Hu8qlY8IOhylqC7dvXV1/sbUWn3YUBuUYU52XhoMWGD78OHzz2VXOHDbVPNcDhEjh7YgX+cukUZBl0OGix4fsj8SlnKiVFVcAlfw/sbenGirVfBXxtapEDrlA9XIW5RphzPMfJQRgln7gHXF995U1zDxkScF9paSmMRiN2796N7m7t7Q+IKDqUsRARBFKej0MFZp7j5CBuREme31/2gG/wY28yXI/+eyde/3I/jHoJdZdPRUm+Kexj5Ob5ZzbswZ/WfQ0AuPP8CUrGrSDbiIcWTEOOUY+Pv23Gvd7+mUSSs0rzj6+CJAVmOeSs1/s7DuFQiJLsPW9/jU+/P4q8LD3+dsU05Zf1pMoBWH7+eADAvW/vwK9Xf4GXN+2DXifhgZ9MQbk5G9NHFGFESR467S68/sX+qP7/rf/WU8qbMbIYF07x/Ox/LgaZNABwuQWuf3YT9rdZMbI0D3fPm4xsox7HDxvoXcuRMM8QHfKgUvX3QWGOUZmz9fd/e/oR1V+bWpStfeyugMHBbaqSIjNcyc8Q/pDoam1tBQDk5eUF3CdJEnJzc9HW1obW1lbk5AResQEAFov/D2yTyQSTKfwP4nA27Dwasx8CRL2RZdDhv340HMeUFcTsNWyOKDbN9wjG5ODK77YhoSdt97Rh51GsfMMz3PS351Rj2rCBYR7hMWt0KcrNJhy0eMqFl9ZU4ZIeZbox5QX4w7xJuP6ZTfjrB9+hsaUbWarMmV4HXHJ8FY4fXhT0dVxugVXrdwVtRu9p5qhi/HhaZcDtX+23YPPeNhj1Ei6cGviHKAAcU1aAacMGYuPuFrzYsBfXnXxMwDFvbT2Ahz78DgBw97zJAV87l9ZUoWF3C17YuBfPf7YXAPDrM8fihJHFAHw9cH94czuerd8T8J4BnszRwx99jyMddr/bDToJC04YhomV2oGD3Ds185gSnDCiCH//9068u/0QDrVbUVaQ7Xes2y3w/z7ZhS81AvNZY0pw/nHa75Hs3rd34ONvm5GbpcffFviCzpmjirH+u2as/64ZV8wYHvI51Lbsa8MbW/bjf2aNUoKaSHT2mDQvmzDEjD3eK061vjZ7ylcFbF0Ol9/ncoN8YY4v4Ap1leITn+zC542x2UQ+mR07qABXnzgyas9ns9lgs/naEXrGJMHEPeCKhqoq/y/QpUuXRuXqxl3NnVjdsLffz0MUDd12J/7P2zAdC/JYiFDjHnKMeuSbDLC73CjIDv7LpmcwNmGIOeAYuZyyv82K5g4bikNkqw5ZrKh9ugEut8D5xw3GT2cMC/n/ombQ6zD/+Crc9963mDikEMvOG6953HmTB6NhdwtWrd+FVzc3Bdz/z81NePm6HwaURmV/fudrPPD+txGva3XDXriEUBr7ZfIfeaceWx4ygzf/+Cps3N2C5+sbce1Jo/wyYTuPdOImb/P7f/1oBM6ZNCjg8ZIk4XcXTMC2/RZsbbLgrAkV+O8ev4R+PG0I7nl7Bxq8PXCjy31Bm8PlxjVPbMRnu7UvNvhiXxvWXv+jgAyd1eHCRu8FCjNHFWNUaT6mDh2Ahj2teKlhn7JLgKzu/W9x7ztfa77G6oa9EAK4YIp20PX21gP46weeoPOuH0/yW/+MUSUAvsYn3zfD7Raa/VI9CSHwq+c3Y8fBdmxrsuDRn9VE9DhAPfjU/9fs1KEDsfbLAyG/NtWyjTrodRJcboFOm9Pv+ZQMV074pvkDbVb87ytbI1p7upk9tjSqAdfKlSuxfPnyXj8u7gHXgAEDAACdnYF1dCEEurq6/I7T0tjYCLPZ90MwGtktAJhUWYjfnDUuKs9F1FffHOzA6oa9yma2sRLJWAi9TsLjV02Hw+VGTlb4pnnZeI0MV77JgBEledh5pBNbmyyYNaZU87kcLjd+/vQmHG73DDdd6R1u2hvXzT4GVUW5OPXY8pAB5W/PORZThw1EU6v/e/3eV4ewYddRXPvkRrzy8x8FZDbWbTuoBFv/9aMRKC0I/TPo64PteKlhH/53zRZUDzIr2T6rw6VcRdezWb6ncyYNwvJXt2JXcxf+s/Ookpnqsjux6AlP83vN8IEhf4ZlG/V4+uoT8K9vD+PUY8sD3le5B+6dbQfxXH0jfju3WrlvxdqvlBloi04epQzoFAL487qv8dV+C7bsswRkuTbuboHd6UaFORsjvaM8Lq0ZioY9rXi+vhHXzBqprOOjrw8rZeCFM4ejotCX/fpqvwWvfN6EJS99iWMHmTG2wj+Dt0t1xeXCmcNxnvciANmkykLkZenR2uXAtv2WkGU82ea9bdhxsB0A8P6Ow7j/vW9xw6mjwz4O8PVc9Qy4FpwwDANzszDn2LKQX5sySZKQl6WHxepEu9WJcu+vPiGEks0qzAk/FqKpzfM1PiDXGBDkprue2yX115IlS7B48WLlc4vFEpAI0hL3gOvYY48FAOzbFziI7/Dhw3A4HBg2bFjQciIAmM1mv4ArWsZVmDGuIvrPS9QbDXtasLphLw609X58QqSEEBGNhQAQUSmvZx/Y+MHa30fjB5ux80gntjS1BQ24/vDGdmzYdRQFJgMeXDDVb7hppLKNelx8fAQ/APW6gF/MgCebNPf+f2NXcxduemEz/rZgmpLZ2N3ciV8+/zkA4GczhuF/VUFJMG63QGuXA+9tP4Rrn9qI135+IgpzjXh720G0dTswuDAbJ47Wfj9keSYDzp08GM/WN+L5+kacMLIYQgjc+tKX2HHQ2/z+k6kwhrioAPA0WM+dFPj/rP5/f2fbQby0aR9uOXMcsgw6/HNzEx77eBcA4N5LJuP0HmM5vtpvwT83N+HZ+j2YWDnR777133l6pmaOKlYCKzl4/P5IJ+p3tWD6iCLsbenCDc9ughCeUlvP7I/LLXC0045/fXMEi57ciFd+/kMlq9Ntd2GR94rLacMG4tazjw34/zLqdfjByGK8t/0QPvmuOaKA67l6z+yzYcW52N3chf9792scN3QATgrytSsTQihzs3oGXNlGvWZpOZR8kwEWq9PvYoYOmxNyS5c52xdwBctwHfKW2IcX52VcwBVtfW1jinvT/Jw5cwAAGzduDLhPvu20006L65qIkskg71/1ByzWmF1BJwdbQOirDyOl7n+qHJgT9Ior3wBU7Z6H17/YrzQT//Hiycpk7ngbmJeFv17uubLvnW0H8dBHnjKV5xd7A9qtTkwZOgC3nRM+2AIAnU7Cny85DlVFOWg82o1fesczyL/Q502rDNjSRYvc7/P6l/vR1u3AE5/uxprPm6DXSaj7yRSUmbPDPEN4J48tRVmBCUc77Vj31UF8c7Adv1ntmYF27cmjAoItwJed++fnTQFbCX0sN8yPKlZuyzMZlKDv2fo9sDldqH2qAS1dDkwYYtYstel1Ev5y6RQMLszGziOduPmFzRBCeK+4/NJ7xWUW6n4yVdnbs6eZ3jXIQWAonTYn/vm5p9R810WTcNn0oRACuOHZTdgbZhP2bodLCYZ6XjzSF3kaoyHkjaqz9DpkG3Vhm+YPe7cTKguTjaXYiXvAdeKJJ2Ly5MlYu3Yt2tr8m/eeeeYZ6HQ61NbWxntZREmjrCBb6dk4EqM5UeqAK1yGKxI6naQEXVoN87IJIfZU9Aw39ZSErpk1EmdOCPzFHk+TqwYov/jveWsHPv72CH67Zgu+2m9BsRyQhSjH9lSYa8SDl0+DyaDDe9sP4bY1W/Dxt82QJESUjQOAKVUDMKY8HzanG3e+tg2/886Z+s2Z4/CDkcVhHh0Zg16Hed4MzOPrd2HRk54ZaDNHFeNXp2nPQJsxshhVRTlotznxxhbfFY4WqwNf7G0F4GmYV5vvvZp07Zf7sWT1l9i8tw2FOZ73KFiprSgvC3WXT4VRL+GtrQfxt4++x5P/2YOXvFdc3n/ZVL8yZMA6vQHXhp1H4QgzB+z1L/ej0+7C8OJcnDCyCEvPrcakykK0djlw3VMNIfcslEdCSBKQG6IUH6n87MDhp21dvv4tSZJgzg49FuKQd1ujMjMDrkSJe8AlSRIee+wxZeJ8W5tnq49Vq1bhqaeewm9/+1scd9xx8V4WUdLQ6yTlr9D9MSoryiMhJAkw6nvXHxWM3AsWrJyovm93cxe+PdSBptZuNLV2Y3dzJxY92YBOuwsnjCzCzWeMjcqa+uuy6VWYN60SbgH81+P1WN2wFzoJuP+yKRhUGLztIZgJQwrxuwsmAPCMrQCAH44qQVWEPSbqafovbNyrzJm6+sQRvV5LKPJr/GfnUWUG2n2XBZ+BptNJuGRa4JT/+p1H4RbA8OJcDBng/35NqRqA0WX5sDrceGnTPkgS8H+XHhf2vZgydCBuP9cTCN/95nbc8aqnEfyWM8b6ZdG0HFthxsBcIzrtLiUQDEYe1XGxd1RHtlGPv14+FQNyjfhibxuWv7ot6GOV/q0sQ6/7D7Xka0yb9zXMe+4Ll+GSS4o9rwql+EnIXopTpkxBfX09JEnCmDFjUFZWhgceeACPP/54nzr/idKN/Ff6/tbYNM6rR0JE4xcC4OvjCtUbMzAvS/nFe+qfPsTMu97DzLvew0l//ADfHupAudmE+y+bGnK4aTxJkoQ7L5iA6kFmZcbYTWeMDcjW9MYlx1fhsum+jFa4ZvmeLppaqQTJ8pypaJ1D2fCSPJww0jMSw6iX8NcF4WegzTu+EjrJkz36/nAHAHU5MfD9kiTJ7//9+lNGY/bYsojWt+AHQ3HRlCFwC8DhEjhzfAX+Z1b4q9B0OkkJyuTZYFq+PdSOz3a3QK+TlGwfAFQOzMV9l06BJHkC5mDDWzs1ZnD1R16WVknR1zCv/m+wpvlD3pJiuAs8KHYS9lNt3LhxWL16NQ4ePIjDhw/js88+w4IFCxK1HKKkMtibPYlVhqvbWw7JieAqqUidM3EQqgeZMX1E8NlVAPCTHwxFtlGHLL3/v6FFuXhwwbSk+4WQbdTjoQXTMGGIGQtOGIpro9BwvPTc8Th5bCmmjyjC6eMDNywOpSgvC9fMGoVRpXl+c6ai7fpTRmNQYTZWXDgxYPq9lkGFOUozuTznS+6V+uEx2pmni6dVoXqQGRdOGYIb5kR29R/gCdZ+f+FEzBlXhh8eU4w/Xjwp4qBTDv4+DtHHJa9/9thSlPfoi5s1phTnevvPvgySJesIMoOrr3z7KfrKmOqhpwCUpvl2q1Oz91MpKSbZ91cmSck5XETpTslwtcUmw9XlbWzuyxWAwSw/f0JEx9XOPga1swMHdyazocW5eO0XJ0bt+bKNeqy6cnqfH3/TGWNxU4zLrjOPKcEnS+b06jHza4bi/R2HsbphL6784XBsP+AZqXBCkP6ywlwj1t7Qt/c1J0uPRxfW9PpxcuN8w+5WWB2ugH4xu9ON1Rs9Adf8mqGazzFogOf7s6VLO5sUbAZXXxUoPVy+11OPhAB8gRfgKWkW5vqPMjnczpJioiVH3p6I/AxSAq7YZLi6vJesh5qtRdRbc44tQ0l+Fg6327BirWcbt3EVBRFtyRQvI0vyUGHOht3lxkaNIa7vbT+I5k47SgtMmD1We/xDkfcq3JZOu+b9coZLbnbvLzlT1qnKcPUMuLIMOiVj3bOPS30BDpvmE4cBF1ESGhTrkqKS4WLARdFj1Ovw46menqdXvCMVZmr0byWSJElKlutjjX0V5ab/edMqg/YSDszzBFxHu0IHXHlRyiDnaTTNy2Mh5KZ5IHjjfHOnDW7huUimOE97ZAvFHgMuoiQklyxiNfxULilGs4eLCAgccTEzzJWDiaA0zn/n3zjf1NqNj7yN8D23YFILl+GKeklRYw5XW48MF+ALvno2zstXKBbnmZLmgpRMlJI9XDU1NdDr9aitreXMLkpLcknxoHf4aSRDMXuDGS6KlWPK8lEzfCDqd7VAJwHTR4a+iCIR5KtMv9jbit+s/gJyv/33hzvhFsAPRhRhhHcbIi0RZ7iidZViqLEQqt6tYBmuw2yYj4m6ujrU1dXB5Qo+k00tJQOu+vr6mGztQ5QsSvNN0EmA09t70fNKqf6Se7ii2TRPJLts+lDU72rBtGED/QKCZDFkQA5Glebhu8OdfnPDZJdN126Wlw30NqS3dGo3zUe/h0ujpKiR4VJGQ/QIuOSREOzfii456WOxWFBYGH6rKP60JUpCBr0O5eZs7G+zYn+bNfoBlzwWghkuioELpwyBUa/DcVUDEr2UoP56+TS8s+0ARI8JCiUFJs39NdWKvBmuDpsTNqcrYLeGaJcU8yMtKWZrZ7h8Q08ZcCUSAy6iJFVR6A24Wruj/ouLJUWKJUmScG6YoCXRxlYUYGxFQZ8ea842QicBbgG0djlQbu4ZcHkHn0bp+8sXcKmuUrT6tvZR1hVk+Kk8gyvZZtxlGnbPESWpWA4/VZrmGXAR9ZpOJ2Ggt3H+qEbjfLtSUoxOOVUuKbarAintpvlwPVycwZVIDLiIklQsh58qg0+NTHIT9YXcON+i0TjvKylGOcNld0EIAZvTpWw1pd0077+BtdLDxQxXQvGnLVGSiuXw0257dLceIco0vtEQgY3znVG/StHzfepyC9icbrR7Z3BJkm8KPQCYvR8HNs1z6GkyYIaLKEnJw09jMYuLJUWi/hmY58kmaY2GiPpYCNXVxB02p9KjlW8yQKcaGaM1FkIIodpHkSXFRGLARZSkKmKZ4XKwaZ6oP+QrFbWGn8oBV0GUAi6dTlIa8DusTs3+LfXn6qZ5S7cTdqen/Mim+cRiwEWUpAYP8B9+Gk2+SfPsKiDqi1BN89EuKaqfq8MWPOAya8zhkvu3zNmGgI26Kb4YcBElqZ7DT6Opi2MhiPqlKEjTvM3pgsPl+QMpmgGXehaXRWPKPKAefOqE8A4Y8/VvsZyYaAy4iJKUPPwUiH5Z0TdpngEXUV8Ey3B1WH1XCEZrDhfgm1rfaXdqTpkHfBkuu8utXMXIbX2SR0oGXDU1NaiurkZdXV2il0IUU0ofV2t0R0OwaZ6of+Sm+Z4ZLnk4aY5RH9WNouXG+XarExZvUCdvVu07Rq/suyqXHeWSIvu3oq+urg7V1dWoqamJ6PiUbODgXoqUKQYVZmMTop/h8k2aT8kfAUQJNzDIWIhoX6Eoy1NNmw/WwyVJEszZBrR0OWCxOlBRmM1tfWKot3sppmSGiyhTKKMhLNELuIQQLCkS9VOwHq5Oe3SHnsrk51P3cPUMuNS3+TJcHAmRLBhwESUxefhpUxRLijanG/JFjywpEvWNPGm+y+6C1eHb41Du4Yp2hkvu4WpXXaVoDhFwWXqUFDn0NPEYcBElsVgMP5XLiQCQy8vEifqkwGSAwdsvpc5ydSjb+sSqpBh8LAQQuJ8iN65OHgy4iJJYLIafdnn/Gs/S66La1EuUSSRJUrJc6isVO2MUcOVnqcZCWLXHQgCBs7gOW1hSTBb8aUuUxGIx/FTeR5HlRKL+0dpPMdZN8x1hSopyENbW7US33YV273pYUkw8BlxESSwWw0859JQoOrT2U1RKitmx6eHqsDlh6fa8RrimeXkGV7ZRF7VthqjvGHARJTGDXqeUAqJVVuQMLqLo0NpPMWYlRTnDZVWVFHMCX0O+zWJ1+BrmC7IhSVLAsRRfDLiIktwgb1nxQFt0rlTsZoaLKCq0ps13eAef5kV5xp1cUjxgscK7a49mD5c6w8WG+eTCgIsoyflGQ0Q3w5XLjauJ+kUOuFo1Sop5UZ/D5Q24vJluk0GnuRm1eizEIYuc4WLAlQwYcBEluWgPP+1i0zxRVChXKXb5mublkmJBtHu4vAGX03vxjFb/FqBumneohp4y4EoGKRlwcS9FyiTRHn7a7R0LEe2/wIkyTZG8n2KnVoYr2iVF/+9XrSsUAV8g1m51+gIuM0dCxAL3UiRKM9Eefqo0zbOkSNQvWj1cnTEKuHo24QfNcLGHK264lyJRmon28FOOhSCKDq39FGM9aV4WLOCSb++wObHfmxVnSTE5MOAiSnJySTFaw0+7uXE1UVSoM1zCe+lgrMZCGPU6mAy+X9nmID1i6t6x3c1dADhlPlkw4CJKcmUFvuGnzVEYfso5XETRIWe4bE630hsZqwxXz+cMluEy6nXI835v211uAJwynywYcBElOfXw06YolBU5h4soOnKz9MjyZp2OdtrhdLlhdXiCnGj3cPV8zmBN84B/MKbXScoWRJRYDLiIUkA0h5/6MlxsmifqD0mS/PZT7PQOPQVicxVwJBkuwD8YK8nPgk7HKfPJgAEXUQqI5vDTTrmHS2NoIhH1zkBV43yH93srS6+DyRDbgCtUhkt9H/u3kgcDLqIUUGGO3vBTlhSJokeZxdVlV42EiM33lvp5tbb10bqPVygmDwZcRClgsLekuK8ldElxX2s3fvSH97Bi7VdBj2HTPFH0DFBdqdhujc0MLllehCVF9X1smE8eDLiIUkD1YM+g34++OaxkqLQ88clu7G3pxltbDwQ9Rr6aKpc9XET95uvhssdsJIRMPfLBnBP8NdT3lbKkmDRSMuDi1j6UaU4YUYyqohy0W514Y8t+zWMcLjde3LgXgGfKdDBdnMNFFDW+/RRjH3DlZfUhw8WSYsz0dmuflAy46uvrsW3bNtTW1iZ6KURxodNJuGRaFQDgufpGzWPe334IR7xzuizdDmUQY08sKRJFT1GuvJ+iI2b7KMr6VFJkwBUztbW12LZtG+rr6yM6PiUDLqJMNO/4Sugk4D87j2Lnkc6A+9WBmFv4BjD2xKZ5ouhRMlyd9pgOPVU/r07yz3b15Nc0z42rkwYDLqIUMagwB7PGlAIAnv/MP8t10GLF+zsOAQAk78gdizUw4LI73XB6twfK5ebVRP2m3k8x1iXFfG8PlznHGHK2ljrDxY2rkwcDLqIUcmmNp6z44sa9cHq37ZA/dwugZvhAFHt/AbR1BfZxqRvuWVIk6j/1food3sGnsS4phhoJAfjP4SrNZ8CVLBIScHV1deHmm2+GwWDAsmXLErEEopR0yrhyFOdl4XC7De/vOAwAcLuFkvGaXzNU+WGr1Tjf5fD8BW7QScqWJETUd3KGq7XLgQ6b53suP0ZzuEryPa9VHmbUg3x/hTmb3+dJJO5n4s0338T48eOxevVquFzBL28nokBZBh1+PK0SgK9n6z87j2J3cxfyTQacPbFCKSdYrBoBF/u3iKJKznDZXW4ctHguWolVhusHI4qx7NxqLDtvfMjjhhXn4e55k/B/lx4Xk3VQ38S1ieOTTz7BokWLUFdXh8OHD+PKK6+M58sTpYVLjq/Cwx99j/d3HMIhixXP1e8BAJw7eTByswxKuUErw+VrmGf/FlE05GTpkWPUo9vhQuPRLgC+Xqto0+skLPzhiIiOveT4qpisgfourhmu0aNHY+vWrTjnnHPi+bJEaeWYsnwcP2wgXG6BRz/eiTe2eIacyv1dSoZLq6TIDBdR1Mllxb3enSBi1TRPqS2uAVdJSQny8vLi+ZJEaekSb3D18Effw+Z0Y1xFASZVFgLwTZnWDrg8PVxsmCeKngHeWVzKHC5mkEkDu+mIUtA5EwchL0sPebbp/JoqSN55EIUhmuY5g4so+uQMlyxWPVyU2lLyq8Jisfh9bjKZYDLx0lfKHHkmA847bjCe2dCILL0OFxw3RLlP7uHSmsPlmzKfkt/6RElJbpyXFcSoh4uSg81mg81mUz7vGZME0+uvihUrVsBut0d8/MKFCzF8+PDevkxIVVX+zYBLly7leAnKOFf9cATWfnkAF0+rVKZdA6EzXF3yxtVGZriIooUZrsyycuVKLF++vNeP61PA1dkZuK1IMCeffHLUA67GxkaYzWblc2a3KBONLi/A5qWnB9weqmm+mxtXE0VdzwxXXozmcFFyWLJkCRYvXqx8brFYAhJBWnodcHV0dPT2IVFnNpv9Ai4i8gk5+JQbVxNFXVGe/+R3XqWY3vraxsSmeaI0E2rwKZvmiaJPXdLXSUAOS/akgQEXUZoJNfi0UxkLwb/AiaKlSFVSzDMZlCuGidQYcBGlGTnDZXW4YXP6b5/FwadE0afOcLGcSMHEPeCaMWMGKioqcMMNNwAA7rnnHlRUVKCysjLeSyFKSwXZBsh/YFu6/UdDsKRIFH1FDLgoAnH/yvjkk0/i/ZJEGUWnk5BvMqDd6kRbtwOlBb7mTqVpnj0mRFEjT5oHOBKCgmNJkSgNBWuc5+bVRNFnMuiR580aM8NFwTDgIkpDwRrnuxycw0UUC3IfF2dwUTAMuIjSULDhp5zDRRQbch9XvskY5kjKVAy4iNKQOcdT1ugZcLFpnig25Gnz+cxwURApGXDV1NSguroadXV1iV4KUVIKtp9iF3u4iGKiSCkp8nsrU9TV1aG6uho1NTURHZ+SXxn19fXc2ocoBF/TPMdCEMXDzFHFeP3L/agZXpTopVCc1NbWora2FhaLBYWFhWGPT8mAi4hCU5rmu3wZLqfLDbvLDYABF1G0XXx8FS6YMgRGfUoWjigO+JVBlIYKcwPHQnQ5fFPn2TRPFH0MtigUfnUQpSGtsRByOVGvk5DFXwxERHHFn7pEaUiraV5pmDfqubkuEVGcMeAiSkNmjUnzXXZPAz3LiURE8ceAiygNFXrncKmb5nmFIhFR4jDgIkpDcoar3eaE2y0AqKfM8+JkIqJ4Y8BFlIbkpnkhPEEXoB56ygwXEVG8MeAiSkPZRj1MBs+3t7y9Tzc3riYiShgGXERpqueVikpJ0ciAi4go3lIy4OJeikThKVcqygGXjSVFIqJo4V6KRARAvZ9ijwwXm+aJiPqtt3sppmSGi4jCM2d7R0PIGS72cBERJQwDLqI0pWS4uj2BFudwERElDgMuojRlDtY0z4CLiCjuGHARpamePVzdqr0UiYgovhhwEaWpwLEQ3h4uE5vmiYjijQEXUZqSp833LCmyh4uIKP4YcBGlqZ5zuLodDLiIiBKFARdRmjLn9BgLoUyaZ0mRiCjeGHARpSlf0zzHQhARJVpKBlzc2ocovKBN8wy4iIj6jVv7EBEAXw+X3emG1eHiHC4ioiji1j5EBADIzzJAJ3k+bu1ywOZ0AwByuZciEVHcMeAiSlM6nYQC72iIAxarcjtLikRE8ceAiyiNyX1cB9q6AQCSBJgM/LYnIoo3/uQlSmPyaIgDbZ4MV65RD0mSErkkIqKMxICLKI3JGa793pJiDvu3iIgSggEXURqTA66DcoaL/VtERAnBgIsojcn7KTYx4CIiSigGXERpzNc0L5cUGXARESUCAy6iNCYPP5XHQjDDRUSUGAy4iNKYeto8wI2riYgSJSUDLu6lSBQZuaQoyzMxw0VEFA3cS5GIFOZs/29xlhSJiKKDeykSkaJnhoslRSKixGDARZTGzD0CLma4iIgSgwEXURoLyHAx4CIiSoi4BlybNm3Cz3/+c4wZMwbFxcUwm82YMmUK/vCHP8Bms8VzKUQZQR58KmOGi4goMeIWcDU0NGDq1Kmor6/HmjVr0NzcjEOHDuGKK67Ab37zG5xyyimw2+3xWg5RRsgy6JBj9AVZDLiIiBIjbgGX2+2ZA/T000+juroaAJCdnY3Fixdj3rx5WL9+Pf7xj3/EazlEGUNdVuTm1UREiRG3gGvw4MFYsWIFRo0aFXDfiSeeCABYv359vJZDlDHMOb4gK9fIDBcRUSLENeBasmSJ5n1yKbG4uDheyyHKGOoMF0uKRESJkRRXKcqZrcsuuyzBKyFKP+rGeV6lSESUGAlv6NixYwdee+01/PSnP8X06dMjeozFYvH73GQywWQyxWJ5RCnPP8OV8G95IqKUZrPZ/CYr9IxJgun1T98VK1b06mrChQsXYvjw4Zr3Wa1W/PSnP8WECRN6tS9iVVWV3+dLly7FsmXLIn48USYxs6RIRBQ1K1euxPLly3v9uD4FXJ2dnREff/LJJ2sGXE6nE5dccgksFgs++ugj5OfnR/ycjY2NfnspMrtFFJw5hyVFIqJoWbJkCRYvXqx8brFYAhJBWnodcHV0dPT2IQHsdjvmz5+PnTt34oMPPkBpaWmvHm82m7l5NVGE2DRPRBQ9fW1jinvTvM1mw0UXXYQ9e/bggw8+QHl5OQCgvb0dX375ZbyXQ5T2zNm+v6uyDQy4iIgSIa4BV3d3N84991wcPXoU7733nt8YiI0bN+Lcc8+N53KIMoKc4cox6qHTSQleDRFRZorbJUsdHR2YO3cu1q9fj+uvvx5//vOf/e7ftWtXvJZClFHkHi6WE4mIEiduAde6devw4YcfAgDuvfdezWOGDRsWr+UQZYzRZfnIMepRPZh9j0REiSIJIUSiFxEpi8WCwsJCtLW1sWmeqBfauhzINelh1CfFrGMiorQRaWzCKYhEGaAw1xj+ICIiihn+uUtEREQUYwy4iIiIiGIsJQOumpoaVFdX92o7ICIiIqJoqaurQ3V1NWpqaiI6nk3zRERERH0UaWySkhkuIiIiolTCgIuIiIgoxhhw9WCz2bBs2TLYbLZEL4W8eE6SD89J8uE5SU48L8knUeeEPVwJeA3qHZ6T5MNzknx4TpITz0vyifY5YQ9XkovHFZbxuoozXa4W5TlJPun0fqXLOQHS5/3iOcnM10gUBlwJkk5fuOnyDcJzknzS6f1Kl3MCpM/7xXOSma+RKCm1tY9c/bRYLDF7Dfm5Y/kaAOByudLiNeLxOjwnyfc66XRO4vU66XJOgPR4v+L1Gun0vZIurxHtcyI/T7gOrZTq4dq7dy+qqqoSvQwiIiIiP42NjaisrAx6f0oFXG63G01NTSgoKIAkSYleDhEREWU4IQTa29sxePBg6HTBO7VSKuAiIiIiSkVsmiciIiKKMQZcRERERDHGgMtr+/btmDdvHioqKlBWVoaamho89dRTiV5WWrPZbHjuuecwd+5cVFRUoLi4GKWlpTjnnHOwbt06zcdYrVYsXboUo0ePRllZGYYNG4Ybb7wRbW1tcV595vj5z38OSZKwcOFCzft5TuLD5XLhr3/9K2bMmIGhQ4diwIABGDVqFC699FJs3rzZ71iek9hzuVx4/PHHMWPGDAwePBjl5eWYNGkSfv/736OjoyPgeJ6T2NiyZQtmzpwJSZKwa9euoMf15f1fu3YtZs2ahbKyMpSXl+Oss87Chg0b+r5YQaKhoUEUFBSICy64QLS0tAi32y0ee+wxodPpxNKlSxO9vLT1i1/8QgAQS5YsERaLRQghxO7du8Wpp54qAIj777/f73i73S5mz54tysrKxIYNG4QQQnz99ddi9OjRYuLEiaKtrS3u/w/p7p133hGSJAkA4mc/+1nA/Twn8dHd3S1OO+00MWPGDLFlyxYhhBAOh0Pcc889AoB47LHHlGN5TuLj6quvFgDEHXfcIWw2m3C73eK1114TOTk5YsqUKcJmsynH8pxEX3d3t7j11ltFUVGRKCkpEQDEzp07NY/ty/v/yCOPCADizjvvFA6HQ3R1dYlrr71WGI1G8fbbb/dpzRkfcLndbjF58mRRUFAgWltb/e674oorhE6nE5s2bUrM4tJcbW2tOPHEEwNuP3z4sMjJyREmk0m0tLQot997770CgPjHP/7hd/y7774rAIhf/vKXsV5yRmlpaRGVlZXiiiuuCBpw8ZzExw033CCKi4v9vh9kF110kXj11VeVz3lOYm/v3r0CgDjuuOMC7rvxxhsFAPHMM88ot/GcRN8111wjzj//fNHY2ChOOumkkAFXb9//vXv3ipycHDFr1iy/2x0Ohxg5cqQYMmSI6Orq6vWaMz7g+vDDDwUAMX/+/ID71q5dKwCIq6++OgErS3+vvvqqePPNNzXvmzJligAg3n33XeW2kSNHCr1eL9rb2/2Odbvdory8XBQUFIju7u6YrjmTXH755WLu3Lni/fffDxpw8ZzE3sGDB4XBYBA33HBDRMfznMTep59+KgCISy65JOC+uro6AUDcddddym08J9G3a9cu5eNwAVdv3//ly5cLAOLBBx8MeK5bbrlFABBPPvlkr9ec8T1c7777LgBg2rRpAffJt73zzjtxXVOmmDt3Ls444wzN++x2OwCguLgYALBz5058//33GDt2LPLz8/2OlSQJU6dORXt7Oz799NPYLjpDrF69Gm+99RYeeeSRoMfwnMTHmjVr4HQ6ccIJJ4Q9luckPsaMGYPs7Gx89dVXAffJt02cOBEAz0msDBs2LKLj+vL+xyouyPiAS/7mGDJkSMB9paWlMBqN2L17N7q7u+O9tIx15MgRfPPNN6iursakSZMAhD5P6tu3b98en0WmsYMHD2LRokV48MEHUVFREfQ4npP42LhxIwCgsLAQt99+O8aPH4/S0lKMHj0aixYtwp49e5RjeU7iY+DAgbj//vuxfft23HrrrbBYLLDb7XjhhRfwyCOP4LLLLsPZZ58NgOck0fry/od6TH/OV8YHXK2trQCAvLy8gPskSUJubq7fcRR79913H5xOJ+677z5lR4FQ50l9e0tLS1zWmM6uvvpqnH766Zg3b17I43hO4qOpqQkA8LOf/Qx79uzBunXr0NTUhLq6OqxZswZTp07Fjh07APCcxNPVV1+NF198Ec8++ywKCwuRn5+P//7v/8aKFSvw9NNPK8fxnCRWX97/UI/pz/nK+ICLksunn36Ku+66C3fccQfmzJmT6OVknEcffRQNDQ144IEHEr0U8pKz6/n5+fj73/+OQYMGwWg04vTTT8ef/vQnNDc348Ybb0zsIjOMEALXXHMNLrzwQixatAgtLS1ob2/H008/jT/+8Y84++yz+Uc6Bcj4gGvAgAEAgM7OzoD7hBDo6uryO45iZ9u2bZg7dy6uv/563HbbbX73hTpP6tsHDhwY0zWms127dmHx4sV49NFHI3ofeU7iQ/6Les6cOTAYDH73nXfeeQCAdevWwWq18pzEyapVq/Dwww9jwYIFuOWWWzBgwACYTCacffbZ+Mtf/oI33nhDCYJ5ThKrL+9/qMf053xlfMB17LHHAgD27dsXcN/hw4fhcDgwbNgw5OTkxHtpGWXLli045ZRTcNVVV+Gee+4JuD/UeVLfPm7cuNgtMs2tXbsWbrcbCxcuREVFhfLvoosuAgA899xzym2vvPIKz0mcDB8+HABQUlIScF9+fj7y8vLgdDpx9OhRnpM4efPNNwFAMwsv3/byyy8D4M+uROvL+x/qMf05XxkfcMnfHHJjqpp822mnnRbXNWWaTZs2Yfbs2Vi0aBHuvvtu5fZdu3Yp/SsjRozAyJEj8fXXXwdMcRZCYNOmTSgoKIjoSi7Sdt1116G9vR0HDhzw+/fSSy8BAObPn6/cdv755/OcxMmsWbMAAAcOHAi4r6urC52dnTAYDCgqKuI5iRP5vZV7TNXk2zo6OuByuXhOEqwv73+s4oKMD7hOPPFETJ48GWvXrg0Y8f/MM89Ap9OhtrY2QatLf/X19ZgzZw5uvvlmLFu2zO++ZcuW4eGHH1Y+r62thdPpxAsvvOB33Pvvv48DBw7g6quvRnZ2djyWTV48J7F3zjnnoLKyEu+8844yLkX2xhtvAADOOuss5X3mOYk9+Zfzhx9+GHDfRx99BAA4/vjjodfrAfCcJFpv3/+rrroKOTk5eOaZZ/yOdzqdePHFFzFkyBBceOGFvV9Iryd3paGGhgaRn58vLrzwQtHa2uq3tc/tt9+e6OWlrY8//liYzWYxbtw4sXTp0oB/kydP9ttayW63i5NPPjlge4YxY8Zwe4wYCjX4lOckPt5++22RlZUlFixYIJqbm4Xb7Rbr168XlZWVYtCgQeL7779XjuU5ib2WlhYxduxYodfrxUMPPSSsVqtwu93iX//6lxg6dKgwmUziww8/VI7nOYmtcINP+/L+P/zwwwKA+P3vfy+cTqfo7u4W1157rTAYDOKtt97q0zoZcHl99dVX4qKLLhJlZWWipKRETJs2TTzxxBOJXlZaO//88wWAkP967mXZ3d0tbr/9djFy5EhRWloqqqqqxA033BCwLRP135133inKy8vFwIEDBQCRnZ0tysvLxcSJE/2O4zmJj88++0ycd955oqioSAwYMECMGDFC/OIXvxAHDhwIOJbnJPZaW1vFrbfeKsaPHy8KCgpEYWGhqKysFJdffrnYvHlzwPE8J9H1n//8R5SXl4vy8nJhNBoFAFFSUiLKy8vF4sWLA47vy/v/+uuvix/96EeipKRElJaWijPOOEN8+umnfV6zJIQQvc+LEREREVGkMr6Hi4iIiCjWGHARERERxRgDLiIiIqIYY8BFREREFGMMuIiIiIhijAEXERERUYwx4CIiIiKKMQZcRERERDHGgIuIiIgoxhhwEREREcUYAy4iIiKiGGPARURERBRjDLiIiIiIYuz/A+fLhPHKLQYnAAAAAElFTkSuQmCC", + "text/plain": [ + "
" + ] + }, + "metadata": {}, + "output_type": "display_data" + } + ], + "source": [ + "plt.plot(g-data)" + ] + }, + { + "cell_type": "code", + "execution_count": 9, + "metadata": {}, + "outputs": [ + { + "data": { + "text/plain": [ + "[]" + ] + }, + "execution_count": 9, + "metadata": {}, + "output_type": "execute_result" + }, + { + "data": { + "image/png": "iVBORw0KGgoAAAANSUhEUgAAAncAAAFeCAYAAADngTkBAAAAOXRFWHRTb2Z0d2FyZQBNYXRwbG90bGliIHZlcnNpb24zLjkuMiwgaHR0cHM6Ly9tYXRwbG90bGliLm9yZy8hTgPZAAAACXBIWXMAAA9hAAAPYQGoP6dpAABafElEQVR4nO3deXxU5b0/8M+ZJXsySUgmk40IyJKwhBAHJEgBEbwCBaRoS6mIFK6UWKjW6/3h5aVYq9grFaSkVbEsP0yxLihSFgV+SHElkrApYZFtCCEESCb7MjPP74/JGTJMQjIhyZnMfN4v50V4znPO+c4cE755VkkIIUBEREREXkGldABERERE1H6Y3BERERF5ESZ3RERERF6EyR0RERGRF2FyR0RERORFmNwREREReREmd0REREReRKN0AJ7KZrPh0qVLCA0NhSRJSodDREREPk4IgfLycsTFxUGlar59jsldMy5duoTExESlwyAiIiJyYjKZkJCQ0OxxJnfNCA0NBWD/AMPCwjrkHmVlZUhMTOzQewCA0WhETk5Oh12/M+/T0ffgM/G8e3TWMwG84/PqrHt40/eKt9yDz8Tz7tPez0S+npyjNIfJXTPkrtiwsLAO/welo++hVqs7/D101n06673wmXjWPYDO+V70ls+rs54J4B3fK95yDxmfiefdp72fSUvDxTihwgdkZmZ6zX066710ND4Tz+QtnxefiW/eo7N40+flTc+lMUkIIZQOwhOVlZVBp9PBbDZ3aLdsR9+D3MNn4nn4TDwTn4vn4TPxPO39TFp7PbbctcBoNCIlJQVZWVntfm1/f388//zz8Pf3b/drU9vwmXgePhPPxOfiefhMPE97PZOsrCykpKTAaDS2qj5b7prB34CIiIjIk7DljoiIiMgH3VZyd+zYMWRkZECSJJw7d65N19i4cSOMRiP0ej0MBgMeeughnDx5stn6+fn5mD59OgwGA/R6PYxGI7Kzs5utX1NTg+effx69e/eGXq9HUlISfve738FsNrcpXiIiIiJP1qbkrqamBv/zP/+DUaNG4dSpU22++ZIlSzB79mxkZmaiqKgI+fn5sFgsMBqNOHLkiEv9vLw8DB06FFarFfn5+SgqKkJmZiZmzZqFpUuXutSvr6/HhAkT8MYbb+Af//gHrly5gt27d2P79u0YOXIkysrK2hw7ERERkUcSbfD444+LKVOmCJPJJEaNGiUAiLNnz7p1je+++05IkiRmzZrlVF5aWipCQ0NFenq6sNlsjnKbzSZSU1NFaGioKC0tdTrnkUceESqVSuTl5TmV//nPfxYAxNq1a53K9+zZIwCIJ598stn4zGazACDMZrNb74uIiIioI7Q2N2lTy93ixYvx8ccf33Lri5ZkZWVBCIEZM2Y4let0OjzwwAM4ePAgvvrqK0f5/v37cfjwYUyYMAE6nc7pnBkzZsBms7nMaM3KyoJarcZDDz3kVD5mzBjExMTg7bffRk1NTZvfAxEREZGnaVNyl5SUdNs33rNnDwAgPT3d5ZhctmvXrjbXP3v2LM6cOYO+ffsiJCTEqb4kSRgyZAjKy8vxzTff3OY7ISIiIvIcimw/VlVVhQsXLsDPzw/R0dEux+Pj4wHYJ0/Ijh8/7nSssejoaGi1Wpw/fx7V1dUIDAy8Zf2b7zF69OhmY715XJ6/v3+7rCFUUFqNqVlf3vZ1iABALUm4p3cUfjO6F3pFh7R8AhGRB/jy9FWs/+ocKmosqKq3orrOgqo6K2otNqVDa5MArQr7n7m33a5XW1uL2tpax99bO1dAkeSutLQUABAUFNTk8eDgYABASUmJyznyscYkSUJQUBDMZjNKS0sRGBh4y/rN3aMpiYmJTn9//vnnm5y84S6bTaC4vLblikSt9MHBi/gw9yImDIjFb0b3woB4XcsnEREppM5iw+/fO4zLZd4zPCpQq27X6y1btgwvvPCC2+cpktx1JSaTyWmhwPZa+TsmLAA7Fo1sl2sRlVTWYd1X57DrhyJsO1qIbUcLMbpvNJ6blIKebMkjIg/08aECXC6rgT7UH/8zMRlBfhoE+akR6KdGgEYNSVI6Qve1d8yLFy/GU0895fh7WVmZS6NTUxRJ7sLDwwHYu2ebUllZCQCIiIhwOUc+1pgQwnEtud6t6jd3j6aEhYV1yA4VfhoVkmO58wW1n4w7o3Dicjn+9vlpfHL4Ej4/UYzL5lzsWDQSUlf8KUlEXstmE3hj348AgLkje2DK4KaHUPm6tg4FU2SHiqCgIHTv3h11dXUoLi52OV5QUAAA6Nevn6MsOTnZ6VhjxcXFqK+vR1JSEgIDA1us39w9iLq6voZQrPxFGvb8fjT8NSrkXy7H0QIu2E1EnuWzH4pwprgSYQEazBjaXelwvI5i24+NHTsWAHDw4EGXY3LZuHHj2ly/R48e6NmzJ06ePImKigqn+kII5OXlITQ0FHffffdtvhMiz9MjKhj39zcAAN7/7qLC0RAR3SCEwN8aWu0eGZ6E0ACtwhF5nw5P7oQQMJlMLuWZmZmQJAmbNm1yKjebzdixYweGDBmCjIwMR/nIkSORmpqK7du3u2wdtmnTJqhUKmRmZrrcw2Kx4P3333cq37t3Ly5fvoy5c+ciICDgdt8ikUd66C77OpRbDhWgpt6qcDRERHbfnLmOw6ZS+GtUmJ3RQ+lwvFKHJ3cLFy5E9+7dsWjRIqfy9PR0PPvss3jnnXewYcMGCCFgNpsxe/ZsAMDatWudxglJkoR169ZBCIHHHnsMZrMZQgisX78e2dnZWLJkCQYPHux0j9/+9rcYPXo0/s//+T/IyckBAJw6dQq/+c1vMHDgwHaZ9UrkqTJ6RSFOF4CyGgt2/VCkdDhERADgaLV7+K5ERIe2zyRFctam5O7AgQMwGAwwGAyOXSSMRiMMBgN+//vfO9VNTExEUFBQk7M7/vjHP2LdunVYtWoVYmJi0KdPH6jVauTk5CA1NdWlflpaGnJyciBJEvr06QO9Xo/Vq1djw4YNTU4V1mq12LFjB+bPn49f/OIX0Ov1GDt2LB544AHs37+/QyZKEHkKtUrCz9LtrXfvH2TXLBEp71iBGf8+WQy1SsJ//qSn0uF4LUkIIZQOwhOVlZVBp9PBbDYzCaQu6/y1Sox69XNIEvDlf9+LuPBApUMiIh/2xD9y8a8jhZgyOA6v/yJN6XC6nNbmJopNqCCijpfULRhDe0RCCGBzLlvviEg5569VYvvRQgDA/FG9FI7GuzG5a4HRaERKSgqysrKUDoWoTR5q6Jr94OBFsKGeiJSyZv8Z2AQwum8013l1U1ZWFlJSUmA0GltVn92yzWC3LHmLyloLhr60G5V1Vrz3+HAM7RGpdEhE5GOsNoH0P+5CaVU93vn1MNzTO0rpkLokdssSEQAg2F+DiYNiAQDvf+e6LBERUUc7fLEUpVX1CA3Q4O6e/AWzozG5I/IBD91ln62+7WghKmstCkdDRL7m8xP23ah+0jsaGjVTj47GT5jIB9yVFIEeUcGoqrM6BjQTEXWWfSeuAABG9Y1WOBLfwOSOyAdIkoTpDRMrPuSsWSLqRFcranGkYY/r0X2Y3HUGJndEPuKng+IAADnnSlBeU69wNETkK/59shhCACmxYdCHccvPzsDkjshHdO8WhKRuQbDaBL45c13pcIjIR8jj7UazS7bTMLkj8iH33GlffuCLU8UKR0JEvsBqE/j3KTm50yscje9gctcCLmJM3mRkw9pS+09fVTgSIvIFjZdAGdI9XOlwuix3FzHWdHA8XV5OTg4XMSavMbxXFFQScKa4EpdKq7nXLBF1KLlLdmTvKC6BchsyMzORmZnpWMS4JfykiXyILlCLQQnhAIAvTrH1jog6lrwEyug+7JLtTEzuiHwMu2aJqDNca7QECte361xM7oh8jDyp4svTV2GzcWtpIuoY/z5lXwIlOTYMMVwCpVMxuSPyMWndIxDkp8b1yjr8UFimdDhE5KW4BIpymNwR+Rg/jQp39+wGAPiCXbNE1AGsNoF/n2xI7rgrRadjckfkg26sd8fkjoja35GLpSipqkeovwZDkiKUDsfnMLkj8kHypIoD566jpt6qcDRE5G32NnTJ3tM7ClougdLp+Im3gIsYkze6Ux+CmDB/1FlsyDnHrciIqH3ta+iSHcNdKdoFFzFuZ1zEmLyRJEm4585ofJh7EV+cuoqRvTkmhojaR2WtBccalkAZ0dBLQLeHixgTUas41rvjuDsiakeHTKWw2gTiwwMRz11wFMHkjshHjWiYVPFDYRmuVtQqHA0ReQt5qMddd3AihVKY3BH5qOhQf/QzhAKwL2hMRNQevjtXAgC4645IhSPxXUzuiHyY3DXLJVGIqD1YrDbkXrAnd0a23CmGyR2RD7unYSLFVz9eUzgSIvIGxwvLUVVnRWiABn30oUqH47OY3BH5sLuSIqBWSSgorcal0mqlwyGiLs4x3i4pAiqVpHA0vovJHZEPC/bXIDnW/tv1wfMlCkdDRF2d/HOE4+2UxeSOyMfdlWT/IczkjohuhxDCqeWOlMPkrgXcoYK8XXrDD+HvznOnCiJqO9P1alwpr4VWLSE1MVzpcLwKd6hoZ9yhgrydnNwdLyxHZa0Fwf78sUBE7pNb7QbG6xCgVSscjXfhDhVE5Ja48EDE6QJgtQkcNpUqHQ4RdVFy67+R4+0U16bkLj8/H9OnT4fBYIBer4fRaER2drZb1ygqKsLChQvRq1cvREZGIioqClOmTMHBgwebPWfz5s249957ERkZiYiICKSkpODll19Gba3r6vrnzp2DWq2GwWBo8vWPf/zD7fdN5K3SG34Yf8dxd0TURjlcvNhjuJ3c5eXlYejQobBarcjPz0dRUREyMzMxa9YsLF26tFXXOHv2LNLS0rB161a8++67uH79Oo4fPw4AyMjIwO7du13OWbx4MX72s5/BaDTiwoULuHr1Kl5++WUsW7YMkydPhtVqdTknMTERly9fbvL1y1/+0t23TuS17nKMu2NyR0Tuu15Zh9NXKgDcGOpBynEruRNC4LHHHgMArF+/HuHh4ZAkCbNnz8bMmTPx4osv4tChQy1eZ+HChSgsLMTrr7/uGBwYHR2NjRs3IjAwEHPmzHFqjTt48CBeeeUVpKWl4U9/+hNCQkKgVqsxdepUPP300/jss8/w5ptvuvNWiKgR+Ydx3vkSWG1C4WiIqKuRZ9vfqQ9BZLCfwtGQW8nd/v37cfjwYUyYMMFlQN+MGTNgs9lanFVaU1ODnTt3AgDGjx/vdCwsLAwjR46EyWTCtm3bHOUfffRRk/UBYNKkSQCAN954w523QkSN9DOEIshPjfJaC05dKVc6HCLqYr47J4+3Y6udJ3AruduzZw8AID093eWYXLZr165bXuPatWuwWCwICQlBQECAy3GDwQDAnkjKioqKANhb95qrf/ToUZjN5ta8DSK6iUatQlr3cAA3Nv0mImqtG+vbcbydJ3AruZPHxcXHx7sci46Ohlarxfnz51Fd3fw2RpGRkVCr1aioqEBVVZXL8StXrgCwj8uT6fV6ADeSvKbq33wOAFRVVeGpp55C//79ERMTg549e+KXv/wlcnJybvU2nZSVlTm9mpq8QeQN0rmYMRG1QU29FUcL7I0rnCnbvmpra13ykNZwK7krLS0FAAQHB7sckyQJQUFBTvWaEhgYiDFjxgCAU9crAFRUVODLL790fC2bMGECAGDHjh0Qwnk8kNzFe/M5AFBSUgKDwYAvvvgCly5dwscffwyTyYThw4dj/fr1t3inNyQmJkKn0zley5Yta9V5RF0NFzMmorY4ctGMequAPtQfiZGBSofjVZYtW+aUgyQmJrbqPEXWuVu5ciV0Oh2efPJJ7N27FxaLBSaTCTNnzoRabV/4sHECOWLECMydOxfHjh3DE088geLiYtTU1OCDDz7AihUrHOP/Gp+TmJiIwsJCPPPMM4iIiIBarcagQYOwZcsWhISEYMGCBU22BN7MZDLBbDY7XosXL27nT4PIM6R1D4ckNawyX1ajdDhE1EXknLuxvp0kSQpH410WL17slIOYTKZWnedWchceHg4AqKysdDkmhHB0s8r1mtO/f3/k5uZi/PjxmDNnDgwGAyZOnIhhw4Zh+fLlAIDY2Finc9566y2sWbMGeXl5SE5ORu/evZGdnY0dO3YgLi7O5Ry1Wo2oqCiXe0dGRuLee+9FdXU1tm/f3uJ7DgsLc3r5+/u3eA5RVxQWoEXfmFAA7JolotaTJ1PcxckU7c7f398lD2kNt/YZSk5OBgAUFBS4HCsuLkZ9fT2SkpIQGNhys2zPnj2xdu1al/IVK1YAAIYMGeJULkkS5s6di7lz57qcU1BQgNjYWMfkipbIyWBhYWGr6hP5irvuiED+5XJ8d74EDwyMbfkEIvJpNptw/DLIyRSew62Wu7FjxwJAk7tIyGXjxo27rYC+/fZbaDQaTJ06tVX18/PzUVZWhoceesipfP369c1OnLh06RKAGxM1iMgunYsZE5Ebzl2rRFmNBf4aFfrFhiodDjVwK7kbOXIkUlNTsX37dpdlRzZt2gSVSoXMzExHmRCiyf7hLVu2YPLkyS7lBQUF+OSTT7BgwQKXxOv+++93mjwh++tf/4qQkBA8/fTTTuXr16/HunXrXOqXlpbi888/h5+fH/7jP/7j1m+YyMfIv3l/X2BGTb3rri9ERI0dvlgKABgQr4NWze3qPYVbT0KSJKxbt86xU4XZbIYQAuvXr0d2djaWLFmCwYMHO+ovXLgQ3bt3x6JFi5yuU1JSgq1bt2LlypWObcPy8vIwceJEDB8+vMkZqSdOnMAzzzyDM2fOALCP+/vTn/6ENWvWIDs7u8kZJGvWrMHbb7+Nuro6AMCPP/6I6dOno7S0FK+++ioSEhLceftEXi8hIhD6UH9YbAKHTaVKh0NEHu6wyd7Qk5oQrmwg5MTtNDstLQ05OTmQJAl9+vSBXq/H6tWrsWHDBrzwwgtOdRMTExEUFOSSeKWlpeHhhx/GqlWr0K1bNyQkJGD+/PmYN28ePv30U8eSKo39+te/RnBwMIYNG4aYmBgMGDAAP/zwA3Jzc5tsBXzzzTexZMkSvP322+jRowciIyORkZGBkJAQ7NmzBwsXLnT3rRN5PUmSHIOi2TVLRC2RW+5SE3W3rkidShI3LxxHAOyLF+t0OpjN5lbPTiHyBm/vP4M/bjuOe/vpsXa2UelwiMhD1VlsGLD0U9RZbNj3X6OR1M11DVxqX63NTdhBTkRO7mpYYT73QonLouFERLITl8tRZ7EhPEiL7pGuPW6kHCZ3LTAajUhJSUFWVpbSoRB1ipTYMPipVSitqsf5a65bBBIRAcChhi7ZQQnhXLy4g2VlZSElJQVGY+t6U9xa584X5eTksFuWfIqfRoWUuDAcMpXi8MVS3BHFrhYiciVPuhqcwPF2HS0zMxOZmZmObtmWsOWOiFwMTgwHcGMmHBHRzeTkLrXh5wV5DiZ3RORCnvkmz4QjImqsvKYep4srANi7ZcmzMLkjIhfyD+tjBWbUW23KBkNEHudogRlCAPHhgYgO5Z7rnobJHRG56NEtGKEBGtRabDhZVK50OETkYeQhG4PZJeuRmNwRkQuVSnKsOM9xd0R0syOOmbKcTOGJmNwRUZMc4+64DRkR3YSTKTwbkzsiapI87o6TKoiosStlNbhkroFKAgbGs+XOEzG5awEXMSZfJY+lOVlUjqo6i7LBEJHHOHzRPlSjtz4Uwf5cLrczcBHjdsZFjMlXxYQFwBAWgMtlNThWUIahPSKVDomIPMCNLlm22nUWLmJMRO2G4+6I6GbyUA2Ot/NcTO6IqFkcd0dEjdls4kbLHRcv9lhM7oioWY5tyJjcERGAc9cqUVZjgZ9Ghb6GUKXDoWYwuSOiZg1sWMPKdL0a1ypqFY6GiJR2pGEyxYC4MGjVTCE8FZ8METUrLECLntHBAIAjBVzMmMjXHeL6dl0CkzsiuqXBjp0qShWNg4iUJw/R4LZjno3JHRHdkvwbOpM7It9Wb7Xh+0tlAG5MtiLPxOSuBVzEmHydI7m7aIYQQtlgiEgxJ4vKUWexITRAgzu6BSkdjk/hIsbtjIsYk69Ljg2FVi3hemUdLpZUIzGSP9SJfNGxAnkyhQ6SJCkcjW/hIsZE1K78NWokx9p/weGSKES+61iBvUt2QDwbPDwdkzsialEqJ1UQ+byjcstdPLcd83RM7oioRY3H3RGR77FYbTheaG+5G8jkzuMxuSOiFqU2LGZ89KIZVhsnVRD5mlNXKlBrsSHEX4M7ugUrHQ61gMkdEbWoV3QIgv3UqK634sfiCqXDIaJOJnfJ9o8Lg0rFyRSejskdEbVIpZLQP+5G6x0R+ZbvOd6uS2FyR0StIv9QP8ptyIh8jvx9z/F2XQOTOyJqlYEJ9uUPmNwR+RaL1YYfCuVlUJjcdQVM7lrAHSqI7AbGhwMAfrhUxkkVRD7kx+JK1NTbEOynRs8oTqZQAneoaGfcoYLIrmdUMIL91Kiss0+q6BMTqnRIRNQJ5J0pUjiZQjHcoYKIOgQnVRD5Ji5e3PW0KbnLz8/H9OnTYTAYoNfrYTQakZ2d7dY1ioqKsHDhQvTq1QuRkZGIiorClClTcPDgwWbP2bx5M+69915ERkYiIiICKSkpePnll1FbW9vsORs3boTRaIRer4fBYMBDDz2EkydPuhUrEdlxUgWR7znGyRRdjtvJXV5eHoYOHQqr1Yr8/HwUFRUhMzMTs2bNwtKlS1t1jbNnzyItLQ1bt27Fu+++i+vXr+P48eMAgIyMDOzevdvlnMWLF+NnP/sZjEYjLly4gKtXr+Lll1/GsmXLMHnyZFitVpdzlixZgtmzZyMzMxNFRUXIz8+HxWKB0WjEkSNH3H3rRD6PkyqIfIvVJvD9Je5M0eUIN9hsNpGamipCQ0NFaWmp07FHHnlEqFQqkZeX1+J1Jk2aJACILVu2OJWbzWah0+lEYmKiqKmpcZR/9913AoBIS0tzudbSpUsFAJGVleVU/t133wlJksSsWbOcyktLS0VoaKhIT08XNput2RjNZrMAIMxmc4vvh8hXnCoqF0n//S/Rb8kOYbE2//1DRN7h5OUyfs97kNbmJm613O3fvx+HDx/GhAkTXAb0zZgxAzabrcVZpTU1Ndi5cycAYPz48U7HwsLCMHLkSJhMJmzbts1R/tFHHzVZHwAmTZoEAHjjjTecyrOysiCEwIwZM5zKdTodHnjgARw8eBBfffXVLWMlImfypAruVEHkG45dujGZQs3JFF2GW8ndnj17AADp6ekux+SyXbt23fIa165dg8ViQUhICAICAlyOGwwGAPZEUlZUVAQAiI6Obrb+0aNHYTbf6Cpqj1iJyBknVRD5lqMX2SXbFbmV3Mnj4uLj412ORUdHQ6vV4vz586iurm72GpGRkVCr1aioqEBVVZXL8StXrgCwj8uT6fV6ADeSvKbqNz6nqqoKFy5cgJ+fX5MJoRx/fn5+s3HKysrKnF63mrxB5As4qYLIdxzjTFlF1dbWuuQhreFWcldaWgoACA52XcRQkiQEBQU51WtKYGAgxowZAwBOXa8AUFFRgS+//NLxtWzChAkAgB07dkAI58VT5S7exufI95fjuZkcf0lJSbNxyhITE6HT6RyvZcuWtXgOkTcblMDkjsgX2GwC31/iTFklLVu2zCkHSUxMbNV5iqxzt3LlSuh0Ojz55JPYu3cvLBYLTCYTZs6cCbVaDcA5gRwxYgTmzp2LY8eO4YknnkBxcTFqamrwwQcfYMWKFY7xf00lnbfLZDLBbDY7XosXL273exB1JfJv8Nypgsi7nblaico6KwK0KvSK5s4USli8eLFTDmIymVp1nlvJXXh4OACgsrLS5ZgQwtHNKtdrTv/+/ZGbm4vx48djzpw5MBgMmDhxIoYNG4bly5cDAGJjY53Oeeutt7BmzRrk5eUhOTkZvXv3RnZ2Nnbs2IG4uDinc+T7N9Xt2zj+iIiIFt9zWFiY08vf37/Fc4i8GSdVEPkGudUuOTYMGjX3PFCCv7+/Sx7SGm5tP5acnAwAKCgocDlWXFyM+vp6JCUlITAwsMVr9ezZE2vXrnUpX7FiBQBgyJAhTuWSJGHu3LmYO3euyzkFBQWIjY11TK4ICgpC9+7dceHCBRQXF7uMu5Pj79evX4txEpEzeVLFgXPXceSimduQEXkpedIUu2S7HrdS8bFjxwJAk7tIyGXjxo27rYC+/fZbaDQaTJ06tVX18/PzUVZWhoceeqjTYyXyVXLX7DGOuyPyWtx2rOtyK7kbOXIkUlNTsX37dqdlRwBg06ZNUKlUyMzMdJQJIZrsH96yZQsmT57sUl5QUIBPPvkECxYscMyQld1///1Okydkf/3rXxESEoKnn37aqTwzMxOSJGHTpk1O5WazGTt27MCQIUOQkZHR8psmIhecVEHk3Ww2gR+4M0WX5VZyJ0kS1q1bByEEHnvsMZjNZgghsH79emRnZ2PJkiUYPHiwo/7ChQvRvXt3LFq0yOk6JSUl2Lp1K1auXOnYNiwvLw8TJ07E8OHDm5yReuLECTzzzDM4c+YMAPu4uT/96U9Ys2YNsrOzXWaQpKen49lnn8U777yDDRs2QAgBs9mM2bNnAwDWrl0LSeKCjERt0XhShcVqUzgaImpvF65XobzWAj+NCnfqQ5QOh9zk9gjJtLQ05OTkQJIk9OnTB3q9HqtXr8aGDRvwwgsvONVNTExEUFCQS+KVlpaGhx9+GKtWrUK3bt2QkJCA+fPnY968efj000+bXMLk17/+NYKDgzFs2DDExMRgwIAB+OGHH5Cbm9tkKyAA/PGPf8S6deuwatUqxMTEoE+fPlCr1cjJyUFqaqq7b52IGjhPqnCdYEVEXZu8M0WyIRRaTqbociRx88JxBMC+eLFOp4PZbG717BQiX/LwG1/jwLnrWP5QKqanJygdDhG1oz/tzMffPv8RM4Z2x7JpA5UOhxq0NjdhOk5EbcJJFUTe68bOFGzc6IqY3LXAaDQiJSUFWVlZSodC5FE4qYLIOwlxYzKFvJc0KSsrKwspKSkwGo2tqu/WOne+KCcnh92yRE24eVIFFzkl8g6Xy2pwrbIOapWEfgauY+kJMjMzkZmZ6eiWbQl/GhNRmzSeVHHmKidVEHmL7wvsrXZ3RocgQKtWOBpqCyZ3RNQm8k4VAMfdEXkTeaZsf46367KY3BFRm8k//Dnujsh7fM/xdl0ekzsiarMBDT/85W4cIur6vpdnysax5a6rYnJHRG0mT6r4/pIZNhuXzCTq6q5X1uGSuQYAkMLkrstickdEbdYrOhgBWhUq66w4e42TKoi6uu8bxtvd0S0IoQFahaOhtmJyR0RtplGrkBxr/+2ekyqIuj7HeLt4jrfrypjctYCLGBPdmmPc3SWOuyPq6uRf0vqzS9ajcBHjdsZFjIlubWDDb/hHL7Lljqirk3emGMCZsh6FixgTUaeSl0M5dskMITipgqirqqi1OBYkZ8td18bkjohuS299KPzUKpTXWGC6Xq10OETURscL7a12sboAdAvxVzgauh1M7ojotvhpVOgXa99/kosZE3VdHG/nPZjcEdFtc2xDdonJHVFXxZ0pvAeTOyK6bQPiuRwKUVfHljvvweSOiG6bPGP2WAEnVRB1RTX1Vpy+UgHgxs4z1HUxuSOi29YnJhQalYSSqnrH1kVE1HWcLCqHxSYQEaRFrC5A6XDoNjG5I6LbFqBVo3dMw6QKrndH1OXI4+0GxOsgSZLC0dDtYnLXAu5QQdQ6AxvG3X3PSRVEXY483i6F4+08EneoaGfcoYKodQbE6/Dedxc5qYKoC/qeO1N4NO5QQUSKkJdPOFpQxkkVRF2IxWpzLGDMmbLegckdEbWLlNgwqCTgakUtrpTXKh0OEbXSmauVqLXYEOynxh3dgpUOh9oBkzsiaheBfmrcqQ8BwPXuiLqSxuPtVCpOpvAGTO6IqN0McHTNMrkj6iq4M4X3YXJHRO2mv2Mx4zKFIyGi1uLOFN6HyR0RtRt5pwouh0LUNdhsAj80WuOOvAOTOyJqN/IaWYXmGlyt4KQKIk9nKqlCea0FfhqVY8wsdX1M7lrARYyJWi/EX4OeUfbZdpxUQeT55PF2/Qyh0KqZEngqLmLczriIMZF7BsTrcOZqJY4VmDG6r17pcIjoFjjermvgIsZEpCh53B1nzBJ5vmOcKeuV2pTc5efnY/r06TAYDNDr9TAajcjOznbrGkVFRVi4cCF69eqFyMhIREVFYcqUKTh48GCz52zZsgX33nsvEhISEBMTg5SUFDz99NMoLi52qfv555/Dz88PBoOhydf+/fvdft9E1LL+DXvMcsYskWcTQuD7hl/COJnCu7id3OXl5WHo0KGwWq3Iz89HUVERMjMzMWvWLCxdurRV1zh79izS0tKwdetWvPvuu7h+/TqOHz8OAMjIyMDu3btdznnppZcwdepU9OnTx3Hft99+G++88w7S09Nx7do1l3MyMjJw+fLlJl8jR450960TUSvI/0gUlFajpLJO4WiIqDlFZbW4VlkHtUpCP0Oo0uFQO3IruRNC4LHHHgMArF+/HuHh4ZAkCbNnz8bMmTPx4osv4tChQy1eZ+HChSgsLMTrr7/uGBwYHR2NjRs3IjAwEHPmzEFt7Y2ZdnV1dVi2bBmio6Pxl7/8BSEh9hk9GRkZWLx4MUwmE9asWePOWyGiDhIWoMUd3YIAsGuWyJPJSxbdGR2CAK1a4WioPbmV3O3fvx+HDx/GhAkTXAb0zZgxAzabrcVZpTU1Ndi5cycAYPz48U7HwsLCMHLkSJhMJmzbts1RXlJSgsrKSvTo0QNardbpnN69ewMAzp8/785bIaIOJLfeHeN6d0QeSx46wckU3set5G7Pnj0AgPT0dJdjctmuXbtueY1r167BYrEgJCQEAQEBLscNBgMAOI2J0+v1iImJwY8//oi6OuduHrk7d+DAgW68EyLqSI7kji13RB5Lbrnrz/F2Xset5E5OpOLj412ORUdHQ6vV4vz586iurm72GpGRkVCr1aioqEBVVZXL8StXrgCwj8uTSZKEv//976itrcXjjz+O4uJiWCwW7N69G6+88gpGjx6NX//6101ea968eejXrx/0ej369u2LefPm4cSJE61+z2VlZU6vxt3FRNQ0zpgl8nw39pRly52nqq2tdclDWsOt5K60tBQAEBwc7HJMkiQEBQU51WtKYGAgxowZAwBOXa8AUFFRgS+//NLxdWMTJ07Ezp07kZubC71ej+DgYPz0pz/FvHnz8Nlnn8Hf39/lXiaTCcOGDcPBgwdRUFCAdevW4euvv0ZaWlqLLYyyxMRE6HQ6x2vZsmWtOo/Ilw1oWFbBdL0a5qp6haMhopuVVNahoNTeEJPC5M5jLVu2zCkHSUxMbNV5iqxzt3LlSuh0Ojz55JPYu3cvLBYLTCYTZs6cCbXaPqjz5gTyxRdfxKhRozB27FhcuXIFlZWV2L17Nz788EPcc889uHDhglP94cOH48KFC5g7dy6Cg4Oh1WqRkZGBDz/8EHV1dXj00Udb1QpnMplgNpsdr8WLF7ffB0HkpXRBWiRGBgLguDsiTyS32iV1C0JYgLaF2qSUxYsXO+UgJpOpVee5ldyFh4cDACorK12OCSEc3axyveb0798fubm5GD9+PObMmQODwYCJEydi2LBhWL58OQAgNjbWUX/v3r147rnnMGLECLz22muIjo6GRqPBiBEjsHHjRhw4cACzZs1yuoe/vz8iIiJc7t23b18MGjQIhYWF+Oqrr1p8z2FhYU6vploIicgVu2aJPJf8S9cALl7s0fz9/V3ykNZwa/ux5ORkAEBBQYHLseLiYtTX1yMpKQmBgYEtXqtnz55Yu3atS/mKFSsAAEOGDHGUybNrx44d61J/6NChCAkJwb59+3D9+nVERka2eO+4uDjk5eWhsLCwxbpE1DYD4nXYfvQykzsiDyS33LFL1ju51XInJ1dN7SIhl40bN+62Avr222+h0WgwdepUR5k8/k6SpCbPUansb8NsvvGPyMqVK3Hq1Kkm61+6dAmAfRYuEXUMuUXgeyZ3RB6HO1N4N7eSu5EjRyI1NRXbt293SqQAYNOmTVCpVMjMzHSUCSGa7B/esmULJk+e7FJeUFCATz75BAsWLHBKvO6++24AwL59+1zOOXToEMrKymAwGJCUlOQoX7lyJT766COX+qdPn8axY8fQrVs3ZGRktOJdE1FbyN2y565VoayGkyqIPEVFrQVnr9mHV3GmrHdyK7mTJAnr1q1z7FRhNpshhMD69euRnZ2NJUuWYPDgwY76CxcuRPfu3bFo0SKn65SUlGDr1q1YuXIlrFYrAPu2ZhMnTsTw4cNdZqTOmDEDI0aMwJ49e7B06VLHmL+jR4/i0UcfhSRJeO211xwteLKXXnoJH3/8MaxWK4QQOHToEB566CEIIfDWW285ZvcSUfuLCPZDfHjDpAq23hF5jOOFZRACMIQFICqE48i9kduzZdPS0pCTkwNJktCnTx/o9XqsXr0aGzZswAsvvOBUNzExEUFBQS5Td9PS0vDwww9j1apV6NatGxISEjB//nzMmzcPn376qUvSpdFoHGvabd26FbGxsYiIiMC4cePQs2dP7Nu3DzNmzHA6Z/PmzZg/fz7+8Ic/ICEhAZGRkZg0aRKSk5Nx4MABTJs2zd23TkRuklvvvi9o3dpMRNTx5F+22GrnvSQhhFA6CE9UVlYGnU4Hs9nc6tkpRORs9f87heWfncTk1DismpGmdDhEBODp9w/jg4MXsXBsbzw1ro/S4ZAbWpubKLLOHRH5Bm5DRuR52HLn/ZjctcBoNCIlJQVZWVlKh0LU5cjJ3ZmrlSjnpAoixdXUW3H6in0FCs6U7TqysrKQkpICo9HYqvpurXPni3JyctgtS9RGUSH+iNUFoNBcgx8ulWFYz25Kh0Tk004WlcNiEwgP0iJOF6B0ONRKmZmZyMzMdHTLtoQtd0TUoQZwpwoijyF/Hw6M1zW7dix1fUzuiKhDOWbMXuKMWSKlHePixT6ByR0RdagB8fZhDWy5I1Je45Y78l5M7oioQ8ktBD8WV6Cy1qJwNES+q9ZixYnL5QBubA9I3onJHRF1KH1oAGLC/CEE8EMhu2aJlHKqqAL1VgFdoBaJkYFKh0MdiMkdEXW4gfHhAIAjF9k1S6SUo47xdmGcTOHlmNwRUYcblNAwY/ZiqbKBEPmwo5xM4TOY3LWAixgT3T45uTvCSRVEijnGyRRdFhcxbmdcxJjo9sn/mJwprkRZTT3CArQKR0TkW+osNuQXcjJFV8VFjInI43QL8Ud8uH0AN/eZJep8p66Uo85qQ2iABkndgpQOhzoYkzsi6hQ3xt0xuSPqbI7Fi+O4M4UvYHJHRJ1iUEI4AI67I1KCY/HiBHbJ+gImd0TUKRyTKjhjlqjTHS2wrzHJmbK+gckdEXUKeRC36Xo1SirrFI6GyHfUW2043rCAOGfK+gYmd0TUKXRBWtzRMJCb+8wSdZ7TVypQZ7EhxF+DpEhOpvAFTO6IqNPI4+6Y3BF1Hvn7rX9cGFQqTqbwBUzuiKjTyOPuDptKlQ2EyIdw8WLfw+SuBdyhgqj9yP+4sOWOqPNwpmzXxx0q2hl3qCBqP/3jdZAkoNBcgyvlNdCHBigdEpFXszSaTMGZsl0Xd6ggIo8V4q/BndEhALhTBVFnOF1cgZp6G4L91OjRLVjpcKiTMLkjok410DHujskdUUc71rC+Xf84HSdT+BAmd0TUqQZx3B1Rp3FsO8YuWZ/C5I6IOtVAeRuyi2YIIZQNhsjL3ZhMwbHjvoTJHRF1qv5xYVCrJFytqMXlshqlwyHyWlabwA+XuDOFL2JyR0SdKkCrRp+YUAAcd0fUkX4srkB1vRVBfmr0iApROhzqREzuiKjT3Rh3V6psIERe7MjFGztTqDmZwqcwuWsBFzEman/yjFn5Hx8ian/yTjCpDeNcqeviIsbtjIsYE7W/1EZ7zAohIElsVSBqb0culgIABiWGKxoH3T4uYkxEHq+PIQR+ahVKq+phul6tdDhEXqfWYsUPDTtTDGbLnc9pU3KXn5+P6dOnw2AwQK/Xw2g0Ijs7261rFBUVYeHChejVqxciIyMRFRWFKVOm4ODBg82es2XLFtx7771ISEhATEwMUlJS8PTTT6O4uLjJ+jabDa+//joGDBgAvV6PuLg4zJkzB4WFhW7FSkTty1+jRnKsfVLFoYbWBSJqP/mF5ai3CkQEaZEYGah0ONTJ3E7u8vLyMHToUFitVuTn56OoqAiZmZmYNWsWli5d2qprnD17Fmlpadi6dSveffddXL9+HcePHwcAZGRkYPfu3S7nvPTSS5g6dSr69OnjuO/bb7+Nd955B+np6bh27ZrLOY8++iieffZZvPrqq7hy5QoOHjyI/Px8GI1GXLx40d23TkTtKLWhq+jQhVJF4yDyRoflLtmEcA578EXCDTabTaSmporQ0FBRWlrqdOyRRx4RKpVK5OXltXidSZMmCQBiy5YtTuVms1nodDqRmJgoampqHOW1tbUiODhYREdHi7q6OqdzVq5cKQCIZcuWOZV/+OGHAoB47rnnnMpPnTolJEkSDz744C1jNJvNAoAwm80tvh8ict/mXJNI+u9/iQezvlA6FCKv89Q/D4mk//6X+POn+UqHQu2otbmJWy13+/fvx+HDhzFhwgSXAX0zZsyAzWZrcVZpTU0Ndu7cCQAYP36807GwsDCMHDkSJpMJ27Ztc5SXlJSgsrISPXr0gFardTqnd+/eAIDz5887la9evdoRV2N33nknjEYjPv74Y7beESlocGIEAODYpTLUWWwKR0PkXY40arkj3+NWcrdnzx4AQHp6ussxuWzXrl23vMa1a9dgsVgQEhKCgIAAl+MGgwGAPZGU6fV6xMTE4Mcff0RdXZ1Tfbk7d+DAgY6yuro6fPHFFwgODkbfvn2bjFUI0WT3LxF1jju6BSE8SIs6iw35l8uUDofIa1TUWnC6uAIAMCiRO1P4IreSOzmRio+PdzkWHR0NrVaL8+fPo7q6+dlvkZGRUKvVqKioQFVVlcvxK1euALCPy5NJkoS///3vqK2txeOPP47i4mJYLBbs3r0br7zyCkaPHo1f//rXjvqnT59GfX094uLimhxrIMefn5/f4nsuKytzetXW1rZ4DhG1TJIkx5IoeRx3R9Rujl40QwggThcAfahrIwp1HbW1tS55SGu4ldyVlpYCAIKDg12OSZKEoKAgp3pNCQwMxJgxYwDAqesVACoqKvDll186vm5s4sSJ2LlzJ3Jzc6HX6xEcHIyf/vSnmDdvHj777DP4+/u3Ks7G5SUlJc3GKUtMTIROp3O8li1b1uI5RNQ6g+VJFQ2LrRLR7ZMnU6Ryfbsub9myZU45SGJiYqvOU2Sdu5UrV0Kn0+HJJ5/E3r17YbFYYDKZMHPmTKjVagCuidmLL76IUaNGYezYsbhy5QoqKyuxe/dufPjhh7jnnntw4cKFDonVZDLBbDY7XosXL+6Q+xD5osHdwwEwuSNqTxxv5z0WL17slIOYTKZWnedWchceHg4AqKysdDkmhHB0s8r1mtO/f3/k5uZi/PjxmDNnDgwGAyZOnIhhw4Zh+fLlAIDY2FhH/b179+K5557DiBEj8NprryE6OhoajQYjRozAxo0bceDAAcyaNatVcTYuj4iIaPE9h4WFOb0atxAS0e2RF1c9e7USpVV1t65MRK1y2GTf1i+V4+26PH9/f5c8pDXc2n4sOTkZAFBQUOByrLi4GPX19UhKSkJgYMsLJvbs2RNr1651KV+xYgUAYMiQIY4yeXbt2LFjXeoPHToUISEh2LdvH65fv47IyEjceeed0Gq1uHTpUpNbG8nx9+vXr8U4iajjRAT7oUdUMM5ercQhUylG99UrHRJRl1ZcXouC0mpIEjAwnsmdr3Kr5U5OrpraRUIuGzdu3G0F9O2330Kj0WDq1KmOMnn8XXMLMapU9rdhNtt/W/Hz88M999yDyspKnDhxoslYJUnCfffdd1uxEtHtk8fdcVIF0e2Tu2R7RgUjNEB768rktdxK7kaOHInU1FRs377dkUjJNm3aBJVKhczMTEeZEKLJ/uEtW7Zg8uTJLuUFBQX45JNPsGDBAuj1N36Dv/vuuwEA+/btcznn0KFDKCsrg8FgQFJSkqP8iSeecMTV2OnTp5GTk4OpU6ciISGhNW+biDoQJ1UQtZ/DF+Uu2XBlAyFFuZXcSZKEdevWQQiBxx57DGazGUIIrF+/HtnZ2ViyZAkGDx7sqL9w4UJ0794dixYtcrpOSUkJtm7dipUrV8JqtQKwb2s2ceJEDB8+3GVG6owZMzBixAjs2bMHS5cudYyZO3r0KB599FFIkoTXXnvN0YIHANOmTcPMmTOxfPlyR7fu5cuXMWvWLMTFxWHVqlXuvHUi6iBycnf4YimEEMoGQ9TFyS13qZxM4dPcni2blpaGnJwcSJKEPn36QK/XY/Xq1diwYQNeeOEFp7qJiYkICgpymbqblpaGhx9+GKtWrUK3bt2QkJCA+fPnY968efj0008dS6rINBqNY027rVu3IjY2FhERERg3bhx69uyJffv2uexEAQD/9//+X7z00kv4/e9/D71ejyFDhqBv3744cOAAW+2IPERybBj8NCqUVtXj3DXXtS+JqHWEEDjc0ALOljvfJgn+qtyksrIy6HQ6mM3mVs9OIaK2mfbXL5F7oRQrfp6KB9P4ixdRW5iuV2Hk/+6FVi3h2Av3w1+jVjokametzU0UWeeOiKgxeZ9ZTqogajt53GpybBgTOx/H5K4FRqMRKSkpyMrKUjoUIq/FxYyJbt+NxYu5BIq3ycrKQkpKCoxGY6vqu7XOnS/KyclhtyxRB0trGB90vLAMNfVWBGjZ6kDkLnnxYu5M4X0yMzORmZnp6JZtCVvuiEhxCRGB6Bbsh3qrwPeXWrcxNhHdYLUJHLtkT+4GczKFz2NyR0SKkyQJaeyaJWqz01cqUFVnRZCfGr2iQ5QOhxTG5I6IPMKNnSpKlA2EqAuSv28GxuugVjW9mxP5DiZ3ROQR5BmzbLkjct/B8/bkLj0pQuFIyBMwuSMijzAoUQdJAi6WVONqRa3S4RB1KQcvMLmjG5jcEZFHCAvQOsYKcb07ota7XlmHM8X2bTnTujO5IyZ3RORB7mpodfju/HWFIyHqOuTxdj2jgxEZ7KdwNOQJmNy1gIsYE3Weu+6IBAB8d46TKohaK1fukmWrndfiIsbtjIsYE3Ue4x32f5yOXCzlYsZErcTJFN6PixgTUZfVPTII0aH+qLcKHLloVjocIo9Xb7U5dqYYwuSOGjC5IyKPIUmSo/Uu5xzH3RG1JL+wHNX1VoQGaHAnFy+mBkzuiMij3JUkj7tjckfUkoMNk4+GdI+AiosXUwMmd0TkUYzypIrzJbDZhMLREHm23IZlgzjejhpjckdEHiU5NhRBfmqU11hw8kq50uEQeTROpqCmMLkjIo+iUaswpLs87o5LohA157K5BgWl1VBJQGrD3sxEAJM7IvJAdzVMquC4O6Lmyevb9TWEIcSfK5vRDUzuiMjjGLmYMVGLbnTJhisbCHkcJnct4A4VRJ1vcGI41CoJBaXVKCitVjocIo/E8Xa+gztUtDPuUEHU+YL9NUiJDcPRAjO+O3cd8YPjlQ6JyKPU1Fvx/SX74sXp3SMVjoY6GneoICKvcGPcHbtmiW52rMCMeqtAVIg/EiMDlQ6HPAyTOyLySPK4O+5UQeSq8Xg7SeLixeSMyR0ReaS7GsYRnSgqh7m6XuFoiDyLnNzJywYRNcbkjog8kj4sAEndgiDEjSUfiAgQQji+JziZgprC5I6IPBb3mSVydeF6Fa5W1EGrljAgvuXB9eR7mNwRkccy3sGdKohuJk8y6h+nQ4BWrXA05ImY3BGRx7qrYVLFYVMpai1WhaMh8gxfn7kGABjWk0ugUNOY3LWAixgTKadXdDAigrSotdhwrKBM6XCIPMLXP9qTu+E9uykcCXUWLmLczriIMZFyJEmC8Y5IfPZDEb45c42Dx8nnma5XoaC0GhqV5FguiLwfFzEmIq8y4s4oAMBXP15VOBIi5cmtdoMSdAj2Z/sMNa1NyV1+fj6mT58Og8EAvV4Po9GI7Oxst65RVFSEhQsXolevXoiMjERUVBSmTJmCgwcPutT9/PPPoVarYTAYmnwFBwdDpVLhypUrTuf4+fk1e87+/fvb8taJqJONuNPe9ZRzrgQ19Rx3R75NHm83vBe7ZKl5bqf9eXl5GDVqFMaOHYv8/HzodDps2LABs2bNwqlTp7B06dIWr3H27FmMGDEC/v7+eO+992A0GlFcXIy5c+ciIyMD27Ztw3333ed0TmJiIs6dO9fk9YYOHYqwsDDo9Xqn8oyMDHz++efuvkUi8iC9okMQE+aPorJaHDxf4mjJI/I1QohG4+34fUDNc6vlTgiBxx57DACwfv16hIfbtz2ZPXs2Zs6ciRdffBGHDh1q8ToLFy5EYWEhXn/9dcfgwOjoaGzcuBGBgYGYM2cOamtrHfUjIyMxatSoJq+Vm5uLnJwcLFiwwJ23QkRdhCRJjoTui9PsmiXfde5aFS6X1UCrljj+lG7JreRu//79OHz4MCZMmOAyoG/GjBmw2WwtziqtqanBzp07AQDjx493OhYWFoaRI0fCZDJh27ZtjvJBgwZhw4YNTV7vjTfeQHx8PCZPnuzOWyGiLmREL3ty9yWTO/JhcqtdWmIEAv24vh01z63kbs+ePQCA9PR0l2Ny2a5du255jWvXrsFisSAkJAQBAQEuxw0GAwC0akxceXk5Nm3ahP/8z/+ERsOBpUTeSm65O1pghrmK+8ySb5LH293N8XbUAreSu+PHjwMA4uPjXY5FR0dDq9Xi/PnzqK6ubvYakZGRUKvVqKioQFVVlctxeVLE2bNnW4xn48aNqK2txbx585o8fuXKFcybNw/9+vWDXq9H3759MW/ePJw4caLFaxOR5zDoAnCnPgRCAF+fYesd+R7n8XZM7ujW3EruSktLAQDBwcEuxyRJQlBQkFO9pgQGBmLMmDEA4NT1CgAVFRX48ssvHV+35M0338TUqVMRGxvb5HGTyYRhw4bh4MGDKCgowLp16/D1118jLS2txRZGWVlZmdOr8VhAIuo8IxpaKzjujnzRj8UVuFpRCz+NCmndw5UOhzpJbW2tSx7SGoqsc7dy5UrodDo8+eST2Lt3LywWC0wmE2bOnAm12j6OoKkEsrGvv/4aR44caXYixfDhw3HhwgXMnTsXwcHB0Gq1yMjIwIcffoi6ujo8+uijrUrUEhMTodPpHK9ly5a5/4aJ6LY51rs7fU3hSIg6n9xql949gvvJ+pBly5Y55SCJiYmtOs+t5C48PBwAUFlZ6XJMCOHoZpXrNad///7Izc3F+PHjMWfOHBgMBkycOBHDhg3D8uXLAaDZ1jjZG2+8gZSUFIwePbrJ4/7+/oiIcJ1N1LdvXwwaNAiFhYX46quvbnkPwN76ZzabHa/Fixe3eA4Rtb+7e3WDSgLOXK1EQWnzQz+IvBHXt/NNixcvdspBTCZTq85zaxZCcnIyAKCgoMDlWHFxMerr65GUlITAwMAWr9WzZ0+sXbvWpXzFihUAgCFDhjR7bklJCd577z28+uqrrQ3dSVxcHPLy8lBYWNhi3bCwMG4/RuQBwgK0GJQQjkOmUnx5+ioevqt1v8ESdXU2m8A3Z64DYHLna/z9/eHv7+/2eW613I0dOxYAmtxFQi4bN26c20E09u2330Kj0WDq1KnN1lm/fj00Gg1mzZrVbJ2VK1fi1KlTTR67dOkSALgsekxEnu0eR9csx92R7zh5pRzXK+sQqFUjNSFc6XCoC3AruRs5ciRSU1Oxfft2mM1mp2ObNm2CSqVCZmamo0wI0WQT4pYtW5pcl66goACffPIJFixYcMvE680338TMmTNv2aK2cuVKfPTRRy7lp0+fxrFjx9CtWzdkZGQ0ez4ReZ4bixlfgxBC4WiIOoc83u6uOyLgp+GW8NQyt/4vkSQJ69atc+xUYTabIYTA+vXrkZ2djSVLlmDw4MGO+gsXLkT37t2xaNEip+uUlJRg69atWLlyJaxW+16ReXl5mDhxIoYPH37LSQt79+7FiRMnWrUjxUsvvYSPP/4YVqsVQggcOnQIDz30EIQQeOuttxyze4moaxiSFI4ArQpXK2pxsqjlGfVE3kBO7u7mEijUSm7/CpCWloacnBxIkoQ+ffpAr9dj9erV2LBhA1544QWnuomJiQgKCnKZ3ZGWloaHH34Yq1atQrdu3ZCQkID58+dj3rx5+PTTT2+ZdL355psYMWIEBg0adMs4N2/ejPnz5+MPf/gDEhISEBkZiUmTJiE5ORkHDhzAtGnT3H3rRKQwf40axjsiAXC3CvINNpvAt2c53o7cIwn2bTSprKwMOp0OZrOZEyqIPMib+37Esh35GNtPj7/PNiodDlGHOlZgxqS/fIFgPzUOPT8eWjW7ZX1Za3MT/l9CRF2KPO7umzPXUG+1KRwNUceSF+029ohkYketxv9TWmA0GpGSkoKsrCylQyEiACmxYQgP0qKyzoojF0uVDoeoQ+05XgQAuLcfV3fwZVlZWUhJSYHR2LreCrfWufNFOTk57JYl8iAqlYQRvaKw7WghPj9RjPSkSKVDIuoQJZV1OHi+BACTO1+XmZmJzMxMR7dsS9hyR0Rdzthk+z90n35/WeFIiDrO3hNXYBNAcmwYEiK4ugO1HpM7IupyxvaLgUYl4WRRBc5edd0Okcgb7G7okr0vma125B4md0TU5eiCtI41v9h6R96o1mLFv0/aJ1OMTY5ROBrqapjcEVGXdH9/+z94TO7IG3175joqai2IDvXHoPiWx1gRNcbkjoi6pHEpBgBA3oVSFJXVKBwNUfuSZ8mO7aeHSiUpHA11NUzuiKhLMugCMDgxHADw2Q9FygZD1I6EENh9/AoAdslS2zC5I6Iu6/7+9ta7z9g1S14k/3I5Ckqr4a9R4Z6GRbuJ3MHkrgVcxJjIc8nj7r7+8RrMVfUKR0PUPuQu2XvujEKgn1rhaMgTcBHjdsZFjIk8V8/oEPTWh+DUlQr8vxNFeDAtQemQiG6b3CV7Xwq7ZMmOixgTkU+Ru2Y/PcZxd9T1XSmvwSFTKQD7ZAqitmByR0Rdmpzc7TtZjJp6q8LREN2evfn2VrtBCTrowwIUjoa6KiZ3RNSlDYgPQ3x4IKrrrfj3yWKlwyG6LY4uWc6SpdvA5I6IujRJkjAuRV7QmF2z1HXV1Fux/5T9F5Sx3HKMbgOTOyLq8uSu2T35RbBYbQpHQ9Q2X/14FTX1NsTpApASy4l81HZM7oioyzPeEYGIIC1Kq+px4Nx1pcMhapMPcwsAAONSYiBJ3JWC2o7JHRF1eRq1ytE1u7nhH0iirqS4vNaxGPfPjd0Vjoa6OiZ3ROQV5H8QPzl8CdcqahWOhsg97x80od4qMDgxHClx7JKl28PkrgXcoYKoaxjSPRwD43Wos9jwbo5J6XCIWs1mE9h04AIAYOYwttqRK3d3qJCEEKKDY+qS5FWgzWYzd6gg6iI+OHgRT79/GHG6APz7mTHQqPn7K3m+fSeL8ejaAwgL0ODbZ+/jlmPUrNbmJvzJR0ReY9KgWEQG++GSuQa7fuCyKNQ1ZH9zHgAwbUgCEztqF0zuiMhrBGjVmDE0EQCw/qtzygZD1AqXzTXY07ArBbtkqb0wuSMir/Kru5OgVkn49ux1HC8sUzocolv6Z44JVpvA0Dsi0TsmVOlwyEswuSMirxKrC8T9/e3Lomxg6x15MIvVhndzGiZS3M1WO2o/TO6IyOvMzugBAPj4UAFKq+oUjoaoaZ+fKEahuQYRQVr8xwCD0uGQF2FyR0Rex3hHBJJjw1BTb8M/uSwKeajsb+0TKR66KxH+Gk6koPbD5I6IvI4kSZidkQQA2PjNeVhtXPGJPMvFkip8frIYADBjKLtkqX0xuWsBFzEm6pqmDI5HeJAWF0uqse1oodLhEDnUWWx4fsv3EAIYcWc39IgKVjok8nBcxLidcBFjoq7vf3fm46+f/wg/jQpZvxzi2H+WSCkWqw0L383D9qOX4a9R4R/z7kZ6UoTSYVEXwUWMicjnLRzbG/cl61FnsWH+OwexOfei0iGRD7PaBJ5+/zC2H70MP7UKbz6SzsSOOgSTOyLyWgFaNf72q3RMS4uH1Sbw1HuHse7Ls0qHRT7IZhN4dvNRfHzoEjQqCVkzh2B0X73SYZGXalNyl5+fj+nTp8NgMECv18NoNCI7O9utaxQVFWHhwoXo1asXIiMjERUVhSlTpuDgwYMudT///HOo1WoYDIYmX8HBwVCpVLhy5YrTeTabDa+//joGDBgAvV6PuLg4zJkzB4WFHH9D5Cu0ahWWP5SKx0bcAQB4YesPWLHrJCdZUKcQQqCqzoLnP/ke//zOBJUEvP6LNA4RoA6lcfeEvLw8jBo1CmPHjkV+fj50Oh02bNiAWbNm4dSpU1i6dGmL1zh79ixGjBgBf39/vPfeezAajSguLsbcuXORkZGBbdu24b777nM6JzExEefOnWvyekOHDkVYWBj0euffgh599FFs3rwZH3zwAR544AEUFhbiZz/7GYxGI7755hskJCS4+/aJqAtSqSQ8NykFEUF+eG3XSby+5xRe33MKgVo1gv3VCPLTIMhPjQCtGoFaNQK0KgRo7X/316jgp1HBT93wZ6O/a9UqaNQStGoVtGoJGpX9T7WqoVylglolQaOW7H+qJKikRl+rJKgb/i5/rVLB/qdkL1NJcJwjNXxtf9lnBXs7IQRsArAJAZsQEI6v7d2cQghYbTfqWG2ioRywCgGrzQaL7Ua5/Kq32v+02GywWO1/1jf+s+HrOov97/VW+9d1DX/WWqyotdjsr3orauptqK63oqbeiup6K6pqraistaCyzgL59whJAv78cComDopV9kMlr+fWhAohBNLS0nDmzBmYTCbodDrHsVmzZiE7OxsHDx7E4MGDb3mdn/70p/jXv/6FLVu2YPLkyY7ysrIydO/eHWFhYTh16hT8/f0BAEeOHMGf//xnbNiwweVaubm5SE9Px4cffohp06Y5yjdv3oyf/exneO655/DCCy84yk+fPo0+ffpg6tSp2Lx5c7MxckIFkXfa+PU5vLT9OGrqbUqH0i7kJE+CPfGD/T+oJHsyKOHGcTT+e6OvGw7hRq7omjTenEc6/8shnMoE7P9e3Pja/nfRUCAfdxyDPTlDo6/lRM5bhPhr8PxPU/DQXYlKh0JdWGtzE7eSu3//+98YNWoUfv7zn+Pdd991OrZjxw5MmDABc+fOxZo1a5q9Rk1NDUJDQ2GxWFBdXY2AgACn43Lid3Oy1pz//M//xPbt23Hu3DloNDcaIu+9917s3bsXx48fR79+/ZzOGTZsGHJycnDhwoVmW++Y3BF5rzqLDeU19aiqs6KyzoLKhlaWmnoraiw21NRbHa0xtRZrQ0uN/VVntaHeYkO91YZ6m3B8bbHZW3fsLT43WoTsrUPOf2/cwiS3OlmFgM0mYPWypKazyK2aN7d+qtX2VlK1o2XU3tIqt57Kf2rUqoY/b7TA+mlUDa2y9tZarUqCv1btaMWVW3UDG1p5Axpafe0twpqGlxrBfhoEatVQqby/pZU6VmtzE7e6Zffs2QMASE9Pdzkml+3ateuW17h27RosFgtCQkJcEjsAMBjsW7Ds37+/xeSuvLwcmzZtwn/91385JXZ1dXX44osvEBwcjL59+zYZ64EDB7B7927Mnj37lvcgIu/jp1GhW4g/uikdSDNu7mqUuyLlxM+pq9J2owWscdclcOPcm1vKGu5yU0ubo7SJeJqOs6leYQmSo/xGa+DNZZLjmFxfTs4a/ymhoTsaDWUq+/lqleTUPW3vsmbiRCRzK7k7fvw4ACA+Pt7lWHR0NLRaLc6fP4/q6moEBgY2eY3IyEio1WpUVFSgqqoKQUFBTsflSRFnz7Y8o23jxo2ora3FvHnznMpPnz6N+vp63HHHHU1+w8vx5+fnt3iPsrIyp7/7+/s7uouJiDqCJNlbkIjIt9XW1qK2ttbx95tzkua4NVu2tLQUABAc7LqatiRJjkRNrteUwMBAjBkzBgCwbds2p2MVFRX48ssvHV+35M0338TUqVMRG+s8OPVWcTYuLykpafEeiYmJ0Ol0jteyZctaPIeIiIjodi1btswpB0lMbN2YTUXWuVu5ciV0Oh2efPJJ7N27FxaLBSaTCTNnzoRabd88ubnETPb111/jyJEjWLBgQYfGajKZYDabHa/Fixd36P2IiIiIAGDx4sVOOYjJZGrVeW4ld+Hh4QCAyspKl2NCCFRVVTnVa07//v2Rm5uL8ePHY86cOTAYDJg4cSKGDRuG5cuXA4BLa9zN3njjDaSkpGD06NFuxdm4PCKi5ZXBw8LCnF7skiUiIqLO4O/v75KHtIZbY+6Sk5MBAAUFBS7HiouLUV9fj6SkpGbH2zXWs2dPrF271qV8xYoVAIAhQ4Y0e25JSQnee+89vPrqq00ev/POO6HVanHp0iUIIVzG3cnx3zyLloiIiKirc6vlbuzYsQDQ5C4Sctm4ceNuK6Bvv/0WGo0GU6dObbbO+vXrodFoMGvWrCaP+/n54Z577kFlZSVOnDjRZKySJLkslExERETU1bmV3I0cORKpqanYvn07zGaz07FNmzZBpVIhMzPTUSaEaLJ/+ObFi2UFBQX45JNPsGDBApfdJhp78803MXPmzFs2Tz7xxBOOuBo7ffo0cnJyMHXqVO5QQURERF7HreROkiSsW7cOQgg89thjMJvNEEJg/fr1yM7OxpIlS5x2p1i4cCG6d++ORYsWOV2npKQEW7duxcqVK2G1WgHYtzWbOHEihg8ffssZqXv37sWJEydanEgxbdo0zJw5E8uXL8fOnTsBAJcvX8asWbMQFxeHVatWufPWO0RtbS2WLl3qNM2ZlMVn4nn4TDwTn4vn4TPxPIo9E9EGx48fF9OmTRN6vV5ERUWJ9PR0sXHjRpd6f/rTn0RQUJB49dVXncoPHTokHn74YdGjRw+h0+lEfHy8GDp0qFi9erWor6+/5b1//vOfixEjRrQqTqvVKlasWCFSUlJEdHS0iI2NFbNnzxYFBQUtnms2mwUAYTabW3WvtuiMe5B7+Ew8D5+JZ+Jz8Tx8Jp6nvZ9Ja6/XpuTOF3hTcrd69eoOvX5n3qej78Fn4nn36Mx/sLzh8+qse3jT94q33IPPxPPuw+TOw8gfYJ8+fURycnKH/A/QWd+IycnJHXr9zrxPR9+Dz8Tz7tGZyZ03fF6ddQ9v+l7xlnvwmXjefdrrmaxevVokJyeLPn36tOp6bi2F4ktEw2aKe/bscUzcaO22H60lX6+9r3szq9Xa4fforPt09D34TDzvHp31TADv+Lw66x7e9L3iLffgM/G8+7TXM3nkkUfwyCOPoKysDImJiY4cpTmSaKmGj7p48WKrt/kgIiIi6iwmk+mWK34wuWuGzWbDpUuXEBoa6rIIMhEREVFnE0KgvLwccXFxUKmaX/CEyR0RERGRF3FrnTsiIiIi8mxM7oiIiIi8CJM7IiIiIi/C5E4B+fn5mD59OgwGA/R6PYxGI7Kzs5UOy6vV1tbin//8JyZNmgSDwYBu3bohOjoaEydOxO7du5s8p6amBs8//zx69+4NvV6PpKQk/O53v3PZV5na1xNPPAFJkjB79uwmj/O5dDyr1Yq//vWvGD58OLp3747w8HD06tULv/jFL3D48GGnunwencNqtWLDhg0YPnw44uLiEBMTg0GDBuGll15CRUWFS30+l/Z37NgxZGRkQJIknDt3rtl6bfnst2/fjp/85CfQ6/WIiYnBAw88gAMHDrQ92NtaVY/clpubK0JDQ8XUqVNFSUmJsNlsYt26dUKlUonnn39e6fC81m9/+1sBQCxevFiUlZUJIYQ4f/68uO+++wQA8Ze//MWpfl1dnRgzZozQ6/XiwIEDQgghTp48KXr37i0GDhzI7X06yK5du4QkSQKAePTRR12O87l0vOrqajFu3DgxfPhwcezYMSGEEPX19WL58uUCgFi3bp2jLp9H55k7d64AIP7whz+I2tpaYbPZxL/+9S8RGBgo0tLSRG1traMun0v7qq6uFs8++6yIjIwUUVFRAoA4e/Zsk3Xb8tmvWbNGABB//OMfRX19vaiqqhK/+c1vhFarFZ999lmbYmZy14lsNptITU0VoaGhorS01OnYI488IlQqlcjLy1MmOC+XmZkpRo4c6VJeXFwsAgMDhb+/vygpKXGU//nPfxYAxNq1a53q79mzRwAQTz75ZEeH7HNKSkpEQkKCeOSRR5pN7vhcOt6iRYtEt27dnL4fZNOmTRNbt251/J3Po3NcvHhRABCDBw92Ofa73/1OABCbNm1ylPG5tK/HH39cTJkyRZhMJjFq1KhbJnfufvYXL14UgYGB4ic/+YlTeX19vejZs6eIj48XVVVVbsfM5K4T7du3TwAQP//5z12Obd++XQAQc+fOVSAy77d161axc+fOJo+lpaUJAGLPnj2Osp49ewq1Wi3Ky8ud6tpsNhETEyNCQ0NFdXV1h8bsa2bOnCkmTZok9u7d22xyx+fSsYqKioRGoxGLFi1qVX0+j87xzTffCADi4YcfdjmWlZUlAIhXXnnFUcbn0r7OnTvn+Lql5M7dz/6FF14QAMTf/vY3l2s988wzAoB455133I6ZY+460Z49ewAA6enpLsfksl27dnVqTL5i0qRJuP/++5s8VldXBwDo1q0bAODs2bM4c+YM+vbti5CQEKe6kiRhyJAhKC8vxzfffNOxQfuQDz/8EJ9++inWrFnTbB0+l4738ccfw2Kx4O67726xLp9H5+nTpw8CAgJw/Phxl2Ny2cCBAwHwuXSEpKSkVtVry2ffUXkBk7tOJH8TxsfHuxyLjo6GVqvF+fPnUV1d3dmh+ayrV6/i1KlTSElJwaBBgwDc+jk1Ls/Pz++cIL1cUVER5s+fj7/97W8wGAzN1uNz6XgHDx4EAOh0Ojz33HPo378/oqOj0bt3b8yfPx8XLlxw1OXz6DwRERH4y1/+gvz8fDz77LMoKytDXV0d3n//faxZswYzZszAhAkTAPC5KKktn/2tzrmdZ8XkrhOVlpYCAIKDg12OSZKEoKAgp3rU8VatWgWLxYJVq1Y5tpm71XNqXF5SUtIpMXq7uXPnYvz48Zg+ffot6/G5dLxLly4BAB599FFcuHABu3fvxqVLl5CVlYWPP/4YQ4YMwYkTJwDweXS2uXPn4oMPPsC7774LnU6HkJAQzJs3Dy+//DL+8Y9/OOrxuSinLZ/9rc65nWfF5I581jfffINXXnkFf/jDHzB27Filw/FJf//735Gbm4vVq1crHQoBjl6DkJAQvP3224iNjYVWq8X48ePx2muv4dq1a/jd736nbJA+SAiBxx9/HA8++CDmz5+PkpISlJeX4x//+AdeffVVTJgwgY0C5ITJXScKDw8HAFRWVrocE0KgqqrKqR51nB9++AGTJk3CwoUL8T//8z9Ox271nBqXR0REdGiM3u7cuXN46qmn8Pe//71VnyWfS8eTWwrGjh0LjUbjdGzy5MkAgN27d6OmpobPoxOtX78eb731Fn71q1/hmWeeQXh4OPz9/TFhwgS8/vrr2LFjhyPp5nNRTls++1udczvPisldJ0pOTgYAFBQUuBwrLi5GfX09kpKSEBgY2Nmh+ZRjx47h3nvvxZw5c7B8+XKX47d6To3L+/Xr13FB+oDt27fDZrNh9uzZMBgMjte0adMAAP/85z8dZVu2bOFz6QR33HEHACAqKsrlWEhICIKDg2GxWHD9+nU+j060c+dOAGiyh0Eu++ijjwDw55eS2vLZ3+qc23lWTO46kfxNKA9abkwuGzduXKfG5Gvy8vIwZswYzJ8/H//7v//rKD937pxjvFGPHj3Qs2dPnDx50mXldyEE8vLyEBoa2qoZhdS8BQsWoLy8HJcvX3Z6bd68GQDw85//3FE2ZcoUPpdO8JOf/AQAcPnyZZdjVVVVqKyshEajQWRkJJ9HJ5I/X3lccGNyWUVFBaxWK5+Lgtry2XdUXsDkrhONHDkSqamp2L59u8s2JJs2bYJKpUJmZqZC0Xm/nJwcjB07Fv/1X/+FpUuXOh1bunQp3nrrLcffMzMzYbFY8P777zvV27t3Ly5fvoy5c+ciICCgM8KmRvhcOtbEiRORkJCAXbt2OZYIku3YsQMA8MADDzg+Yz6PziEnA/v27XM59u9//xsAcNddd0GtVgPgc1GSu5/9nDlzEBgYiE2bNjnVt1gs+OCDDxAfH48HH3zQ/UDcXhmPbktubq4ICQkRDz74oCgtLXXafuy5555TOjyv9eWXX4qwsDDRr18/8fzzz7u8UlNTnbZ/q6urE6NHj3bZQqZPnz7cvqeD3WoRYz6XjvfZZ58JPz8/8atf/Upcu3ZN2Gw28dVXX4mEhAQRGxsrzpw546jL59E5SkpKRN++fYVarRZvvPGGqKmpETabTezfv190795d+Pv7i3379jnq87l0nJYWMW7LZ//WW28JAOKll14SFotFVFdXi9/85jdCo9GITz/9tE1xMrlTwPHjx8W0adOEXq8XUVFRIj09XWzcuFHpsLzalClTBIBbvm7e27e6ulo899xzomfPniI6OlokJiaKRYsWuWwdR+3jj3/8o4iJiRERERECgAgICBAxMTFi4MCBTvX4XDred999JyZPniwiIyNFeHi46NGjh/jtb38rLl++7FKXz6NzlJaWimeffVb0799fhIaGCp1OJxISEsTMmTPF4cOHXerzubSfb7/9VsTExIiYmBih1WoFABEVFSViYmLEU0895VK/LZ/9tm3bxD333COioqJEdHS0uP/++8U333zT5pglIYRwv72PiIiIiDwRx9wREREReREmd0RERERehMkdERERkRdhckdERETkRZjcEREREXkRJndEREREXoTJHREREZEXYXJHRERE5EWY3BERERF5ESZ3RERERF6EyR0RERGRF2FyR0RERORF/j/erIpNIjWrkgAAAABJRU5ErkJggg==", + "text/plain": [ + "
" + ] + }, + "metadata": {}, + "output_type": "display_data" + } + ], + "source": [ + "from squishyplanet import OblateSystem\n", + "\n", + "state = {\n", + " \"times\" : jnp.linspace(-1,1,100),\n", + " \"a\" : 200.0,\n", + " \"e\" : 0.3,\n", + " \"i\" : 89.75 * jnp.pi / 180,\n", + " \"Omega\" : 95 * jnp.pi / 180,\n", + " \"omega\" : jnp.pi / 3.5,\n", + " \"period\" : 1001.0,\n", + " \"t0\" : 0.2,\n", + " \"parameterize_with_projected_ellipse\" : False,\n", + " \"r\" : 0.2,\n", + " \"f1\" : 0.1,\n", + " \"f2\" : 0.2,\n", + " \"obliq\" : 0.3,\n", + " \"prec\" : 0.4,\n", + " \"tidally_locked\" : False,\n", + " \"ld_u_coeffs\" : jnp.array([0.008, 0.007, 0.006, 0.005, 0.004, 0.003, 0.002, 0.001])\n", + "}\n", + "\n", + "p = OblateSystem(**state)\n", + "\n", + "g = p.lightcurve()\n", + "\n", + "plt.plot(g)" + ] + }, + { + "cell_type": "code", + "execution_count": 10, + "metadata": {}, + "outputs": [ + { + "name": "stdout", + "output_type": "stream", + "text": [ + "(100,)\n" + ] + }, + { + "data": { + "text/plain": [ + "[]" + ] + }, + "execution_count": 10, + "metadata": {}, + "output_type": "execute_result" + }, + { + "data": { + "image/png": "iVBORw0KGgoAAAANSUhEUgAAAncAAAFeCAYAAADngTkBAAAAOXRFWHRTb2Z0d2FyZQBNYXRwbG90bGliIHZlcnNpb24zLjkuMiwgaHR0cHM6Ly9tYXRwbG90bGliLm9yZy8hTgPZAAAACXBIWXMAAA9hAAAPYQGoP6dpAABafElEQVR4nO3deXxU5b0/8M+ZJXsySUgmk40IyJKwhBAHJEgBEbwCBaRoS6mIFK6UWKjW6/3h5aVYq9grFaSkVbEsP0yxLihSFgV+SHElkrApYZFtCCEESCb7MjPP74/JGTJMQjIhyZnMfN4v50V4znPO+c4cE755VkkIIUBEREREXkGldABERERE1H6Y3BERERF5ESZ3RERERF6EyR0RERGRF2FyR0RERORFmNwREREReREmd0REREReRKN0AJ7KZrPh0qVLCA0NhSRJSodDREREPk4IgfLycsTFxUGlar59jsldMy5duoTExESlwyAiIiJyYjKZkJCQ0OxxJnfNCA0NBWD/AMPCwjrkHmVlZUhMTOzQewCA0WhETk5Oh12/M+/T0ffgM/G8e3TWMwG84/PqrHt40/eKt9yDz8Tz7tPez0S+npyjNIfJXTPkrtiwsLAO/welo++hVqs7/D101n06673wmXjWPYDO+V70ls+rs54J4B3fK95yDxmfiefdp72fSUvDxTihwgdkZmZ6zX066710ND4Tz+QtnxefiW/eo7N40+flTc+lMUkIIZQOwhOVlZVBp9PBbDZ3aLdsR9+D3MNn4nn4TDwTn4vn4TPxPO39TFp7PbbctcBoNCIlJQVZWVntfm1/f388//zz8Pf3b/drU9vwmXgePhPPxOfiefhMPE97PZOsrCykpKTAaDS2qj5b7prB34CIiIjIk7DljoiIiMgH3VZyd+zYMWRkZECSJJw7d65N19i4cSOMRiP0ej0MBgMeeughnDx5stn6+fn5mD59OgwGA/R6PYxGI7Kzs5utX1NTg+effx69e/eGXq9HUlISfve738FsNrcpXiIiIiJP1qbkrqamBv/zP/+DUaNG4dSpU22++ZIlSzB79mxkZmaiqKgI+fn5sFgsMBqNOHLkiEv9vLw8DB06FFarFfn5+SgqKkJmZiZmzZqFpUuXutSvr6/HhAkT8MYbb+Af//gHrly5gt27d2P79u0YOXIkysrK2hw7ERERkUcSbfD444+LKVOmCJPJJEaNGiUAiLNnz7p1je+++05IkiRmzZrlVF5aWipCQ0NFenq6sNlsjnKbzSZSU1NFaGioKC0tdTrnkUceESqVSuTl5TmV//nPfxYAxNq1a53K9+zZIwCIJ598stn4zGazACDMZrNb74uIiIioI7Q2N2lTy93ixYvx8ccf33Lri5ZkZWVBCIEZM2Y4let0OjzwwAM4ePAgvvrqK0f5/v37cfjwYUyYMAE6nc7pnBkzZsBms7nMaM3KyoJarcZDDz3kVD5mzBjExMTg7bffRk1NTZvfAxEREZGnaVNyl5SUdNs33rNnDwAgPT3d5ZhctmvXrjbXP3v2LM6cOYO+ffsiJCTEqb4kSRgyZAjKy8vxzTff3OY7ISIiIvIcimw/VlVVhQsXLsDPzw/R0dEux+Pj4wHYJ0/Ijh8/7nSssejoaGi1Wpw/fx7V1dUIDAy8Zf2b7zF69OhmY715XJ6/v3+7rCFUUFqNqVlf3vZ1iABALUm4p3cUfjO6F3pFh7R8AhGRB/jy9FWs/+ocKmosqKq3orrOgqo6K2otNqVDa5MArQr7n7m33a5XW1uL2tpax99bO1dAkeSutLQUABAUFNTk8eDgYABASUmJyznyscYkSUJQUBDMZjNKS0sRGBh4y/rN3aMpiYmJTn9//vnnm5y84S6bTaC4vLblikSt9MHBi/gw9yImDIjFb0b3woB4XcsnEREppM5iw+/fO4zLZd4zPCpQq27X6y1btgwvvPCC2+cpktx1JSaTyWmhwPZa+TsmLAA7Fo1sl2sRlVTWYd1X57DrhyJsO1qIbUcLMbpvNJ6blIKebMkjIg/08aECXC6rgT7UH/8zMRlBfhoE+akR6KdGgEYNSVI6Qve1d8yLFy/GU0895fh7WVmZS6NTUxRJ7sLDwwHYu2ebUllZCQCIiIhwOUc+1pgQwnEtud6t6jd3j6aEhYV1yA4VfhoVkmO58wW1n4w7o3Dicjn+9vlpfHL4Ej4/UYzL5lzsWDQSUlf8KUlEXstmE3hj348AgLkje2DK4KaHUPm6tg4FU2SHiqCgIHTv3h11dXUoLi52OV5QUAAA6Nevn6MsOTnZ6VhjxcXFqK+vR1JSEgIDA1us39w9iLq6voZQrPxFGvb8fjT8NSrkXy7H0QIu2E1EnuWzH4pwprgSYQEazBjaXelwvI5i24+NHTsWAHDw4EGXY3LZuHHj2ly/R48e6NmzJ06ePImKigqn+kII5OXlITQ0FHffffdtvhMiz9MjKhj39zcAAN7/7qLC0RAR3SCEwN8aWu0eGZ6E0ACtwhF5nw5P7oQQMJlMLuWZmZmQJAmbNm1yKjebzdixYweGDBmCjIwMR/nIkSORmpqK7du3u2wdtmnTJqhUKmRmZrrcw2Kx4P3333cq37t3Ly5fvoy5c+ciICDgdt8ikUd66C77OpRbDhWgpt6qcDRERHbfnLmOw6ZS+GtUmJ3RQ+lwvFKHJ3cLFy5E9+7dsWjRIqfy9PR0PPvss3jnnXewYcMGCCFgNpsxe/ZsAMDatWudxglJkoR169ZBCIHHHnsMZrMZQgisX78e2dnZWLJkCQYPHux0j9/+9rcYPXo0/s//+T/IyckBAJw6dQq/+c1vMHDgwHaZ9UrkqTJ6RSFOF4CyGgt2/VCkdDhERADgaLV7+K5ERIe2zyRFctam5O7AgQMwGAwwGAyOXSSMRiMMBgN+//vfO9VNTExEUFBQk7M7/vjHP2LdunVYtWoVYmJi0KdPH6jVauTk5CA1NdWlflpaGnJyciBJEvr06QO9Xo/Vq1djw4YNTU4V1mq12LFjB+bPn49f/OIX0Ov1GDt2LB544AHs37+/QyZKEHkKtUrCz9LtrXfvH2TXLBEp71iBGf8+WQy1SsJ//qSn0uF4LUkIIZQOwhOVlZVBp9PBbDYzCaQu6/y1Sox69XNIEvDlf9+LuPBApUMiIh/2xD9y8a8jhZgyOA6v/yJN6XC6nNbmJopNqCCijpfULRhDe0RCCGBzLlvviEg5569VYvvRQgDA/FG9FI7GuzG5a4HRaERKSgqysrKUDoWoTR5q6Jr94OBFsKGeiJSyZv8Z2AQwum8013l1U1ZWFlJSUmA0GltVn92yzWC3LHmLyloLhr60G5V1Vrz3+HAM7RGpdEhE5GOsNoH0P+5CaVU93vn1MNzTO0rpkLokdssSEQAg2F+DiYNiAQDvf+e6LBERUUc7fLEUpVX1CA3Q4O6e/AWzozG5I/IBD91ln62+7WghKmstCkdDRL7m8xP23ah+0jsaGjVTj47GT5jIB9yVFIEeUcGoqrM6BjQTEXWWfSeuAABG9Y1WOBLfwOSOyAdIkoTpDRMrPuSsWSLqRFcranGkYY/r0X2Y3HUGJndEPuKng+IAADnnSlBeU69wNETkK/59shhCACmxYdCHccvPzsDkjshHdO8WhKRuQbDaBL45c13pcIjIR8jj7UazS7bTMLkj8iH33GlffuCLU8UKR0JEvsBqE/j3KTm50yscje9gctcCLmJM3mRkw9pS+09fVTgSIvIFjZdAGdI9XOlwuix3FzHWdHA8XV5OTg4XMSavMbxXFFQScKa4EpdKq7nXLBF1KLlLdmTvKC6BchsyMzORmZnpWMS4JfykiXyILlCLQQnhAIAvTrH1jog6lrwEyug+7JLtTEzuiHwMu2aJqDNca7QECte361xM7oh8jDyp4svTV2GzcWtpIuoY/z5lXwIlOTYMMVwCpVMxuSPyMWndIxDkp8b1yjr8UFimdDhE5KW4BIpymNwR+Rg/jQp39+wGAPiCXbNE1AGsNoF/n2xI7rgrRadjckfkg26sd8fkjoja35GLpSipqkeovwZDkiKUDsfnMLkj8kHypIoD566jpt6qcDRE5G32NnTJ3tM7ClougdLp+Im3gIsYkze6Ux+CmDB/1FlsyDnHrciIqH3ta+iSHcNdKdoFFzFuZ1zEmLyRJEm4585ofJh7EV+cuoqRvTkmhojaR2WtBccalkAZ0dBLQLeHixgTUas41rvjuDsiakeHTKWw2gTiwwMRz11wFMHkjshHjWiYVPFDYRmuVtQqHA0ReQt5qMddd3AihVKY3BH5qOhQf/QzhAKwL2hMRNQevjtXAgC4645IhSPxXUzuiHyY3DXLJVGIqD1YrDbkXrAnd0a23CmGyR2RD7unYSLFVz9eUzgSIvIGxwvLUVVnRWiABn30oUqH47OY3BH5sLuSIqBWSSgorcal0mqlwyGiLs4x3i4pAiqVpHA0vovJHZEPC/bXIDnW/tv1wfMlCkdDRF2d/HOE4+2UxeSOyMfdlWT/IczkjohuhxDCqeWOlMPkrgXcoYK8XXrDD+HvznOnCiJqO9P1alwpr4VWLSE1MVzpcLwKd6hoZ9yhgrydnNwdLyxHZa0Fwf78sUBE7pNb7QbG6xCgVSscjXfhDhVE5Ja48EDE6QJgtQkcNpUqHQ4RdVFy67+R4+0U16bkLj8/H9OnT4fBYIBer4fRaER2drZb1ygqKsLChQvRq1cvREZGIioqClOmTMHBgwebPWfz5s249957ERkZiYiICKSkpODll19Gba3r6vrnzp2DWq2GwWBo8vWPf/zD7fdN5K3SG34Yf8dxd0TURjlcvNhjuJ3c5eXlYejQobBarcjPz0dRUREyMzMxa9YsLF26tFXXOHv2LNLS0rB161a8++67uH79Oo4fPw4AyMjIwO7du13OWbx4MX72s5/BaDTiwoULuHr1Kl5++WUsW7YMkydPhtVqdTknMTERly9fbvL1y1/+0t23TuS17nKMu2NyR0Tuu15Zh9NXKgDcGOpBynEruRNC4LHHHgMArF+/HuHh4ZAkCbNnz8bMmTPx4osv4tChQy1eZ+HChSgsLMTrr7/uGBwYHR2NjRs3IjAwEHPmzHFqjTt48CBeeeUVpKWl4U9/+hNCQkKgVqsxdepUPP300/jss8/w5ptvuvNWiKgR+Ydx3vkSWG1C4WiIqKuRZ9vfqQ9BZLCfwtGQW8nd/v37cfjwYUyYMMFlQN+MGTNgs9lanFVaU1ODnTt3AgDGjx/vdCwsLAwjR46EyWTCtm3bHOUfffRRk/UBYNKkSQCAN954w523QkSN9DOEIshPjfJaC05dKVc6HCLqYr47J4+3Y6udJ3AruduzZw8AID093eWYXLZr165bXuPatWuwWCwICQlBQECAy3GDwQDAnkjKioqKANhb95qrf/ToUZjN5ta8DSK6iUatQlr3cAA3Nv0mImqtG+vbcbydJ3AruZPHxcXHx7sci46Ohlarxfnz51Fd3fw2RpGRkVCr1aioqEBVVZXL8StXrgCwj8uT6fV6ADeSvKbq33wOAFRVVeGpp55C//79ERMTg549e+KXv/wlcnJybvU2nZSVlTm9mpq8QeQN0rmYMRG1QU29FUcL7I0rnCnbvmpra13ykNZwK7krLS0FAAQHB7sckyQJQUFBTvWaEhgYiDFjxgCAU9crAFRUVODLL790fC2bMGECAGDHjh0Qwnk8kNzFe/M5AFBSUgKDwYAvvvgCly5dwscffwyTyYThw4dj/fr1t3inNyQmJkKn0zley5Yta9V5RF0NFzMmorY4ctGMequAPtQfiZGBSofjVZYtW+aUgyQmJrbqPEXWuVu5ciV0Oh2efPJJ7N27FxaLBSaTCTNnzoRabV/4sHECOWLECMydOxfHjh3DE088geLiYtTU1OCDDz7AihUrHOP/Gp+TmJiIwsJCPPPMM4iIiIBarcagQYOwZcsWhISEYMGCBU22BN7MZDLBbDY7XosXL27nT4PIM6R1D4ckNawyX1ajdDhE1EXknLuxvp0kSQpH410WL17slIOYTKZWnedWchceHg4AqKysdDkmhHB0s8r1mtO/f3/k5uZi/PjxmDNnDgwGAyZOnIhhw4Zh+fLlAIDY2Finc9566y2sWbMGeXl5SE5ORu/evZGdnY0dO3YgLi7O5Ry1Wo2oqCiXe0dGRuLee+9FdXU1tm/f3uJ7DgsLc3r5+/u3eA5RVxQWoEXfmFAA7JolotaTJ1PcxckU7c7f398lD2kNt/YZSk5OBgAUFBS4HCsuLkZ9fT2SkpIQGNhys2zPnj2xdu1al/IVK1YAAIYMGeJULkkS5s6di7lz57qcU1BQgNjYWMfkipbIyWBhYWGr6hP5irvuiED+5XJ8d74EDwyMbfkEIvJpNptw/DLIyRSew62Wu7FjxwJAk7tIyGXjxo27rYC+/fZbaDQaTJ06tVX18/PzUVZWhoceesipfP369c1OnLh06RKAGxM1iMgunYsZE5Ebzl2rRFmNBf4aFfrFhiodDjVwK7kbOXIkUlNTsX37dpdlRzZt2gSVSoXMzExHmRCiyf7hLVu2YPLkyS7lBQUF+OSTT7BgwQKXxOv+++93mjwh++tf/4qQkBA8/fTTTuXr16/HunXrXOqXlpbi888/h5+fH/7jP/7j1m+YyMfIv3l/X2BGTb3rri9ERI0dvlgKABgQr4NWze3qPYVbT0KSJKxbt86xU4XZbIYQAuvXr0d2djaWLFmCwYMHO+ovXLgQ3bt3x6JFi5yuU1JSgq1bt2LlypWObcPy8vIwceJEDB8+vMkZqSdOnMAzzzyDM2fOALCP+/vTn/6ENWvWIDs7u8kZJGvWrMHbb7+Nuro6AMCPP/6I6dOno7S0FK+++ioSEhLceftEXi8hIhD6UH9YbAKHTaVKh0NEHu6wyd7Qk5oQrmwg5MTtNDstLQ05OTmQJAl9+vSBXq/H6tWrsWHDBrzwwgtOdRMTExEUFOSSeKWlpeHhhx/GqlWr0K1bNyQkJGD+/PmYN28ePv30U8eSKo39+te/RnBwMIYNG4aYmBgMGDAAP/zwA3Jzc5tsBXzzzTexZMkSvP322+jRowciIyORkZGBkJAQ7NmzBwsXLnT3rRN5PUmSHIOi2TVLRC2RW+5SE3W3rkidShI3LxxHAOyLF+t0OpjN5lbPTiHyBm/vP4M/bjuOe/vpsXa2UelwiMhD1VlsGLD0U9RZbNj3X6OR1M11DVxqX63NTdhBTkRO7mpYYT73QonLouFERLITl8tRZ7EhPEiL7pGuPW6kHCZ3LTAajUhJSUFWVpbSoRB1ipTYMPipVSitqsf5a65bBBIRAcChhi7ZQQnhXLy4g2VlZSElJQVGY+t6U9xa584X5eTksFuWfIqfRoWUuDAcMpXi8MVS3BHFrhYiciVPuhqcwPF2HS0zMxOZmZmObtmWsOWOiFwMTgwHcGMmHBHRzeTkLrXh5wV5DiZ3RORCnvkmz4QjImqsvKYep4srANi7ZcmzMLkjIhfyD+tjBWbUW23KBkNEHudogRlCAPHhgYgO5Z7rnobJHRG56NEtGKEBGtRabDhZVK50OETkYeQhG4PZJeuRmNwRkQuVSnKsOM9xd0R0syOOmbKcTOGJmNwRUZMc4+64DRkR3YSTKTwbkzsiapI87o6TKoiosStlNbhkroFKAgbGs+XOEzG5awEXMSZfJY+lOVlUjqo6i7LBEJHHOHzRPlSjtz4Uwf5cLrczcBHjdsZFjMlXxYQFwBAWgMtlNThWUIahPSKVDomIPMCNLlm22nUWLmJMRO2G4+6I6GbyUA2Ot/NcTO6IqFkcd0dEjdls4kbLHRcv9lhM7oioWY5tyJjcERGAc9cqUVZjgZ9Ghb6GUKXDoWYwuSOiZg1sWMPKdL0a1ypqFY6GiJR2pGEyxYC4MGjVTCE8FZ8METUrLECLntHBAIAjBVzMmMjXHeL6dl0CkzsiuqXBjp0qShWNg4iUJw/R4LZjno3JHRHdkvwbOpM7It9Wb7Xh+0tlAG5MtiLPxOSuBVzEmHydI7m7aIYQQtlgiEgxJ4vKUWexITRAgzu6BSkdjk/hIsbtjIsYk69Ljg2FVi3hemUdLpZUIzGSP9SJfNGxAnkyhQ6SJCkcjW/hIsZE1K78NWokx9p/weGSKES+61iBvUt2QDwbPDwdkzsialEqJ1UQ+byjcstdPLcd83RM7oioRY3H3RGR77FYbTheaG+5G8jkzuMxuSOiFqU2LGZ89KIZVhsnVRD5mlNXKlBrsSHEX4M7ugUrHQ61gMkdEbWoV3QIgv3UqK634sfiCqXDIaJOJnfJ9o8Lg0rFyRSejskdEbVIpZLQP+5G6x0R+ZbvOd6uS2FyR0StIv9QP8ptyIh8jvx9z/F2XQOTOyJqlYEJ9uUPmNwR+RaL1YYfCuVlUJjcdQVM7lrAHSqI7AbGhwMAfrhUxkkVRD7kx+JK1NTbEOynRs8oTqZQAneoaGfcoYLIrmdUMIL91Kiss0+q6BMTqnRIRNQJ5J0pUjiZQjHcoYKIOgQnVRD5Ji5e3PW0KbnLz8/H9OnTYTAYoNfrYTQakZ2d7dY1ioqKsHDhQvTq1QuRkZGIiorClClTcPDgwWbP2bx5M+69915ERkYiIiICKSkpePnll1FbW9vsORs3boTRaIRer4fBYMBDDz2EkydPuhUrEdlxUgWR7znGyRRdjtvJXV5eHoYOHQqr1Yr8/HwUFRUhMzMTs2bNwtKlS1t1jbNnzyItLQ1bt27Fu+++i+vXr+P48eMAgIyMDOzevdvlnMWLF+NnP/sZjEYjLly4gKtXr+Lll1/GsmXLMHnyZFitVpdzlixZgtmzZyMzMxNFRUXIz8+HxWKB0WjEkSNH3H3rRD6PkyqIfIvVJvD9Je5M0eUIN9hsNpGamipCQ0NFaWmp07FHHnlEqFQqkZeX1+J1Jk2aJACILVu2OJWbzWah0+lEYmKiqKmpcZR/9913AoBIS0tzudbSpUsFAJGVleVU/t133wlJksSsWbOcyktLS0VoaKhIT08XNput2RjNZrMAIMxmc4vvh8hXnCoqF0n//S/Rb8kOYbE2//1DRN7h5OUyfs97kNbmJm613O3fvx+HDx/GhAkTXAb0zZgxAzabrcVZpTU1Ndi5cycAYPz48U7HwsLCMHLkSJhMJmzbts1R/tFHHzVZHwAmTZoEAHjjjTecyrOysiCEwIwZM5zKdTodHnjgARw8eBBfffXVLWMlImfypAruVEHkG45dujGZQs3JFF2GW8ndnj17AADp6ekux+SyXbt23fIa165dg8ViQUhICAICAlyOGwwGAPZEUlZUVAQAiI6Obrb+0aNHYTbf6Cpqj1iJyBknVRD5lqMX2SXbFbmV3Mnj4uLj412ORUdHQ6vV4vz586iurm72GpGRkVCr1aioqEBVVZXL8StXrgCwj8uT6fV6ADeSvKbqNz6nqqoKFy5cgJ+fX5MJoRx/fn5+s3HKysrKnF63mrxB5As4qYLIdxzjTFlF1dbWuuQhreFWcldaWgoACA52XcRQkiQEBQU51WtKYGAgxowZAwBOXa8AUFFRgS+//NLxtWzChAkAgB07dkAI58VT5S7exufI95fjuZkcf0lJSbNxyhITE6HT6RyvZcuWtXgOkTcblMDkjsgX2GwC31/iTFklLVu2zCkHSUxMbNV5iqxzt3LlSuh0Ojz55JPYu3cvLBYLTCYTZs6cCbVaDcA5gRwxYgTmzp2LY8eO4YknnkBxcTFqamrwwQcfYMWKFY7xf00lnbfLZDLBbDY7XosXL273exB1JfJv8Nypgsi7nblaico6KwK0KvSK5s4USli8eLFTDmIymVp1nlvJXXh4OACgsrLS5ZgQwtHNKtdrTv/+/ZGbm4vx48djzpw5MBgMmDhxIoYNG4bly5cDAGJjY53Oeeutt7BmzRrk5eUhOTkZvXv3RnZ2Nnbs2IG4uDinc+T7N9Xt2zj+iIiIFt9zWFiY08vf37/Fc4i8GSdVEPkGudUuOTYMGjX3PFCCv7+/Sx7SGm5tP5acnAwAKCgocDlWXFyM+vp6JCUlITAwsMVr9ezZE2vXrnUpX7FiBQBgyJAhTuWSJGHu3LmYO3euyzkFBQWIjY11TK4ICgpC9+7dceHCBRQXF7uMu5Pj79evX4txEpEzeVLFgXPXceSimduQEXkpedIUu2S7HrdS8bFjxwJAk7tIyGXjxo27rYC+/fZbaDQaTJ06tVX18/PzUVZWhoceeqjTYyXyVXLX7DGOuyPyWtx2rOtyK7kbOXIkUlNTsX37dqdlRwBg06ZNUKlUyMzMdJQJIZrsH96yZQsmT57sUl5QUIBPPvkECxYscMyQld1///1Okydkf/3rXxESEoKnn37aqTwzMxOSJGHTpk1O5WazGTt27MCQIUOQkZHR8psmIhecVEHk3Ww2gR+4M0WX5VZyJ0kS1q1bByEEHnvsMZjNZgghsH79emRnZ2PJkiUYPHiwo/7ChQvRvXt3LFq0yOk6JSUl2Lp1K1auXOnYNiwvLw8TJ07E8OHDm5yReuLECTzzzDM4c+YMAPu4uT/96U9Ys2YNsrOzXWaQpKen49lnn8U777yDDRs2QAgBs9mM2bNnAwDWrl0LSeKCjERt0XhShcVqUzgaImpvF65XobzWAj+NCnfqQ5QOh9zk9gjJtLQ05OTkQJIk9OnTB3q9HqtXr8aGDRvwwgsvONVNTExEUFCQS+KVlpaGhx9+GKtWrUK3bt2QkJCA+fPnY968efj000+bXMLk17/+NYKDgzFs2DDExMRgwIAB+OGHH5Cbm9tkKyAA/PGPf8S6deuwatUqxMTEoE+fPlCr1cjJyUFqaqq7b52IGjhPqnCdYEVEXZu8M0WyIRRaTqbociRx88JxBMC+eLFOp4PZbG717BQiX/LwG1/jwLnrWP5QKqanJygdDhG1oz/tzMffPv8RM4Z2x7JpA5UOhxq0NjdhOk5EbcJJFUTe68bOFGzc6IqY3LXAaDQiJSUFWVlZSodC5FE4qYLIOwlxYzKFvJc0KSsrKwspKSkwGo2tqu/WOne+KCcnh92yRE24eVIFFzkl8g6Xy2pwrbIOapWEfgauY+kJMjMzkZmZ6eiWbQl/GhNRmzSeVHHmKidVEHmL7wvsrXZ3RocgQKtWOBpqCyZ3RNQm8k4VAMfdEXkTeaZsf46367KY3BFRm8k//Dnujsh7fM/xdl0ekzsiarMBDT/85W4cIur6vpdnysax5a6rYnJHRG0mT6r4/pIZNhuXzCTq6q5X1uGSuQYAkMLkrstickdEbdYrOhgBWhUq66w4e42TKoi6uu8bxtvd0S0IoQFahaOhtmJyR0RtplGrkBxr/+2ekyqIuj7HeLt4jrfrypjctYCLGBPdmmPc3SWOuyPq6uRf0vqzS9ajcBHjdsZFjIlubWDDb/hHL7Lljqirk3emGMCZsh6FixgTUaeSl0M5dskMITipgqirqqi1OBYkZ8td18bkjohuS299KPzUKpTXWGC6Xq10OETURscL7a12sboAdAvxVzgauh1M7ojotvhpVOgXa99/kosZE3VdHG/nPZjcEdFtc2xDdonJHVFXxZ0pvAeTOyK6bQPiuRwKUVfHljvvweSOiG6bPGP2WAEnVRB1RTX1Vpy+UgHgxs4z1HUxuSOi29YnJhQalYSSqnrH1kVE1HWcLCqHxSYQEaRFrC5A6XDoNjG5I6LbFqBVo3dMw6QKrndH1OXI4+0GxOsgSZLC0dDtYnLXAu5QQdQ6AxvG3X3PSRVEXY483i6F4+08EneoaGfcoYKodQbE6/Dedxc5qYKoC/qeO1N4NO5QQUSKkJdPOFpQxkkVRF2IxWpzLGDMmbLegckdEbWLlNgwqCTgakUtrpTXKh0OEbXSmauVqLXYEOynxh3dgpUOh9oBkzsiaheBfmrcqQ8BwPXuiLqSxuPtVCpOpvAGTO6IqN0McHTNMrkj6iq4M4X3YXJHRO2mv2Mx4zKFIyGi1uLOFN6HyR0RtRt5pwouh0LUNdhsAj80WuOOvAOTOyJqN/IaWYXmGlyt4KQKIk9nKqlCea0FfhqVY8wsdX1M7lrARYyJWi/EX4OeUfbZdpxUQeT55PF2/Qyh0KqZEngqLmLczriIMZF7BsTrcOZqJY4VmDG6r17pcIjoFjjermvgIsZEpCh53B1nzBJ5vmOcKeuV2pTc5efnY/r06TAYDNDr9TAajcjOznbrGkVFRVi4cCF69eqFyMhIREVFYcqUKTh48GCz52zZsgX33nsvEhISEBMTg5SUFDz99NMoLi52qfv555/Dz88PBoOhydf+/fvdft9E1LL+DXvMcsYskWcTQuD7hl/COJnCu7id3OXl5WHo0KGwWq3Iz89HUVERMjMzMWvWLCxdurRV1zh79izS0tKwdetWvPvuu7h+/TqOHz8OAMjIyMDu3btdznnppZcwdepU9OnTx3Hft99+G++88w7S09Nx7do1l3MyMjJw+fLlJl8jR450960TUSvI/0gUlFajpLJO4WiIqDlFZbW4VlkHtUpCP0Oo0uFQO3IruRNC4LHHHgMArF+/HuHh4ZAkCbNnz8bMmTPx4osv4tChQy1eZ+HChSgsLMTrr7/uGBwYHR2NjRs3IjAwEHPmzEFt7Y2ZdnV1dVi2bBmio6Pxl7/8BSEh9hk9GRkZWLx4MUwmE9asWePOWyGiDhIWoMUd3YIAsGuWyJPJSxbdGR2CAK1a4WioPbmV3O3fvx+HDx/GhAkTXAb0zZgxAzabrcVZpTU1Ndi5cycAYPz48U7HwsLCMHLkSJhMJmzbts1RXlJSgsrKSvTo0QNardbpnN69ewMAzp8/785bIaIOJLfeHeN6d0QeSx46wckU3set5G7Pnj0AgPT0dJdjctmuXbtueY1r167BYrEgJCQEAQEBLscNBgMAOI2J0+v1iImJwY8//oi6OuduHrk7d+DAgW68EyLqSI7kji13RB5Lbrnrz/F2Xset5E5OpOLj412ORUdHQ6vV4vz586iurm72GpGRkVCr1aioqEBVVZXL8StXrgCwj8uTSZKEv//976itrcXjjz+O4uJiWCwW7N69G6+88gpGjx6NX//6101ea968eejXrx/0ej369u2LefPm4cSJE61+z2VlZU6vxt3FRNQ0zpgl8nw39pRly52nqq2tdclDWsOt5K60tBQAEBwc7HJMkiQEBQU51WtKYGAgxowZAwBOXa8AUFFRgS+//NLxdWMTJ07Ezp07kZubC71ej+DgYPz0pz/FvHnz8Nlnn8Hf39/lXiaTCcOGDcPBgwdRUFCAdevW4euvv0ZaWlqLLYyyxMRE6HQ6x2vZsmWtOo/Ilw1oWFbBdL0a5qp6haMhopuVVNahoNTeEJPC5M5jLVu2zCkHSUxMbNV5iqxzt3LlSuh0Ojz55JPYu3cvLBYLTCYTZs6cCbXaPqjz5gTyxRdfxKhRozB27FhcuXIFlZWV2L17Nz788EPcc889uHDhglP94cOH48KFC5g7dy6Cg4Oh1WqRkZGBDz/8EHV1dXj00Udb1QpnMplgNpsdr8WLF7ffB0HkpXRBWiRGBgLguDsiTyS32iV1C0JYgLaF2qSUxYsXO+UgJpOpVee5ldyFh4cDACorK12OCSEc3axyveb0798fubm5GD9+PObMmQODwYCJEydi2LBhWL58OQAgNjbWUX/v3r147rnnMGLECLz22muIjo6GRqPBiBEjsHHjRhw4cACzZs1yuoe/vz8iIiJc7t23b18MGjQIhYWF+Oqrr1p8z2FhYU6vploIicgVu2aJPJf8S9cALl7s0fz9/V3ykNZwa/ux5ORkAEBBQYHLseLiYtTX1yMpKQmBgYEtXqtnz55Yu3atS/mKFSsAAEOGDHGUybNrx44d61J/6NChCAkJwb59+3D9+nVERka2eO+4uDjk5eWhsLCwxbpE1DYD4nXYfvQykzsiDyS33LFL1ju51XInJ1dN7SIhl40bN+62Avr222+h0WgwdepUR5k8/k6SpCbPUansb8NsvvGPyMqVK3Hq1Kkm61+6dAmAfRYuEXUMuUXgeyZ3RB6HO1N4N7eSu5EjRyI1NRXbt293SqQAYNOmTVCpVMjMzHSUCSGa7B/esmULJk+e7FJeUFCATz75BAsWLHBKvO6++24AwL59+1zOOXToEMrKymAwGJCUlOQoX7lyJT766COX+qdPn8axY8fQrVs3ZGRktOJdE1FbyN2y565VoayGkyqIPEVFrQVnr9mHV3GmrHdyK7mTJAnr1q1z7FRhNpshhMD69euRnZ2NJUuWYPDgwY76CxcuRPfu3bFo0SKn65SUlGDr1q1YuXIlrFYrAPu2ZhMnTsTw4cNdZqTOmDEDI0aMwJ49e7B06VLHmL+jR4/i0UcfhSRJeO211xwteLKXXnoJH3/8MaxWK4QQOHToEB566CEIIfDWW285ZvcSUfuLCPZDfHjDpAq23hF5jOOFZRACMIQFICqE48i9kduzZdPS0pCTkwNJktCnTx/o9XqsXr0aGzZswAsvvOBUNzExEUFBQS5Td9PS0vDwww9j1apV6NatGxISEjB//nzMmzcPn376qUvSpdFoHGvabd26FbGxsYiIiMC4cePQs2dP7Nu3DzNmzHA6Z/PmzZg/fz7+8Ic/ICEhAZGRkZg0aRKSk5Nx4MABTJs2zd23TkRuklvvvi9o3dpMRNTx5F+22GrnvSQhhFA6CE9UVlYGnU4Hs9nc6tkpRORs9f87heWfncTk1DismpGmdDhEBODp9w/jg4MXsXBsbzw1ro/S4ZAbWpubKLLOHRH5Bm5DRuR52HLn/ZjctcBoNCIlJQVZWVlKh0LU5cjJ3ZmrlSjnpAoixdXUW3H6in0FCs6U7TqysrKQkpICo9HYqvpurXPni3JyctgtS9RGUSH+iNUFoNBcgx8ulWFYz25Kh0Tk004WlcNiEwgP0iJOF6B0ONRKmZmZyMzMdHTLtoQtd0TUoQZwpwoijyF/Hw6M1zW7dix1fUzuiKhDOWbMXuKMWSKlHePixT6ByR0RdagB8fZhDWy5I1Je45Y78l5M7oioQ8ktBD8WV6Cy1qJwNES+q9ZixYnL5QBubA9I3onJHRF1KH1oAGLC/CEE8EMhu2aJlHKqqAL1VgFdoBaJkYFKh0MdiMkdEXW4gfHhAIAjF9k1S6SUo47xdmGcTOHlmNwRUYcblNAwY/ZiqbKBEPmwo5xM4TOY3LWAixgT3T45uTvCSRVEijnGyRRdFhcxbmdcxJjo9sn/mJwprkRZTT3CArQKR0TkW+osNuQXcjJFV8VFjInI43QL8Ud8uH0AN/eZJep8p66Uo85qQ2iABkndgpQOhzoYkzsi6hQ3xt0xuSPqbI7Fi+O4M4UvYHJHRJ1iUEI4AI67I1KCY/HiBHbJ+gImd0TUKRyTKjhjlqjTHS2wrzHJmbK+gckdEXUKeRC36Xo1SirrFI6GyHfUW2043rCAOGfK+gYmd0TUKXRBWtzRMJCb+8wSdZ7TVypQZ7EhxF+DpEhOpvAFTO6IqNPI4+6Y3BF1Hvn7rX9cGFQqTqbwBUzuiKjTyOPuDptKlQ2EyIdw8WLfw+SuBdyhgqj9yP+4sOWOqPNwpmzXxx0q2hl3qCBqP/3jdZAkoNBcgyvlNdCHBigdEpFXszSaTMGZsl0Xd6ggIo8V4q/BndEhALhTBVFnOF1cgZp6G4L91OjRLVjpcKiTMLkjok410DHujskdUUc71rC+Xf84HSdT+BAmd0TUqQZx3B1Rp3FsO8YuWZ/C5I6IOtVAeRuyi2YIIZQNhsjL3ZhMwbHjvoTJHRF1qv5xYVCrJFytqMXlshqlwyHyWlabwA+XuDOFL2JyR0SdKkCrRp+YUAAcd0fUkX4srkB1vRVBfmr0iApROhzqREzuiKjT3Rh3V6psIERe7MjFGztTqDmZwqcwuWsBFzEman/yjFn5Hx8ian/yTjCpDeNcqeviIsbtjIsYE7W/1EZ7zAohIElsVSBqb0culgIABiWGKxoH3T4uYkxEHq+PIQR+ahVKq+phul6tdDhEXqfWYsUPDTtTDGbLnc9pU3KXn5+P6dOnw2AwQK/Xw2g0Ijs7261rFBUVYeHChejVqxciIyMRFRWFKVOm4ODBg82es2XLFtx7771ISEhATEwMUlJS8PTTT6O4uLjJ+jabDa+//joGDBgAvV6PuLg4zJkzB4WFhW7FSkTty1+jRnKsfVLFoYbWBSJqP/mF5ai3CkQEaZEYGah0ONTJ3E7u8vLyMHToUFitVuTn56OoqAiZmZmYNWsWli5d2qprnD17Fmlpadi6dSveffddXL9+HcePHwcAZGRkYPfu3S7nvPTSS5g6dSr69OnjuO/bb7+Nd955B+np6bh27ZrLOY8++iieffZZvPrqq7hy5QoOHjyI/Px8GI1GXLx40d23TkTtKLWhq+jQhVJF4yDyRoflLtmEcA578EXCDTabTaSmporQ0FBRWlrqdOyRRx4RKpVK5OXltXidSZMmCQBiy5YtTuVms1nodDqRmJgoampqHOW1tbUiODhYREdHi7q6OqdzVq5cKQCIZcuWOZV/+OGHAoB47rnnnMpPnTolJEkSDz744C1jNJvNAoAwm80tvh8ict/mXJNI+u9/iQezvlA6FCKv89Q/D4mk//6X+POn+UqHQu2otbmJWy13+/fvx+HDhzFhwgSXAX0zZsyAzWZrcVZpTU0Ndu7cCQAYP36807GwsDCMHDkSJpMJ27Ztc5SXlJSgsrISPXr0gFardTqnd+/eAIDz5887la9evdoRV2N33nknjEYjPv74Y7beESlocGIEAODYpTLUWWwKR0PkXY40arkj3+NWcrdnzx4AQHp6ussxuWzXrl23vMa1a9dgsVgQEhKCgIAAl+MGgwGAPZGU6fV6xMTE4Mcff0RdXZ1Tfbk7d+DAgY6yuro6fPHFFwgODkbfvn2bjFUI0WT3LxF1jju6BSE8SIs6iw35l8uUDofIa1TUWnC6uAIAMCiRO1P4IreSOzmRio+PdzkWHR0NrVaL8+fPo7q6+dlvkZGRUKvVqKioQFVVlcvxK1euALCPy5NJkoS///3vqK2txeOPP47i4mJYLBbs3r0br7zyCkaPHo1f//rXjvqnT59GfX094uLimhxrIMefn5/f4nsuKytzetXW1rZ4DhG1TJIkx5IoeRx3R9Rujl40QwggThcAfahrIwp1HbW1tS55SGu4ldyVlpYCAIKDg12OSZKEoKAgp3pNCQwMxJgxYwDAqesVACoqKvDll186vm5s4sSJ2LlzJ3Jzc6HX6xEcHIyf/vSnmDdvHj777DP4+/u3Ks7G5SUlJc3GKUtMTIROp3O8li1b1uI5RNQ6g+VJFQ2LrRLR7ZMnU6Ryfbsub9myZU45SGJiYqvOU2Sdu5UrV0Kn0+HJJ5/E3r17YbFYYDKZMHPmTKjVagCuidmLL76IUaNGYezYsbhy5QoqKyuxe/dufPjhh7jnnntw4cKFDonVZDLBbDY7XosXL+6Q+xD5osHdwwEwuSNqTxxv5z0WL17slIOYTKZWnedWchceHg4AqKysdDkmhHB0s8r1mtO/f3/k5uZi/PjxmDNnDgwGAyZOnIhhw4Zh+fLlAIDY2FhH/b179+K5557DiBEj8NprryE6OhoajQYjRozAxo0bceDAAcyaNatVcTYuj4iIaPE9h4WFOb0atxAS0e2RF1c9e7USpVV1t65MRK1y2GTf1i+V4+26PH9/f5c8pDXc2n4sOTkZAFBQUOByrLi4GPX19UhKSkJgYMsLJvbs2RNr1651KV+xYgUAYMiQIY4yeXbt2LFjXeoPHToUISEh2LdvH65fv47IyEjceeed0Gq1uHTpUpNbG8nx9+vXr8U4iajjRAT7oUdUMM5ercQhUylG99UrHRJRl1ZcXouC0mpIEjAwnsmdr3Kr5U5OrpraRUIuGzdu3G0F9O2330Kj0WDq1KmOMnn8XXMLMapU9rdhNtt/W/Hz88M999yDyspKnDhxoslYJUnCfffdd1uxEtHtk8fdcVIF0e2Tu2R7RgUjNEB768rktdxK7kaOHInU1FRs377dkUjJNm3aBJVKhczMTEeZEKLJ/uEtW7Zg8uTJLuUFBQX45JNPsGDBAuj1N36Dv/vuuwEA+/btcznn0KFDKCsrg8FgQFJSkqP8iSeecMTV2OnTp5GTk4OpU6ciISGhNW+biDoQJ1UQtZ/DF+Uu2XBlAyFFuZXcSZKEdevWQQiBxx57DGazGUIIrF+/HtnZ2ViyZAkGDx7sqL9w4UJ0794dixYtcrpOSUkJtm7dipUrV8JqtQKwb2s2ceJEDB8+3GVG6owZMzBixAjs2bMHS5cudYyZO3r0KB599FFIkoTXXnvN0YIHANOmTcPMmTOxfPlyR7fu5cuXMWvWLMTFxWHVqlXuvHUi6iBycnf4YimEEMoGQ9TFyS13qZxM4dPcni2blpaGnJwcSJKEPn36QK/XY/Xq1diwYQNeeOEFp7qJiYkICgpymbqblpaGhx9+GKtWrUK3bt2QkJCA+fPnY968efj0008dS6rINBqNY027rVu3IjY2FhERERg3bhx69uyJffv2uexEAQD/9//+X7z00kv4/e9/D71ejyFDhqBv3744cOAAW+2IPERybBj8NCqUVtXj3DXXtS+JqHWEEDjc0ALOljvfJgn+qtyksrIy6HQ6mM3mVs9OIaK2mfbXL5F7oRQrfp6KB9P4ixdRW5iuV2Hk/+6FVi3h2Av3w1+jVjokametzU0UWeeOiKgxeZ9ZTqogajt53GpybBgTOx/H5K4FRqMRKSkpyMrKUjoUIq/FxYyJbt+NxYu5BIq3ycrKQkpKCoxGY6vqu7XOnS/KyclhtyxRB0trGB90vLAMNfVWBGjZ6kDkLnnxYu5M4X0yMzORmZnp6JZtCVvuiEhxCRGB6Bbsh3qrwPeXWrcxNhHdYLUJHLtkT+4GczKFz2NyR0SKkyQJaeyaJWqz01cqUFVnRZCfGr2iQ5QOhxTG5I6IPMKNnSpKlA2EqAuSv28GxuugVjW9mxP5DiZ3ROQR5BmzbLkjct/B8/bkLj0pQuFIyBMwuSMijzAoUQdJAi6WVONqRa3S4RB1KQcvMLmjG5jcEZFHCAvQOsYKcb07ota7XlmHM8X2bTnTujO5IyZ3RORB7mpodfju/HWFIyHqOuTxdj2jgxEZ7KdwNOQJmNy1gIsYE3Weu+6IBAB8d46TKohaK1fukmWrndfiIsbtjIsYE3Ue4x32f5yOXCzlYsZErcTJFN6PixgTUZfVPTII0aH+qLcKHLloVjocIo9Xb7U5dqYYwuSOGjC5IyKPIUmSo/Uu5xzH3RG1JL+wHNX1VoQGaHAnFy+mBkzuiMij3JUkj7tjckfUkoMNk4+GdI+AiosXUwMmd0TkUYzypIrzJbDZhMLREHm23IZlgzjejhpjckdEHiU5NhRBfmqU11hw8kq50uEQeTROpqCmMLkjIo+iUaswpLs87o5LohA157K5BgWl1VBJQGrD3sxEAJM7IvJAdzVMquC4O6Lmyevb9TWEIcSfK5vRDUzuiMjjGLmYMVGLbnTJhisbCHkcJnct4A4VRJ1vcGI41CoJBaXVKCitVjocIo/E8Xa+gztUtDPuUEHU+YL9NUiJDcPRAjO+O3cd8YPjlQ6JyKPU1Fvx/SX74sXp3SMVjoY6GneoICKvcGPcHbtmiW52rMCMeqtAVIg/EiMDlQ6HPAyTOyLySPK4O+5UQeSq8Xg7SeLixeSMyR0ReaS7GsYRnSgqh7m6XuFoiDyLnNzJywYRNcbkjog8kj4sAEndgiDEjSUfiAgQQji+JziZgprC5I6IPBb3mSVydeF6Fa5W1EGrljAgvuXB9eR7mNwRkccy3sGdKohuJk8y6h+nQ4BWrXA05ImY3BGRx7qrYVLFYVMpai1WhaMh8gxfn7kGABjWk0ugUNOY3LWAixgTKadXdDAigrSotdhwrKBM6XCIPMLXP9qTu+E9uykcCXUWLmLczriIMZFyJEmC8Y5IfPZDEb45c42Dx8nnma5XoaC0GhqV5FguiLwfFzEmIq8y4s4oAMBXP15VOBIi5cmtdoMSdAj2Z/sMNa1NyV1+fj6mT58Og8EAvV4Po9GI7Oxst65RVFSEhQsXolevXoiMjERUVBSmTJmCgwcPutT9/PPPoVarYTAYmnwFBwdDpVLhypUrTuf4+fk1e87+/fvb8taJqJONuNPe9ZRzrgQ19Rx3R75NHm83vBe7ZKl5bqf9eXl5GDVqFMaOHYv8/HzodDps2LABs2bNwqlTp7B06dIWr3H27FmMGDEC/v7+eO+992A0GlFcXIy5c+ciIyMD27Ztw3333ed0TmJiIs6dO9fk9YYOHYqwsDDo9Xqn8oyMDHz++efuvkUi8iC9okMQE+aPorJaHDxf4mjJI/I1QohG4+34fUDNc6vlTgiBxx57DACwfv16hIfbtz2ZPXs2Zs6ciRdffBGHDh1q8ToLFy5EYWEhXn/9dcfgwOjoaGzcuBGBgYGYM2cOamtrHfUjIyMxatSoJq+Vm5uLnJwcLFiwwJ23QkRdhCRJjoTui9PsmiXfde5aFS6X1UCrljj+lG7JreRu//79OHz4MCZMmOAyoG/GjBmw2WwtziqtqanBzp07AQDjx493OhYWFoaRI0fCZDJh27ZtjvJBgwZhw4YNTV7vjTfeQHx8PCZPnuzOWyGiLmREL3ty9yWTO/JhcqtdWmIEAv24vh01z63kbs+ePQCA9PR0l2Ny2a5du255jWvXrsFisSAkJAQBAQEuxw0GAwC0akxceXk5Nm3ahP/8z/+ERsOBpUTeSm65O1pghrmK+8ySb5LH293N8XbUAreSu+PHjwMA4uPjXY5FR0dDq9Xi/PnzqK6ubvYakZGRUKvVqKioQFVVlctxeVLE2bNnW4xn48aNqK2txbx585o8fuXKFcybNw/9+vWDXq9H3759MW/ePJw4caLFaxOR5zDoAnCnPgRCAF+fYesd+R7n8XZM7ujW3EruSktLAQDBwcEuxyRJQlBQkFO9pgQGBmLMmDEA4NT1CgAVFRX48ssvHV+35M0338TUqVMRGxvb5HGTyYRhw4bh4MGDKCgowLp16/D1118jLS2txRZGWVlZmdOr8VhAIuo8IxpaKzjujnzRj8UVuFpRCz+NCmndw5UOhzpJbW2tSx7SGoqsc7dy5UrodDo8+eST2Lt3LywWC0wmE2bOnAm12j6OoKkEsrGvv/4aR44caXYixfDhw3HhwgXMnTsXwcHB0Gq1yMjIwIcffoi6ujo8+uijrUrUEhMTodPpHK9ly5a5/4aJ6LY51rs7fU3hSIg6n9xql949gvvJ+pBly5Y55SCJiYmtOs+t5C48PBwAUFlZ6XJMCOHoZpXrNad///7Izc3F+PHjMWfOHBgMBkycOBHDhg3D8uXLAaDZ1jjZG2+8gZSUFIwePbrJ4/7+/oiIcJ1N1LdvXwwaNAiFhYX46quvbnkPwN76ZzabHa/Fixe3eA4Rtb+7e3WDSgLOXK1EQWnzQz+IvBHXt/NNixcvdspBTCZTq85zaxZCcnIyAKCgoMDlWHFxMerr65GUlITAwMAWr9WzZ0+sXbvWpXzFihUAgCFDhjR7bklJCd577z28+uqrrQ3dSVxcHPLy8lBYWNhi3bCwMG4/RuQBwgK0GJQQjkOmUnx5+ioevqt1v8ESdXU2m8A3Z64DYHLna/z9/eHv7+/2eW613I0dOxYAmtxFQi4bN26c20E09u2330Kj0WDq1KnN1lm/fj00Gg1mzZrVbJ2VK1fi1KlTTR67dOkSALgsekxEnu0eR9csx92R7zh5pRzXK+sQqFUjNSFc6XCoC3AruRs5ciRSU1Oxfft2mM1mp2ObNm2CSqVCZmamo0wI0WQT4pYtW5pcl66goACffPIJFixYcMvE680338TMmTNv2aK2cuVKfPTRRy7lp0+fxrFjx9CtWzdkZGQ0ez4ReZ4bixlfgxBC4WiIOoc83u6uOyLgp+GW8NQyt/4vkSQJ69atc+xUYTabIYTA+vXrkZ2djSVLlmDw4MGO+gsXLkT37t2xaNEip+uUlJRg69atWLlyJaxW+16ReXl5mDhxIoYPH37LSQt79+7FiRMnWrUjxUsvvYSPP/4YVqsVQggcOnQIDz30EIQQeOuttxyze4moaxiSFI4ArQpXK2pxsqjlGfVE3kBO7u7mEijUSm7/CpCWloacnBxIkoQ+ffpAr9dj9erV2LBhA1544QWnuomJiQgKCnKZ3ZGWloaHH34Yq1atQrdu3ZCQkID58+dj3rx5+PTTT2+ZdL355psYMWIEBg0adMs4N2/ejPnz5+MPf/gDEhISEBkZiUmTJiE5ORkHDhzAtGnT3H3rRKQwf40axjsiAXC3CvINNpvAt2c53o7cIwn2bTSprKwMOp0OZrOZEyqIPMib+37Esh35GNtPj7/PNiodDlGHOlZgxqS/fIFgPzUOPT8eWjW7ZX1Za3MT/l9CRF2KPO7umzPXUG+1KRwNUceSF+029ohkYketxv9TWmA0GpGSkoKsrCylQyEiACmxYQgP0qKyzoojF0uVDoeoQ+05XgQAuLcfV3fwZVlZWUhJSYHR2LreCrfWufNFOTk57JYl8iAqlYQRvaKw7WghPj9RjPSkSKVDIuoQJZV1OHi+BACTO1+XmZmJzMxMR7dsS9hyR0Rdzthk+z90n35/WeFIiDrO3hNXYBNAcmwYEiK4ugO1HpM7IupyxvaLgUYl4WRRBc5edd0Okcgb7G7okr0vma125B4md0TU5eiCtI41v9h6R96o1mLFv0/aJ1OMTY5ROBrqapjcEVGXdH9/+z94TO7IG3175joqai2IDvXHoPiWx1gRNcbkjoi6pHEpBgBA3oVSFJXVKBwNUfuSZ8mO7aeHSiUpHA11NUzuiKhLMugCMDgxHADw2Q9FygZD1I6EENh9/AoAdslS2zC5I6Iu6/7+9ta7z9g1S14k/3I5Ckqr4a9R4Z6GRbuJ3MHkrgVcxJjIc8nj7r7+8RrMVfUKR0PUPuQu2XvujEKgn1rhaMgTcBHjdsZFjIk8V8/oEPTWh+DUlQr8vxNFeDAtQemQiG6b3CV7Xwq7ZMmOixgTkU+Ru2Y/PcZxd9T1XSmvwSFTKQD7ZAqitmByR0Rdmpzc7TtZjJp6q8LREN2evfn2VrtBCTrowwIUjoa6KiZ3RNSlDYgPQ3x4IKrrrfj3yWKlwyG6LY4uWc6SpdvA5I6IujRJkjAuRV7QmF2z1HXV1Fux/5T9F5Sx3HKMbgOTOyLq8uSu2T35RbBYbQpHQ9Q2X/14FTX1NsTpApASy4l81HZM7oioyzPeEYGIIC1Kq+px4Nx1pcMhapMPcwsAAONSYiBJ3JWC2o7JHRF1eRq1ytE1u7nhH0iirqS4vNaxGPfPjd0Vjoa6OiZ3ROQV5H8QPzl8CdcqahWOhsg97x80od4qMDgxHClx7JKl28PkrgXcoYKoaxjSPRwD43Wos9jwbo5J6XCIWs1mE9h04AIAYOYwttqRK3d3qJCEEKKDY+qS5FWgzWYzd6gg6iI+OHgRT79/GHG6APz7mTHQqPn7K3m+fSeL8ejaAwgL0ODbZ+/jlmPUrNbmJvzJR0ReY9KgWEQG++GSuQa7fuCyKNQ1ZH9zHgAwbUgCEztqF0zuiMhrBGjVmDE0EQCw/qtzygZD1AqXzTXY07ArBbtkqb0wuSMir/Kru5OgVkn49ux1HC8sUzocolv6Z44JVpvA0Dsi0TsmVOlwyEswuSMirxKrC8T9/e3Lomxg6x15MIvVhndzGiZS3M1WO2o/TO6IyOvMzugBAPj4UAFKq+oUjoaoaZ+fKEahuQYRQVr8xwCD0uGQF2FyR0Rex3hHBJJjw1BTb8M/uSwKeajsb+0TKR66KxH+Gk6koPbD5I6IvI4kSZidkQQA2PjNeVhtXPGJPMvFkip8frIYADBjKLtkqX0xuWsBFzEm6pqmDI5HeJAWF0uqse1oodLhEDnUWWx4fsv3EAIYcWc39IgKVjok8nBcxLidcBFjoq7vf3fm46+f/wg/jQpZvxzi2H+WSCkWqw0L383D9qOX4a9R4R/z7kZ6UoTSYVEXwUWMicjnLRzbG/cl61FnsWH+OwexOfei0iGRD7PaBJ5+/zC2H70MP7UKbz6SzsSOOgSTOyLyWgFaNf72q3RMS4uH1Sbw1HuHse7Ls0qHRT7IZhN4dvNRfHzoEjQqCVkzh2B0X73SYZGXalNyl5+fj+nTp8NgMECv18NoNCI7O9utaxQVFWHhwoXo1asXIiMjERUVhSlTpuDgwYMudT///HOo1WoYDIYmX8HBwVCpVLhy5YrTeTabDa+//joGDBgAvV6PuLg4zJkzB4WFHH9D5Cu0ahWWP5SKx0bcAQB4YesPWLHrJCdZUKcQQqCqzoLnP/ke//zOBJUEvP6LNA4RoA6lcfeEvLw8jBo1CmPHjkV+fj50Oh02bNiAWbNm4dSpU1i6dGmL1zh79ixGjBgBf39/vPfeezAajSguLsbcuXORkZGBbdu24b777nM6JzExEefOnWvyekOHDkVYWBj0euffgh599FFs3rwZH3zwAR544AEUFhbiZz/7GYxGI7755hskJCS4+/aJqAtSqSQ8NykFEUF+eG3XSby+5xRe33MKgVo1gv3VCPLTIMhPjQCtGoFaNQK0KgRo7X/316jgp1HBT93wZ6O/a9UqaNQStGoVtGoJGpX9T7WqoVylglolQaOW7H+qJKikRl+rJKgb/i5/rVLB/qdkL1NJcJwjNXxtf9lnBXs7IQRsArAJAZsQEI6v7d2cQghYbTfqWG2ioRywCgGrzQaL7Ua5/Kq32v+02GywWO1/1jf+s+HrOov97/VW+9d1DX/WWqyotdjsr3orauptqK63oqbeiup6K6pqraistaCyzgL59whJAv78cComDopV9kMlr+fWhAohBNLS0nDmzBmYTCbodDrHsVmzZiE7OxsHDx7E4MGDb3mdn/70p/jXv/6FLVu2YPLkyY7ysrIydO/eHWFhYTh16hT8/f0BAEeOHMGf//xnbNiwweVaubm5SE9Px4cffohp06Y5yjdv3oyf/exneO655/DCCy84yk+fPo0+ffpg6tSp2Lx5c7MxckIFkXfa+PU5vLT9OGrqbUqH0i7kJE+CPfGD/T+oJHsyKOHGcTT+e6OvGw7hRq7omjTenEc6/8shnMoE7P9e3Pja/nfRUCAfdxyDPTlDo6/lRM5bhPhr8PxPU/DQXYlKh0JdWGtzE7eSu3//+98YNWoUfv7zn+Pdd991OrZjxw5MmDABc+fOxZo1a5q9Rk1NDUJDQ2GxWFBdXY2AgACn43Lid3Oy1pz//M//xPbt23Hu3DloNDcaIu+9917s3bsXx48fR79+/ZzOGTZsGHJycnDhwoVmW++Y3BF5rzqLDeU19aiqs6KyzoLKhlaWmnoraiw21NRbHa0xtRZrQ0uN/VVntaHeYkO91YZ6m3B8bbHZW3fsLT43WoTsrUPOf2/cwiS3OlmFgM0mYPWypKazyK2aN7d+qtX2VlK1o2XU3tIqt57Kf2rUqoY/b7TA+mlUDa2y9tZarUqCv1btaMWVW3UDG1p5Axpafe0twpqGlxrBfhoEatVQqby/pZU6VmtzE7e6Zffs2QMASE9Pdzkml+3ateuW17h27RosFgtCQkJcEjsAMBjsW7Ds37+/xeSuvLwcmzZtwn/91385JXZ1dXX44osvEBwcjL59+zYZ64EDB7B7927Mnj37lvcgIu/jp1GhW4g/uikdSDNu7mqUuyLlxM+pq9J2owWscdclcOPcm1vKGu5yU0ubo7SJeJqOs6leYQmSo/xGa+DNZZLjmFxfTs4a/ymhoTsaDWUq+/lqleTUPW3vsmbiRCRzK7k7fvw4ACA+Pt7lWHR0NLRaLc6fP4/q6moEBgY2eY3IyEio1WpUVFSgqqoKQUFBTsflSRFnz7Y8o23jxo2ora3FvHnznMpPnz6N+vp63HHHHU1+w8vx5+fnt3iPsrIyp7/7+/s7uouJiDqCJNlbkIjIt9XW1qK2ttbx95tzkua4NVu2tLQUABAc7LqatiRJjkRNrteUwMBAjBkzBgCwbds2p2MVFRX48ssvHV+35M0338TUqVMRG+s8OPVWcTYuLykpafEeiYmJ0Ol0jteyZctaPIeIiIjodi1btswpB0lMbN2YTUXWuVu5ciV0Oh2efPJJ7N27FxaLBSaTCTNnzoRabd88ubnETPb111/jyJEjWLBgQYfGajKZYDabHa/Fixd36P2IiIiIAGDx4sVOOYjJZGrVeW4ld+Hh4QCAyspKl2NCCFRVVTnVa07//v2Rm5uL8ePHY86cOTAYDJg4cSKGDRuG5cuXA4BLa9zN3njjDaSkpGD06NFuxdm4PCKi5ZXBw8LCnF7skiUiIqLO4O/v75KHtIZbY+6Sk5MBAAUFBS7HiouLUV9fj6SkpGbH2zXWs2dPrF271qV8xYoVAIAhQ4Y0e25JSQnee+89vPrqq00ev/POO6HVanHp0iUIIVzG3cnx3zyLloiIiKirc6vlbuzYsQDQ5C4Sctm4ceNuK6Bvv/0WGo0GU6dObbbO+vXrodFoMGvWrCaP+/n54Z577kFlZSVOnDjRZKySJLkslExERETU1bmV3I0cORKpqanYvn07zGaz07FNmzZBpVIhMzPTUSaEaLJ/+ObFi2UFBQX45JNPsGDBApfdJhp78803MXPmzFs2Tz7xxBOOuBo7ffo0cnJyMHXqVO5QQURERF7HreROkiSsW7cOQgg89thjMJvNEEJg/fr1yM7OxpIlS5x2p1i4cCG6d++ORYsWOV2npKQEW7duxcqVK2G1WgHYtzWbOHEihg8ffssZqXv37sWJEydanEgxbdo0zJw5E8uXL8fOnTsBAJcvX8asWbMQFxeHVatWufPWO0RtbS2WLl3qNM2ZlMVn4nn4TDwTn4vn4TPxPIo9E9EGx48fF9OmTRN6vV5ERUWJ9PR0sXHjRpd6f/rTn0RQUJB49dVXncoPHTokHn74YdGjRw+h0+lEfHy8GDp0qFi9erWor6+/5b1//vOfixEjRrQqTqvVKlasWCFSUlJEdHS0iI2NFbNnzxYFBQUtnms2mwUAYTabW3WvtuiMe5B7+Ew8D5+JZ+Jz8Tx8Jp6nvZ9Ja6/XpuTOF3hTcrd69eoOvX5n3qej78Fn4nn36Mx/sLzh8+qse3jT94q33IPPxPPuw+TOw8gfYJ8+fURycnKH/A/QWd+IycnJHXr9zrxPR9+Dz8Tz7tGZyZ03fF6ddQ9v+l7xlnvwmXjefdrrmaxevVokJyeLPn36tOp6bi2F4ktEw2aKe/bscUzcaO22H60lX6+9r3szq9Xa4fforPt09D34TDzvHp31TADv+Lw66x7e9L3iLffgM/G8+7TXM3nkkUfwyCOPoKysDImJiY4cpTmSaKmGj7p48WKrt/kgIiIi6iwmk+mWK34wuWuGzWbDpUuXEBoa6rIIMhEREVFnE0KgvLwccXFxUKmaX/CEyR0RERGRF3FrnTsiIiIi8mxM7oiIiIi8CJM7IiIiIi/C5E4B+fn5mD59OgwGA/R6PYxGI7Kzs5UOy6vV1tbin//8JyZNmgSDwYBu3bohOjoaEydOxO7du5s8p6amBs8//zx69+4NvV6PpKQk/O53v3PZV5na1xNPPAFJkjB79uwmj/O5dDyr1Yq//vWvGD58OLp3747w8HD06tULv/jFL3D48GGnunwencNqtWLDhg0YPnw44uLiEBMTg0GDBuGll15CRUWFS30+l/Z37NgxZGRkQJIknDt3rtl6bfnst2/fjp/85CfQ6/WIiYnBAw88gAMHDrQ92NtaVY/clpubK0JDQ8XUqVNFSUmJsNlsYt26dUKlUonnn39e6fC81m9/+1sBQCxevFiUlZUJIYQ4f/68uO+++wQA8Ze//MWpfl1dnRgzZozQ6/XiwIEDQgghTp48KXr37i0GDhzI7X06yK5du4QkSQKAePTRR12O87l0vOrqajFu3DgxfPhwcezYMSGEEPX19WL58uUCgFi3bp2jLp9H55k7d64AIP7whz+I2tpaYbPZxL/+9S8RGBgo0tLSRG1traMun0v7qq6uFs8++6yIjIwUUVFRAoA4e/Zsk3Xb8tmvWbNGABB//OMfRX19vaiqqhK/+c1vhFarFZ999lmbYmZy14lsNptITU0VoaGhorS01OnYI488IlQqlcjLy1MmOC+XmZkpRo4c6VJeXFwsAgMDhb+/vygpKXGU//nPfxYAxNq1a53q79mzRwAQTz75ZEeH7HNKSkpEQkKCeOSRR5pN7vhcOt6iRYtEt27dnL4fZNOmTRNbt251/J3Po3NcvHhRABCDBw92Ofa73/1OABCbNm1ylPG5tK/HH39cTJkyRZhMJjFq1KhbJnfufvYXL14UgYGB4ic/+YlTeX19vejZs6eIj48XVVVVbsfM5K4T7du3TwAQP//5z12Obd++XQAQc+fOVSAy77d161axc+fOJo+lpaUJAGLPnj2Osp49ewq1Wi3Ky8ud6tpsNhETEyNCQ0NFdXV1h8bsa2bOnCkmTZok9u7d22xyx+fSsYqKioRGoxGLFi1qVX0+j87xzTffCADi4YcfdjmWlZUlAIhXXnnFUcbn0r7OnTvn+Lql5M7dz/6FF14QAMTf/vY3l2s988wzAoB455133I6ZY+460Z49ewAA6enpLsfksl27dnVqTL5i0qRJuP/++5s8VldXBwDo1q0bAODs2bM4c+YM+vbti5CQEKe6kiRhyJAhKC8vxzfffNOxQfuQDz/8EJ9++inWrFnTbB0+l4738ccfw2Kx4O67726xLp9H5+nTpw8CAgJw/Phxl2Ny2cCBAwHwuXSEpKSkVtVry2ffUXkBk7tOJH8TxsfHuxyLjo6GVqvF+fPnUV1d3dmh+ayrV6/i1KlTSElJwaBBgwDc+jk1Ls/Pz++cIL1cUVER5s+fj7/97W8wGAzN1uNz6XgHDx4EAOh0Ojz33HPo378/oqOj0bt3b8yfPx8XLlxw1OXz6DwRERH4y1/+gvz8fDz77LMoKytDXV0d3n//faxZswYzZszAhAkTAPC5KKktn/2tzrmdZ8XkrhOVlpYCAIKDg12OSZKEoKAgp3rU8VatWgWLxYJVq1Y5tpm71XNqXF5SUtIpMXq7uXPnYvz48Zg+ffot6/G5dLxLly4BAB599FFcuHABu3fvxqVLl5CVlYWPP/4YQ4YMwYkTJwDweXS2uXPn4oMPPsC7774LnU6HkJAQzJs3Dy+//DL+8Y9/OOrxuSinLZ/9rc65nWfF5I581jfffINXXnkFf/jDHzB27Filw/FJf//735Gbm4vVq1crHQoBjl6DkJAQvP3224iNjYVWq8X48ePx2muv4dq1a/jd736nbJA+SAiBxx9/HA8++CDmz5+PkpISlJeX4x//+AdeffVVTJgwgY0C5ITJXScKDw8HAFRWVrocE0KgqqrKqR51nB9++AGTJk3CwoUL8T//8z9Ox271nBqXR0REdGiM3u7cuXN46qmn8Pe//71VnyWfS8eTWwrGjh0LjUbjdGzy5MkAgN27d6OmpobPoxOtX78eb731Fn71q1/hmWeeQXh4OPz9/TFhwgS8/vrr2LFjhyPp5nNRTls++1udczvPisldJ0pOTgYAFBQUuBwrLi5GfX09kpKSEBgY2Nmh+ZRjx47h3nvvxZw5c7B8+XKX47d6To3L+/Xr13FB+oDt27fDZrNh9uzZMBgMjte0adMAAP/85z8dZVu2bOFz6QR33HEHACAqKsrlWEhICIKDg2GxWHD9+nU+j060c+dOAGiyh0Eu++ijjwDw55eS2vLZ3+qc23lWTO46kfxNKA9abkwuGzduXKfG5Gvy8vIwZswYzJ8/H//7v//rKD937pxjvFGPHj3Qs2dPnDx50mXldyEE8vLyEBoa2qoZhdS8BQsWoLy8HJcvX3Z6bd68GQDw85//3FE2ZcoUPpdO8JOf/AQAcPnyZZdjVVVVqKyshEajQWRkJJ9HJ5I/X3lccGNyWUVFBaxWK5+Lgtry2XdUXsDkrhONHDkSqamp2L59u8s2JJs2bYJKpUJmZqZC0Xm/nJwcjB07Fv/1X/+FpUuXOh1bunQp3nrrLcffMzMzYbFY8P777zvV27t3Ly5fvoy5c+ciICCgM8KmRvhcOtbEiRORkJCAXbt2OZYIku3YsQMA8MADDzg+Yz6PziEnA/v27XM59u9//xsAcNddd0GtVgPgc1GSu5/9nDlzEBgYiE2bNjnVt1gs+OCDDxAfH48HH3zQ/UDcXhmPbktubq4ICQkRDz74oCgtLXXafuy5555TOjyv9eWXX4qwsDDRr18/8fzzz7u8UlNTnbZ/q6urE6NHj3bZQqZPnz7cvqeD3WoRYz6XjvfZZ58JPz8/8atf/Upcu3ZN2Gw28dVXX4mEhAQRGxsrzpw546jL59E5SkpKRN++fYVarRZvvPGGqKmpETabTezfv190795d+Pv7i3379jnq87l0nJYWMW7LZ//WW28JAOKll14SFotFVFdXi9/85jdCo9GITz/9tE1xMrlTwPHjx8W0adOEXq8XUVFRIj09XWzcuFHpsLzalClTBIBbvm7e27e6ulo899xzomfPniI6OlokJiaKRYsWuWwdR+3jj3/8o4iJiRERERECgAgICBAxMTFi4MCBTvX4XDred999JyZPniwiIyNFeHi46NGjh/jtb38rLl++7FKXz6NzlJaWimeffVb0799fhIaGCp1OJxISEsTMmTPF4cOHXerzubSfb7/9VsTExIiYmBih1WoFABEVFSViYmLEU0895VK/LZ/9tm3bxD333COioqJEdHS0uP/++8U333zT5pglIYRwv72PiIiIiDwRx9wREREReREmd0RERERehMkdERERkRdhckdERETkRZjcEREREXkRJndEREREXoTJHREREZEXYXJHRERE5EWY3BERERF5ESZ3RERERF6EyR0RERGRF2FyR0RERORF/j/erIpNIjWrkgAAAABJRU5ErkJggg==", + "text/plain": [ + "
" + ] + }, + "metadata": {}, + "output_type": "display_data" + } + ], + "source": [ + "import numpy as np\n", + "\n", + "data = np.fromfile('3d_lightcurve.bin', dtype=np.float64)\n", + "print(data.shape)\n", + "\n", + "plt.plot(data)" + ] + }, + { + "cell_type": "code", + "execution_count": 11, + "metadata": {}, + "outputs": [ + { + "data": { + "text/plain": [ + "[]" + ] + }, + "execution_count": 11, + "metadata": {}, + "output_type": "execute_result" + }, + { + "data": { + "image/png": "iVBORw0KGgoAAAANSUhEUgAAAnsAAAFxCAYAAAALR25sAAAAOXRFWHRTb2Z0d2FyZQBNYXRwbG90bGliIHZlcnNpb24zLjkuMiwgaHR0cHM6Ly9tYXRwbG90bGliLm9yZy8hTgPZAAAACXBIWXMAAA9hAAAPYQGoP6dpAABsD0lEQVR4nO3deZwU5bU38F/1Mj37DMssAsMoyjYqiGSMGgENLhG5Gg1qcEWvictE9DWGBPUGjEaMMXnfqHPdZYgiGoIxMRc1yjVqYogjAm6M4gKM7MvsS6/P+0f3U713V3V39Ta/7+fDR+mu7qrpAubMOc85jyKEECAiIiKivGTK9AUQERERkXEY7BERERHlMQZ7RERERHmMwR4RERFRHmOwR0RERJTHGOwRERER5TEGe0RERER5jMEeERERUR5jsEdERESUxxjsJeGjjz7CySefDEVRsG3btkxfTpCDBw/iqquugqIoaGlpiXu8EAJPPvkkhg8fjlNPPdXw6yMiIqL0sGT6AnLR4OAg7rrrLjzyyCMwmbIvXn766adx6623oqioSNPxn376Ka699lrs2LEDHR0dBl8dERERpVP2RSo54Oabb8bHH3+MzZs34+ijj8705QR57rnncN999+HFF1/EggULNL3m5JNPxty5c/G3v/3N2IsjIiKitGNmLwGLFy9GfX19pi8jopkzZ+J73/serFYrXn31VU2vef/991FfX591pWgiIiJKHjN7CdAb6P3v//4vzjzzTAwfPhzDhw/HxIkTsXjxYvT09KT82kaNGgWr1arrNdkauBIREVHyGOwZ7Mknn8Tpp5+OhoYGtLe34+DBg3jkkUfw5JNPYubMmejv78/0JRIREVEeY7BnoF27dqGpqQnHHHMMfvvb36KkpASKouC0007DkiVLsGnTJjz00EOZvkwiIiLKY1yzZ6DVq1fDbrfj7LPPDuvaPemkkwAAf/nLX7Bo0SIAQH9/P+677z5d57j55ptRWVmZkuslIiKi/MNgz0CffvopAODhhx/GihUrgp4TQqCkpAQHDhxQH+vv78edd96p6xwLFixgsEdERERRMdhLg8WLF2Px4sVxjxs5ciSEEGm4IiIiIhoquGbPQJMmTQIAtLe3R3z+ww8/xMaNG9N5SURERDTEMNgz0IUXXojCwkK8+OKLcDgcQc/Z7XacddZZeP311zN0dURERDQUMNgz0GGHHYaHH34Ye/fuxQ9/+EMcOnQIgLdL9+KLL0ZNTQ2uvfbaDF8lERER5TNFcJGYbu+++y7OPfdcAMChQ4fgdDoxcuRImM1mXHrppfjNb34TdPxbb72Fe++9F++++y4KCgpQVlaG7373u/jpT3+K4cOHp/z6xowZA5fLhd7eXvT19aG8vBxFRUU44ogj8K9//Svs+B//+MdYuXIl3G43Dhw4AKvVql7XX/7yF5xwwgkpv0YiIiJKDwZ7RERERHmMZVwiIiKiPMZgj4iIiCiPcc6eRh6PB7t27UJZWRkURcn05RAREdEQJ4RAT08PRo0aFbZTVyAGexrt2rULdXV1mb4MIiIioiDt7e0YM2ZM1OcZ7GlUVlYGADjyyCNhNpvxgx/8AD/84Q9Teo7u7m7U1dWhvb0d5eXlKX3vQI2NjWhtbTXs/dN1jnSch/ck+86TT/ckXefJl3sC5Mfnla5z5NPflXw5R6ruyWOPPYbHH38cbrcbX3zxhRqjRMNgTyNZun3//fcN/8esvLzc0HOYzWbDv4Z0nCOd5+E9yb7z5MM9Sdd58uWeAPnzeaXrngD58XclX84hJXtPbr31Vtx6663o7u5GRUVF3OVlbNAYgpqamvLiHOk8j9F4T7JPPn1e+XJPgPz5vHhPhuY5MoVz9jSS0XNXV5dhkX86zkH68J5kH96T7MN7kp14X7JPqu+J1vdjZi+L2Gw2LFmyBDabLdOXQj68J9mH9yT78J5kJ96X7JOpe8LMnkb8CYmIiIiyCTN7RERERMRgj4iIiCifMdgjIiIiymMM9oiIiIjyGIM9IiIiojzGYE+nxsZGNDQ0oLm5OdOXQkRERENQc3MzGhoa0NjYqOl4jl7RiKNXiIhS799fHsRd//MJfnHeMTh+7LBMXw5RTuHoFSIiynovf7QHH+3sxt8+3pvpSyHKWxkN9j766COcfPLJUBQF27ZtS+g9nn76aTQ2NqK6uhq1tbW48MIL8dlnn0U9vq2tDfPmzUNtbS2qq6vR2NiIlStXJvgVEBFRMuwuDwDA6fZk+EqI8ldGgr3BwUHcfvvtmDVrFrZu3Zrw+9xxxx1YsGABmpqasHfvXrS1tcHlcqGxsREffPBB2PEbN27ECSecALfbjba2NuzduxdNTU244oorsHTp0iS+IiIiSoTLF+S5GOwRGSYjwd7NN9+Mjz/+GJs3b8bRRx+d0Hts2LAB99xzDy677DIsWLAAiqKgsrISLS0tEELg6quvRuByRCEErrrqKgBAS0sLKisroSgKFixYgEsvvRR33XUXNm3alIovj4iINJIZPYeby8eJjJKRYG/x4sV48cUXMWbMmITfo7m5GUIIzJ8/P+jxiooKnH322diwYQPeeecd9fG3334bmzdvxpw5c1BRURH0mvnz58Pj8bDDlogozZy+II9lXCLjZCTYq6+vT/o91q1bBwCYPn162HPysddeey3h44mIyHhOlnGJDJeT3bj9/f3YsWMHCgoKUFVVFfb86NGjAXibMaQtW7YEPReoqqoKVqsV27dvx8DAgEFXTUREoWSw52QZl8gwlkxfQCI6OzsBAMXFxRGfLykpAQB0dHSEvUY+F0hRFBQXF6OrqwudnZ0oKiqKeu7u7u6g39tsNthsNj2XT0REPjLIczCzRxSX3W6H3W5Xfx8ak0STk5m9TKqrq0NFRYX6a9myZZm+JCKinOVwc/QKkVbLli0LikHq6uo0vS4nM3uVlZUAvOXcSPr6+gAAw4b5p7HL18jnAgkh1PeSx0XT3t4eNKWaWT0iosT5R6+wjEsUz+LFi3HLLbeov+/u7tYU8OVksFdcXIyxY8dix44d2L9/f9i6vZ07dwIAJk2apD42efLkoOcC7d+/H06nE/X19TFLuABQXl7O7dKIiFKEZVwi7RJdOpazZdzZs2cD8M7bCyUfO+OMMxI+noiIjOdkGZfIcFkf7Akh0N7eHvZ4U1MTFEXBqlWrgh7v6urCyy+/jOOPPx4nn3yy+viMGTMwdepUrF27Fl1dXUGvWbVqFUwmE5qamoz5IoiIKCIny7hEhsv6YG/hwoUYO3YsbrrppqDHp0+fjttuuw3PPPMMVqxYASEEurq6sGDBAgDAU089BUVR1OMVRcHy5cvVnTS6uroghEBLSwtWrlyJO+64A8cdd1wavzIiIuJQZSLjZSTYe/fdd1FbW4va2lp1l4vGxkbU1tbixz/+cdCxdXV1KC4ujrgA8e6778by5cvxwAMPoKamBhMmTIDZbEZrayumTp0advy0adPQ2toKRVEwYcIEVFdX46GHHsKKFStw5513GvPFEhFRVP7t0hjsERlFEYEbyFJU3d3dqKioQFdXFxs0iIhS5Bt3v44DvXaMHV6MtxadlunLIcopWmOTrC/jEhFR/mKDBpHxGOwREVHGMNgjMh6DPSIiyhh1zZ6LwR6RURjs6dTY2IiGhgY0Nzdn+lKIiHKaEELtxnV5uHycSKvm5mY0NDSgsbFR0/Fs0NCIDRpERKnldHsw/vaXAQBWs4Ktv5yT4Ssiyi1s0CAioqwWuE7P6RZg7oHIGAz2iIgoI5whu2awlEtkDAZ7RESUEaEduOzIJTIGgz0iIsqIsGDPxcwekREY7BERUUaEBnfcMo3IGAz2iIgoI5ye4ODO5WGwR2QEBntERJQRLOMSpQeDPSIiygiWcYnSg8EeERFlBMu4ROnBYE8nbpdGRJQaThfLuESJ0LtdmsXg68k7ra2t3C6NiCgFQocqs4xLpE1TUxOamprU7dLiYWaPiIgygkOVidKDwR4REWVEaHDncrOMS2QEBntERJQRoWVcZvaIjMFgj4iIMiI0uOOaPSJjMNgjIqKMYBmXKD0Y7BERUUawjEuUHgz2iIgoI1jGJUoPBntERJQRHL1ClB4M9oiIKCNCy7hcs0dkDAZ7OnG7NCKi1GBmjygx3C7NYNwujYgoNbhmjygx3C6NiIhyAsu4ROnBYI+IiDKCZVyi9GCwR0REGcEyLlF6MNgjIqKM4A4aROnBYI+IiDJCrtkrMJt8v2dmj8gIDPaIiCgjZHBXbDMH/Z6IUovBHhERZYQM7koKvFPAHC6WcYmMwGCPiIgyQpZxiwq8mT2Xh5k9IiMw2CMiooxQy7gFLOMSGYnBnk7cLo2IKDVCgz2WcYm04XZpBuN2aUREqeH0BXfFvjV7LOMSacPt0oiIKCc4fcFdEcu4RIZisEdERBnh78b1BXss4xIZImPBXltbG+bNm4fa2lpUV1ejsbERK1eu1Pz6U089FRUVFaitrQ37VVNTA0VR0NTUFPaa4cOHR3zNeeedl+ovkYiIYggt43K7NCJjZGTN3saNGzFr1izMnj0bbW1tqKiowIoVK3DFFVdg69atWLp0qab3+d3vfocFCxaEPb527Vqcc845mD9/fthzL7zwAk499dTkvgAiIkqaLOMWc/QKkaHSntkTQuCqq64CALS0tKCyshKKomDBggW49NJLcdddd2HTpk1x3+eEE07A6NGjIz73yCOPYMqUKTjllFNSeelERJRCYaNXWMYlMkTag723334bmzdvxpw5c8I6SObPnw+Px6NprMl9992HM844I+zx9vZ2rF27Ftdff33KrpmIiFIvtIzLBg0iY6Q92Fu3bh0AYPr06WHPycdee+21hN//8ccfR0lJCS677LKE34OIiIwXltljGZfIEGkP9rZs2QIAEUuwVVVVsFqt2L59OwYGBnS/t8vlwpNPPonLL78cpaWlEY95/vnnccopp6Curg61tbWYNWsWHn30Ubjdbt3nIyKixMlgr4hlXCJDpT3Y6+zsBACUlJSEPacoCoqLi4OO0+Oll17Crl27cMMNN0Q9Ztu2bXj00UfR3t6OzZs347TTTsMNN9yAuXPnwul0xj1Hd3d30C+73a77OomIyL83bgnLuESa2O32sDhEi7yas/fII49g1qxZaGhoiPj86tWr8de//hVHH300AKCmpgZLly7FJZdcgldeeQUPP/xw3HPU1dWhoqJC/bVs2bKUfg1EREOFWsa1+bZLY7BHFNOyZcuCYpC6ujpNr0t7sFdZWQkA6OvrC3tOCIH+/v6g47T68ssv8dprr8XM6lVVVcFsNoc9fuGFFwIA1qxZE/c87e3t6OrqUn8tXrxY13USEZH333uXJ2S7NDfLuESxLF68OCgGaW9v1/S6tM/Zmzx5MgBg586dYc/t378fTqcT9fX1KCoq0vW+jz76KGpra3H++efrvqZRo0YBAHbv3h332PLycu6NS0SUJGdAYFfM7dKINLHZbLDZbLpfl/bM3uzZswEAGzZsCHtOPhZppEosDocDy5cvxzXXXAOr1RrxmE2bNuHxxx+P+NyuXbsAANXV1brOS0REiQkM7PxDlQWEYHaPKNXSHuzNmDEDU6dOxdq1a9HV1RX03KpVq2AymYK2ORNCxE1TrlmzBocOHcK1114b9ZhNmzbhpz/9KQYHB8Oe+9Of/gQAOPfcc/V8KURElCBXUGbPX2RyspRLlHJpD/YURcHy5cvVnTS6uroghEBLSwtWrlyJO+64A8cdd5x6/MKFCzF27FjcdNNNUd/zkUcewbnnnht1Rw2po6MDl19+uVpC7u3txa9+9Sv8/ve/x7e+9S0sXLgwJV8jERHFFtiMUWj1fytiKZco9TKyN+60adPQ2tqK22+/HRMmTIDH40F9fT1WrFgRNgy5rq4OxcXFUTtO2tra8NZbb8UdxPy9730PiqJgzZo1mDlzJnp6ejA4OIiJEyfivvvuw4033oiCgoKUfY1ERBSdDOoKzCYUmBnsERlJEVwgoUl3dzcqKirQ1dXFBg0ioiRtP9iHWb/+O0oKzPjozrNwxOK1AIB3b5+N6rLCDF8dUW7QGpvk1Zw9IiLKDXJtnsVsgqIoanaP41eIUo/BHhERpZ0s11p9QZ7VrAQ9TkSpw2CPiIjSzr9mzxvkWS2moMeJKHUy0qCRyxobG2E2m9HU1BQ0IoaIKJb2Q/0YVVkEs0nR/dpdnQPYuq8XXQNOdA040e37rxACRVYzigosKLKaUFRghqIo8HgE3EJ4/+sRmDZ2GKbWVab+i0pCYBkXACwmU9DjRBRdc3Mzmpub4Xa7NR3PYE+n1tZWNmgQkS5vfrYfVz71Lq6dOQ6L50zW9dpdnQOYed8b6tZiiSi1WbDx52eoJdNs4C/jeoPfgjwo4z777x3Y1TmAW8+amOlLoTwnE06yQSMeBntERAbbsrsbAPDF/l7dr912sA8uj4DNYsK0sZWoKLKqvxRFwYDDjQGn75fDDY8QMCsKTCYFJgV49eO96LW70G93o6I4G4M935q9PCjj3rN2C3rtLlzcWIe64cWZvhwiFYM9IiKDdQ04AQCDTv2BjN33mvE1pXjuhyfpeq0QAkfethYeAdhdbgCRt5PMhNBgz2KSmb3cLOMKIdBrdwEADvU5GOxRVsmeH/OIiPKUDPa8AZc+8jWFFrPu1yqKgkKr93WJBJpGkkGdLOPKoC9XM3t2l/+65f0myhYM9oiIDJZMZk++xmZN7J9rm688mkigaaTQzF5BjpdxGexRNmOwR0RksK7+zGT2AGRxZs83esUi5+x5/+tw5WYZ1+7031sGe5RtGOwRERksFZk9GbTpJV+XfZk93+gV31o9+V+XJ7uCUq0C7y2DPco2DPaIiAyWijV7shyrl3xdtmb28qeMy8weZS8Ge0REBkvNmr3EMns2tYybZZk93xo3a0gZ15mjZdygzF4/gz3KLgz2iMgwg043zv/vf+JXr7Rl+lIyxuMR6B6UwZ7+gEu+JtnMXmADQTZQu3FDyrjOHC3jMrNH2YzBnk6NjY1oaGhAc3Nzpi+FKOt9vKsLG3d0YvV7X2f6UjKmZ9AF4UtW2V0eCKEvcyWDtGTX7GVdZs8TZahylgWlWnHNHqVTc3MzGhoa0NjYqOl4DlXWidulEWknv+n1O1wZvpLMCf3Gb3d5dAVuMkgrTHr0SnYFUbJcK4O8AnXOXq6WcZnZo/TRu10aM3tEZBh/sOeGJ4m9XXNZpGBPD3m8LenRK1mW2ZOjV2Rmzzdc2ZGzDRrM7FH2YrBHRIbpHvBn9PqzLNhIl7BgT+fnkGxmrzBbM3u+Mq46esUX9LnyILPXzWCPsgyDPSIyTGCg02cfmqXcTGf25M4bWZfZi1rGza6gVKvA+9pjd8E9RDPZlJ0Y7BGRYboZ7IUFe3qDruQze3KocnYFUaFz9mQZN1eDvdD7yuweZRMGe0RkmODMXnZlltKlc8AR9Hu9s/bszjzN7MlgL6SMm7MNGiEDs7luj7IJgz0iMoycLwcAfUO0Ize8jKsv6FL3xk06s5dtwV5wGdea62XckCCewR5lEwZ7RGQYrtkLL+fpzewluzeuzOyFBiOZFrZdWq6XcZnZoyzGYI+IDBPYjdvnyK7MUrqkKrOX6A4a6uiVrMvsydEr3iBPBn05O3qFmT3KYgz2iMgwzOxFatBIc2bPkq2ZPW8ZV67Vy/XRK6FBPIM9yiYM9nTidmlE2rEbF+js934GijeBxcyeT96VcZnZozTidmkG43ZpRNq4PQI9AQHeUO3Gld/0R5TYcKDXnoHMnq9BI+syezLYCy7j5mqwFxiU210eBntkKG6XRkRZoWcw+JvdUO/GrSm3AdA3AkUIoWbkbInujStHr2R5Zi/nR6/4guma8kIAQFc/gz3KHgz2iMgQgc0ZwNAs47o9Aj2D3q9bBgF6hhs73QLCF/skvDeuRe6Nm10ZM3X0Sp4MVZaZveoyb1DPzB5lEwZ7RGSI0G92QzHYC8xuyiBAT2YvMBuX6Jw9dfRK1mb2vEFerm+XFpbZY7BHWYTBHhEZojusjJtdwUY6yOaM4gIzSm3eJdJ6MntynZ2i+IMhvbI3sydHrwQPVXbkbBnXl9krZ2aPsg+DPSIyBDN7/s+gosia0LZl8libxQRFtvPq5B+qnF3Btits9Iriezy7glKtZBDPzB5lIwZ7RGQI+c3O7Nv7dChm9gKDvUS2LfN3eCa2Xg8IHL2SXUGUI+/KuN57JRtxQndOIcokBntEZAj5za7Gt1aNmT39w439Y1cS/6dazudzuDwQIntKpKHduHKP3FztxpWZveoyb2avx+6C25ObXwvlHwZ7RGQIGeiMqiwCwGAvkeHGMrOX6Iy90NfqWS9otNBuXIspt7tx1TV7vh9uAGb3KHsw2CMiQ8gGjcMY7AWXcXVk9uSxie6eAQCFAa/NpsHKeTdU2ffZltgsKCnw3muu26NswWBPJ26XRqRNl2/O3qgKb1mrz+HOqjJiOkRs0NCR2RtMQWbPYjap6yazabBy2HZpOVzG9XiEugbRZjGhosgKgMEeGYfbpRmM26URaSNLWIf5gj23R8Du8iQVuOQauYtCRZE1oW3LUpHZA7zZvT6HW1cnsNFkUCeDvFzO7AWWxwutZpQXWbGra5DBHhmG26URUVaQ3+hqK4rUx4ZaKVd+BpXFmcvsAYDNKjuBsyOQ8niE2rwg1+rl8pq9wA5rZvYoGzHYIyJDyDV7w4qtKPIFG/1DbPyK/GZfHrBmT89w48EUZva875cdn7/T4/8MZBduLpdx5X2ymBRYzAz2KPtkLNhra2vDvHnzUFtbi+rqajQ2NmLlypWaX79t2zaYzWbU1tZG/PXss88acl4i0kaWcSuKrSixeQOd3iGa2QsavaKnG1cOVc6zzF5gQBe6g4bbI+DJsZElMoiWGVgGe5RtMrJmb+PGjZg1axZmz56NtrY2VFRUYMWKFbjiiiuwdetWLF26VNP71NXVYdu2bWk/LxHFJoTwZ7UKrSixWXCg14F+xxAO9hLJ7PmCs8IkhioD/sxgtmT2AnfJUMu4Zv8OIU6PBzZT7qztlEG0/JwZ7FG2SXtmTwiBq666CgDQ0tKCyspKKIqCBQsW4NJLL8Vdd92FTZs25c15iYaiQadHzd5UFFlRUuD9ubLXnh3BRroEz9nTv22Z2qCRxFBlwJ9xypbRK7JzVVH8O6wE7v2ba6XcqJm9fgZ7lB3SHuy9/fbb2Lx5M+bMmRPWQTJ//nx4PB5Dxppk6rxEQ1HgVmnFBWa1jDuUGjRcbo9atq4sLlBLqXq2LVMbNFKV2cuS0SuBA5Xlnr/WwGAvS8rNWoVl9oqZ2aPskvYy7rp16wAA06dPD3tOPvbaa6/lzXmJhiLZnFFRZIWiKCixef+pGUrBXveg/2stL7SoMwbltmUyyIklXzN7MpgLzOaZTQoUBRAiuIEjFwyGrK1kGZeyTdoze1u2bAEAjB49Ouy5qqoqWK1WbN++HQMDA3Hfq7+/H7fccguOPvpo1NTUYNy4cbjkkkvQ2tpq6HmJKLbA8iUAtYw7lII9+RmU2iywmE1BTRZaGyXyNbPn8gVzgev0gMBZe7laxuWaPcpOaQ/2Ojs7AQAlJSVhzymKguLi4qDjYuno6EBtbS3+8Y9/YNeuXXjxxRfR3t6Ok046CS0tLYact7u7O+iX3W6Pe51EQ0232pzhDfLUMu4QGr0SGvAGblumtVEiNIhIlLovb5Zk9hyu4H1xJZnpy/kyLoM9Mojdbg+LQ7TI2Tl7dXV12L17NxYtWoRhw4bBbDZjypQp+POf/4zS0lLccMMN2Lt3ryHnraioUH8tW7Ys5ecgynWB8+UAoHgIZvY6+x0A/J9B4LZlWjN7oUFEouTr9Yx9MZIcnFwQEuzJfXJzbbBytAaNbgZ7lGLLli0LikHq6uo0vS7twV5lZSUAoK+vL+w5IQT6+/uDjovGbDZj5MiRYY8PHz4c3/72tzEwMIC1a9em/Lzt7e3o6upSfy1evDjm8URDUWiwV+pbszeUhiqru2f4PgNA/3BjuzM1O2hkW2YvWhnXkqNl3GiZvR67S90phCgVFi9eHBSDtLe3a3pd2hs0Jk+eDADYuXNn2HP79++H0+lEfX09ioqKwp7XatSoUQCA3bt3p/y85eXl3BuXKI7uAW8GT12zZ5OjV4ZOZq87pIwLeIOuPodbf2YvyTJutmX24pZxczyzVx5wz7sHnBhWUpCR66L8Y7PZYLPZdL8u7Zm92bNnAwA2bNgQ9px87Iwzzoj7Pi0tLREbMQBg165dAIDq6uqUn5eI4gscqAz41+wNpaHKoWv2AP3DjdUgIskGjazrxvUFc6HBXq6Wce0hw6+tZhNKCrz/z3V7lA3SHuzNmDEDU6dOxdq1a9HV1RX03KpVq2AymdDU1KQ+JoSImKZsaWnB8uXLwx7v7OzE3//+dxQUFOA73/lOwuclosQFjl4BMCSHKncFbBcnFerctixVmb3CBLZqM5J/zV6elHHV0Sv++8QmDcomaQ/2FEXB8uXL1R0turq6IIRAS0sLVq5ciTvuuAPHHXecevzChQsxduxY3HTTTWHv9fjjj+OJJ56Aw+FdCP3FF19g3rx56OzsxK9//WuMGTMm4fMSUeL8a/ZCunGHUBm3sz88s1eQocxeIlu1GUkGc5awzF6OlnFlZi9gbWU5gz3KIhnZG3fatGlobW3F7bffjgkTJsDj8aC+vh4rVqzAZZddFnRsXV0diouLwzpOHn30UTz33HN44oknsGTJEgwMDMBqteKkk07CunXrcNpppyV1XiJKXOh6taE4VDm0SQXQ3ygxqA5VTraMm1174/rLuMGZvYJcLePKzJ6FmT3KThkJ9gBg0qRJWLNmTdzjFi1ahEWLFoU9PnHiRCxZsgRLliwx5LxElLjQ9Wrq6JUhuGavMsKaPa3lVHlc8qNX9JWPjRZ9zV6OZvac4Zk9BnuUTXJ2zh4RZa8e31ZhskFDHb0yFNfspSCzl+zoFVuWZfZc7sjduBY1s5dba/YGIwTlDPYomzDYI6KUC9suzbdmj6NXmNkDAEeUMm6uZvbsEcrtDPYomzDYI6KUcrk9alBXHtKNa3d54Mqxb+SJijx6RXtmTwiRssxe9q7Zy5M5e+oexv6vp9LXhd3Vz2CPMo/Bnk6NjY1oaGhAc3Nzpi+FKCvJEi4QuDeuf3nwUNgf1+n2qF9nopm9wCxcsnvjZltmL9p2ablaxmVmj9KtubkZDQ0NaGxs1HR8xho0clVrayt30CCKQX5zKykwq6M1CiwmWM0KnG6BPrsrKADKR4Hf4MsTzOwFBma2pIcqZ1tmT45eyY8ybqTMHkevkJGamprQ1NSE7u5uVFRUxD2emT0iSqnQgcpSibo/bv6v25Pf4MsKLTCb/AGNmtnTEHTJY0xK+No2vfQOczZa3pVx2Y1LWY7BHhGlVKT5csDQ2kUj0no9QF85Vd09w2KGoiQX7Ondps1o8Uev5FgZl924lOUY7BFRSnUPBDdnSOr+uEOgIzdasKennKrunpHkej3ve2TX3rj+0Suh26Xl6lDl6Jm9bgZ7lAUY7BFRSkULdIrVzN4QCPYibJUG6CunBmb2kiUzTg63Bx5P5rNmjjwbqqxm9iLsjdtjd8GdBZ85DW0M9ogopdQybmFwoKMOVh4C3bjq7hnFoWXczGb2gOxYtxd1zZ4lN8u46po9S/jeuACze5R5DPaIKKWiN2gMncHKUdfs6cjspWrGHhC8lkzrQGcjOV3eYK4gZFi0xZSbZVx/YO6/V1azCSUF3t9z3R5lGoM9Ikopf4NG8GQn2aAxlLpxQ9ct6snspWr3DACwmE1qIKV1qzYjOT3ea7CYcn/0isvtgctXpg29V2zSoGzBYI+IUirSNmGAf/TKUO7G9e+Nq6WMGz6oNxn+9YKZ//ydUfbGVcu4rtwp4wYPvw6+V5y1R9mCwR4RpVTUBg1fGbdvKJdxLXIHDS0NGqnL7AW+T1Zk9nxfv9US2qCRe2Xc4OHXzOxRdmKwpxO3SyOKrdu3XVpYg8ZQKuP6unEriwqCHk8ks5eKNXt6z200l6+Maw0p41pMvsxeDnWvys+zwGyCKeTrYbBHRuF2aQbjdmlEsall3OLQzB7LuPpGrxiT2cuGblxHlDKuVS3jZv4atZLBni1C1zSDPTIKt0sjoozqjjp6hUOV9ZRSU53Zs2VRZi9aGbcgh8u4keYhytE7DPYo0xjsEVHKCCGiBjr+Bo2hG+z5d7JI75w9ILsyezKYKwjdQSOHy7iR7pOa2etnsEeZxWCPiFKm3+FWx1BEH72S+cySkewuNwZ8AUByDRqp20ED0LdVm9FkMCeDOykXy7j++8QyLmUvBntElDJyoLLVrKAopPwoM3v53o0rv7ErClBWGBzwysyew+2Ju4VW6jN72tcLGi2fyriRBipLHL1C2YLBHhGlTGD5UlGCS3TFvt0E+vK8GzdwzWJod2Zg9scRJ+jK68yeul1alKHKOVXGjb62kpk9yhYM9ogoZboHIo9dAfx74/bleTdutPV6QHBAEC/osqc4s6enE9hostQf2o1rMediGTd61zSDPcoWDPaIKGWibRMGBAxVdrggRO5kbvSKFeyZTYqazYoXdA26opcHE6Fnqzajyaxm2OiVHCzj2jVk9roZ7FGGMdgjopTpjhHsycyeEFAbGPJRrGAP8Jdl42f2oi/8T4SeTmCjRSvjFuTg3rhaMns9dlfcNZpERuJQZZ0aGxthNpvVgYZE5Bcr0CmymqEo3mCv1+5CcUF2/PMz4HBjw/YOdA860Wd3eX853BgI6BoOXH7o9gh4BOARAh6PgMsj0O9woc/uRq/dhR2H+gFED/YKrSb02v2Zu2iMyuxFyyj+obUdL32wC26P8H2N3q+zfkQx7vveFLXEGsl72w6h5Z1tcLo98AjvCB6P8M6Z+69zGjCsJHgnEX+wF6WM6w4PjLr6nXjoja042OeA2/e5ezwCJkXB1accgen1w6Jen9sj8NvXPsXebjtKCswoKrD4/mtWf/gYcLox6PtlNikotVlRVug9rrTQim/UD8PhI0vC3jvWmr3AH3q6B5wYVlIAj0eg3+mG1aykbD0mDT3Nzc1obm6G263th7fs+Nc2h3AHDaLo1DJuYfg/LYqioKTAgl67C/12N1CW7quL7JY/bMLLH+1J+fseVV0a8XG1KzbOYGWjMnvRMoq/XLsl4tqyDds7cMkJY/GNw4dHfe/fvvYZ3vniYMTnptcPw6XfrA96zBVtB40YZdwXN+3E429/FfEcA043nloQfduo1m2H0PzGF1Gf12JESQFabz89rOnG7oq+ttJqNqGkwIw+hxtn/b+3MOBwo9fhghBAmc2Cl248JWIASRSP3h00GOwRUcrI0SvRslolNjN67a6sGaz86Z4evPzRHigKMH3sMJTYLCi1WVBiM/sykcHf2IUQMJkUmBQFZvW/QLEvUyRfP6ykAI1RgiObxq5YmdmzpSGz5/b4h2Evu+BYlBVaYFIU3P/qp/jyQB864gwFPtjrAAD85ylH4KjqUpgU4IX3d+LfXx1CR58j7HhHAmXc/T12AMAJhw/HWcfUwqwAn+/vxTPrd+BghHMEOtDrfW3d8CJ897jR6LO7MeD0ZmPNJgWFVu/9LiowodBihssjvH9OB13osTux9sM9ONjnQI/dFfZne9AZu2t6fE0ZNrV3Yp/v+qUeuwuPvvUFll0wJea1E6UCgz0iSpl469W8g5XtWTNY+eG/fw4AOPuYWvz3pdPTck6t8+7SmdkLbCCYN32MmnFb9e4OfHmgL243aeeAN9j67nGjcewYb5bhi/19+PdXhyK+1r+DRmhmz/t7V4QyrjzHieOG4z9POQIA8O8vD+KZ9TviNkDIa5hcW44fnzkx5rGRTPqvlzHo9KB7wBkh2Iu+Ny4ArLj6BHy8qwulvh8ESgst2Lq3F5c+8W+seX8nbjljIqrKbLqviUgPNmgQUcqoo1eiZvayZ7By+6F+vPTBbgDADacelbbzap13l841e52+YKikwBxUWtU6OiRSkB/ttXLNI4CwdYAWX6bPESGz1xXhz1aFxr1n4/0QEk+szyHePMSKIitOPnIkpoypxLiqUlSXFeLkI0fguLpKOFwe/P5f2xK6JiI9GOwRUcp0x/mmKgcrZ0MZ99G3voDbIzBj/EgcMzr+mpdUKdSY2VMX/qdoEb8tRmYvWjBUKYOp/uhlUrvLrV5r4OtlUNYZUgIOLNHqKePGCyhjjfNJVbAX+rUAie10oigKrp05DgDw9Prt6M/zQeOUeQz2iChl5Jq9SEOVAf/4lUx/c9vXM4g/vPc1gPRm9QDta/bsccqDesUaqhxtPqKWzF607eEqo7w2ONiLXMb1CISNKokV7Lk9An0xlgZ09ScX7FUWFQRdQyD5eeoNys88uhaHjyhGZ78Tf2htT+i6iLRisEdEKRN3zZ4v2OvN8C4aT/1jGxwuD6aNrcSJ46J3mRpBBgWDcYcqRx/pkYhYQ5Wj3TctwZ7M5pbZLEGdqtFeG7geL3z0iv/1odk9eZ7KYv8YlyKrWc0OaglIZdlXr1h73MZbsxeN2aTgP2d4s3tP/OMruHJotiDlHgZ7RJQy/qHKkXu/Sny7aPRnsIzbNeDEM+u3A/Bm9UI7bo0mg4JYw42FEOouE6lv0NBWIg38vZZAKjAIC3xtaPOEDOJMijfgCRQY/IUGe5GuUVEU/zXG6Bg2cs3eYIKZPQC4cPoYDC8pwNcdA4aM/yGSGOwRUUo43R61lBa7GxfozWAZ95n129Frd2FCTSlmT6pO+/m1rNkLfC71DRrRu3GTCfa0vtYRZaBy6GOBg5WFEFHPo64NHIi+rjDWNn5axGzQSKLcXmg144qTvDMIH3vry7zeRpAyi8EeEaVEYAanLMqavWK5Zi9DZdwBhxtP/cM7mPf6U48MG5CbDloye4EDlwvTmNmrLI4cSMUK9jqjrIeTv+9zuIOydDKICx27AsA3u9D7/4Flzd6A7cbCmkg07D+busxeeECZTGYPAK446XAUWk34cGcX1n95KKH3IIqHwZ5OjY2NaGhoQHNzc6YvhSirdA96s3VlNktYeU4q9ZVxMzV65Q/vteNgnwNjhhXhP6aMysg1qEFXjMyeHLtiNikxtynTI+boFV+3bfTsXPT7FS/jBgQHYjKIs5gj/xmR2b3A8SvyHAVmU1jXq65Sc6INGjFGvNidyY3IGV5SgAun1wEAHnsruV0+aOhobm5GQ0MDGhuj7xwTiMGeTq2trfjkk0+4Ly5RCC2lMrkfbl8Gyrgf7ezCfa+0AQCunTkuZUGUXjJTFyuzp47zSFFWDwjoxk2gQaM7xmiTaPfdbFJQ5svkBgZJscq4QOD4Ff/5As8RusYyXrDn9gj0+H4QMXTOXhJd09fMOAKKArzx6X58vq834fehoaOpqQmffPIJWltbNR3PYI+IUkJLsFeqDlVObxn3645+XNXSij6HGycfOQLfP2FsWs8fyBajnCr5A4jUrNcD/HPgEhm94nB7ol5vrBKp7H7tDAiSnFH2xZWslvBZe/5zhDf+xAv2ArOKRqzZ8wfmid+r+hEl+Eb9MADAx7u6En4fomgY7BFRShzq8+79OaKkIOoxmRiq3NXvxILlrdjfY8fEmjI8cvn0qIFGOqgjUCI0SkhGZPbkDg8OtyfCDLvIma/SgJJ8tAaImMFehCDJFWVfXMniO19gsBdp7Eqsc0S6vtDdQfSItXYxFZk9AKguKwQAHIqzzy9RIjL2L15bWxvmzZuH2tpaVFdXo7GxEStXrtT8+q+//hp33303vvGNb2DEiBGorKzEUUcdhR/96EfYvXt3xNeceuqpGD58OGpra8N+nXfeean60oiGpEN93m+Ew2MEe+keqmx3ufHDp9/D5/t6UVteiOVXNUYd+JwuNrWcmpnMnvf9gwPNaN24QaNN4mTOQps7At+vW0cZ1xqjjBspoCyPs64w2eaMwNfG3EEjyZ1O5N+bDgZ7ZIDIw7AMtnHjRsyaNQuzZ89GW1sbKioqsGLFClxxxRXYunUrli5dGvc9GhoaUFhYiGeeeQann346AODVV1/FZZddhtWrV+Odd97BkUceGfa6F154AaeeemqKvyIikt+kYgV7JWks43o8Areu/gD//uoQymwWLL+qEaMqiww/bzyFOjJ7qZqx530vfzBid3oQmCSLl5071OeIOsdOb2YvXhm3IGYZV9s5Il1foiVcwB/I9gx6u4IDG5DUHTSSzOwN8/29ORRjazqiRKU9syeEwFVXXQUAaGlpQWVlJRRFwYIFC3DppZfirrvuwqZNm+K+j8fjwbJly3DmmWfCZDLBZDLh7LPPxi9+8Qvs27cPt99+u8FfCREFOugL9oZFKLVJcqiy0Q0aQgjcs3YLXtq8CxaTgkcun47Jh5Ubek6tNGX25L64KczsmU2KWjoNDDRdbo9aVo+dOUsi2AsIFJ2+4MgaJZCNVMaNNt4l6BwJXJ9Wga/tGQwMXP0lcVuymT1fQNnRF72rmChRaQ/23n77bWzevBlz5sxBRUXw5uPz58+Hx+PRNNbkpz/9Kf7jP/4j7PEZM2YAAN55553UXDARaaJm9kq1ZPaMC/ZkoPeEb57effOm4FtHjTTsfHppyuy5Up/Z875feKApR+YAiQVTegMxl8cX7EUZzxOrjBspOyfX8XVFyYilItizmk3qetPAryVw67lk1+zJzN5B39pXolRKexl33bp1AIDp06eHPScfe+211+K+z3/9139FfNzh8P6FHzFiRKKXSEQJkOWn4TEye3L0itPt3Q6sIMXBjBACd/11C576pzfQu+u7x+CC48ek9BzJKtSQ2Rs0ILPnfT8Teu3BgaacsVdqs0QcR5NM5ixSVtChtRvXldoybqQ1hXpUFFnR73AHnSewsznZwHxEiQ0AM3tkjLRn9rZs2QIAGD16dNhzVVVVsFqt2L59OwYGBhJ6f5nRmz9/fsTnn3/+eZxyyimoq6tDbW0tZs2ahUcffRRud2Y3ZifKdbKLcFhJ9G+qJQX+4CXV2T0hBO586RM10Lvn/GNx+Yn1KT1HKmjpxrWnMbMXL/Mlx51E2qFi0OlWA57IWbcIa/bilHELzOFlXC3BXvegK+IswFRk9gJfH9ikEbi2Mtk9luXfG67ZIyOkPdjr7OwEAJSUlIQ9pygKiouLg47TY3BwEM3NzZg0aRJ+9KMfRTxm27ZtePTRR9He3o7NmzfjtNNOww033IC5c+fC6Yz/E1V3d3fQL7udKXciwF/GlRmKSCxmkxrApHLdnhACS/7yMVre2QZFAe694Fhc8s3MzdKLJZOZPVlqDCw/xmtgiJU5kwGgokAdoBzptZ06yrgWky+zFzAeRu34jRHsuT0i4kifrhhlZj0ifQ7+5ozk71NgNy73yKVo7HZ7WByiRV7N2Vu0aBH279+P1atXq0FjoNWrV+Ovf/0rjj76aABATU0Nli5diksuuQSvvPIKHn744bjnqKurQ0VFhfpr2bJlKf86iHKNxyPQ0R8/swekfrCyw+XBz9Z8iN//azsUBfjV96ZkdGhyPOreuBnI7MnxIPaIJdLIq3oqiwqCjgsUmDWLtM9w5NErSZRxI5RiC60mddeNeNeYjEjBXiq7pmVjk8sjgtZREgVatmxZUAxSV1en6XVpD/YqKysBAH19fWHPCSHQ398fdJxWv/rVr7B8+XKsXbsWxxxzTMRjqqqqYDaH/wR24YUXAgDWrFkT9zzt7e3o6upSfy1evFjXdRLlo64BJ2QiJlY3LuBv0kjFYOW93YOY//h6PP9eOxQF+PW8qbjoG9r+8csUGXDF2kEjnZm9aDP2pFiZvfglYOPLuIqixOwYTsXolcBzBwd7qbtPhVazusyBs/YomsWLFwfFIO3t7Zpel/YGjcmTJwMAdu7cGfbc/v374XQ6UV9fj6Ii7fOwfv3rX2PZsmV49dVXceKJJ+q+plGjvBuiRxvGHKi8vBzl5dkxwoEoW8h1RuWFlri7FMiuxmQHK7+37RCuX/k+9vfYUVZowe++fxy+PakmqfdMB7WMGyuzJwf1JtnhGXZuGWhqbH4A/EFSZ6qCvbg7aASXcT0eoWld4YFee1oye91BZdzUZmCHlRSgzzGAQ/0OHI7wpU5ENpsNNlv0pTLRpD2zN3v2bADAhg0bwp6Tj51xxhma3+/uu+/Gr371K6xbtw4nn3yy+vh7772nduYCwKZNm/D4449HfI9du3YBAKqrqzWfl4j8DmkYqCyVJjl+RQiBp/+1Dd9/bL26BdpLPzolJwI9wB8YON0ibNsySd1BI8nZbWHnliXkCGv2EsnsxRq7Evh4v8OtBnku39dsNWkr4/Y6XGrWON55IjWRpCrYk80mgQ0aqZ6HyF00yChpD/ZmzJiBqVOnYu3atejqCt7wedWqVTCZTGhqalIfE0JETVPecccdePDBB/HGG2+EjXJpbGxUgzjAG+z99Kc/xeDgYNj7/OlPfwIAnHvuuQl/XURDmb8TN36wV5zEmr1+hws/Xr0Z//Xnj+HyCJwz5TC8cMPJOHxk7mRBAgODaNm9wQxk9iLtOwtoC6SilUjLAramk8c61DJutDl7wWVc2WBRYDFFDarUWXsxmkiMadBI7X2SSyAOMtijFEt7sKcoCpYvX67upNHV1QUhBFpaWrBy5UrccccdOO6449TjFy5ciLFjx+Kmm24Kep+f/OQn+OUvf4lvf/vbWLNmDZYuXRr0K5KOjg5cfvnlagm5t7cXv/rVr/D73/8e3/rWt7Bw4UKjvmyivObvxNWS2UtsF41P9/Tg3If+iRfe3wmTAtw2ZxIemj9NXQOYKwJLftHW7aUzsyczVVG7cQPGp4R2icbLmplNCsoKLUHHOuPsjSubLWQGUEtmLtretS63Bz2+DHK0YFarSOsC5f1L1X0akWBm783P9uOs//sW/tCqbf0WDT0Z+Vdy2rRpaG1txe23344JEybA4/Ggvr4eK1aswGWXXRZ0bF1dHYqLi4M6Tjo7O3H//fcDAJ577jlN5/ze974HRVGwZs0azJw5Ez09PRgcHMTEiRNx33334cYbb0RBQXL/GBANVVq2SpPkYGWtmT0hBJ5vbceSv3wMu8uD6jIbfvf9aTjpyNwcnG4yKSgwm+Bwe4IaJQIZndmL3I0bu0TqdAsMON3q/dPyWsBb/uwZdKnHqmXcKMGexZfZkxnAWGNXQq8xNLMX2NVaXpjct7tY3bgpy+wluD/u/3ywC5/u7cGiNR/g3W2HcNd5x6CoILU/KFBuy9iPxJMmTdLU/bpo0SIsWrQo6LHKykrdc4jKyspw5ZVX4sorr9T1OiKKT8tWaZKeNXu9dhdue+FD/GWzd0nGrAlV+M1FUzGyVP8C5Wxis3iDvcCgK5Ca2TOoG1fPmr2SAjPMJgVuX6NEYLCnNRBrx4BajlXLuFEaNPzbpXk0XR8Qff9e+ftou4PoEWvOXqoye4mu2Qv8wemPG77Gh1934b8vOx5HVpWm5Loo9+XVnD0iygwtW6VJJRrLuEIIXPnUu/jL5l0wmxT89DuTsHxBY84HeoA/iIuX2Uv5nD1r+Jq9eGvaFEVRg7lowZSWEqveMq6eYC9aZi9VzRlA5HWB6n1K8Zq9QzqDPTnG6KJvjMHIUhs+3duDcx/8B17avCvOK2moYLBHREnT1aBRoC2z19HvxIbtHQCA5394Iq4/9ciIg3tzUaE6WDlyZs9fHkzx3rgW/Zm9wOe6+o0P9ixqg4a3etOZgmAv2Rl7gefotbvg8n0NqdxBA/Bn9vQGe3KM0akTq7F24Sn45hHD0edw48ZVG7H4hQ9SvjUh5R4Ge0SUNH0NGtrW7O3u8u6PPbLUhm8cPjzJK8wu6v64UTJ7/vJgivfGtQYPdHa6PehzeK8hkTJpIoGYS91BQ18ZN1bAFq1jON7uIHoErvmTawFTnYFVy7ghQXU8vb6/SyU2C6rLC7Hymm+i6bQjoSjAqnfbcc4Db2Pjjo6UXCPlJgZ7OjU2NqKhoQHNzc2ZvhSirHFQV2ZPWxl3T5d3TNJhFYVJXl328Q9WTm9mTw0yfSNDAoOjWA0Mkfa4BbQFYqGBoiNOZi+RNXvpKONazCb1BxX5vqne6WS4b6tBvZk9mbmTne4Wswk/OWsSVv7nN3FYRSG2HezHvEf+hd+9vlXNSlJua25uRkNDAxobGzUdz2BPp9bWVnzyySdBswCJhjq1QUPDmj2tDRq7fMFebR4Ge5nO7MlhwDJ4K4vTwBA/c5b6NXsyA6i14zfwWPX6fGtJUxHsBb5Pp+99U76DRsC6QKeOoEyWcQObZwDg5KNG4pWbZmLulMPg9gj839c/w4WP/gv7usPnzVJuaWpqwieffILW1lZNxzPYI6KkDDrdailQSzeu1qHKe3xl3HzO7EVv0DBmb9zCkMye1jVt0caOyM5aOYsvksqi4MaGeGVcdfSKO2T0SoxzBF6fJ2BXkngDo/UK/RxSfZ8qiwug+D6W0JmBsfSqmb3w7GxFsRUPzp+G/3fxcSizWbBxRyceeuPzlFwv5Q4Ge0SUlA5flsNiUlCmYcCx1qHKu9UyrvZ9snOFzARFH71iUBk3JLOntcwZKdiT/2+Oc99DX2tkGdcjvNurhV5jqjN78n3V+5SizJ7Z5O987tA4a8/l9qhBZ7QB44qi4LvTRuPn/9EAAPh8X28KrpZyCYM9IkpKYCeuosTvli3RnNkbAmv2opVxncaUcUMze1q3EosV7JUXWmLe99BOXu2jV7SXcQutZhT4vrbAjuFUduMGXkN3SGYvlfMQh+nsyJVZdcC/HjaascOLAQA7OwcSvDrKVQz2iCgpHX3eb3xaOnEBoLxQBg4OuD3Rh6PvzuM1e7EaNNweoWa/Ul7GTTSzF2FNXKJZQadb2w4aMiiU5cxkAlLDM3sp3OlkuM5Ze3K9nsWkxP3hYPQwb5Z8V+dAULmb8h+DPSJKysE+OwBtW6UBQE15IaxmBU63wN4oC8WFEOrolXzM7MVq0HAEBIApb9AIXbOXRCCVaBDmUjN78UeveDwC3YP6ztMdFOy5NL1WKxn0yq/dnuK9cQH9s/Zko1OJLXaGFQBqywthNnn/7u3rsSd3oZRTGOwRUVLUTlyNmT2zScHoSm+GYceh/ojHdA041RJZTXn+BXuFIfPuAgUGgGnL7MVofgDilHE1BmEDvoYOR5zMnjWgjNtjd0HujJlIE4nWMrVWYQ0aRmT2dG6ZJmfsRWrOCGUxm1Dr+/u0szPy3z3KTwz2iCgph3QGewBQ51s7FC3YkyXcESUFKQ94soG/QSM8s2cP2DvWnOIdQ9S9cUO6cRPLmml7bVmhRe0wDRwpEnXNnsV7sMvtUc9ns5ji/jnISBlXduOmMLOnrtnT2KDRb5djV7Rdgyzlft3BdXtDCYM9IkqK/KakZaCyJIO9r6MGe95vRPm4Xg8I38kikH9XhtQHuTIoGQyZs6c1a9bZ74QQ2hsnAMAU0K3bNeCMW8a1mLzflhxuETA6JX6wFrp/r9PtUUeSGJ3ZS9XeuID+NXu9AWVcLcZUMtgbihjsEVFS9DZoAP6uwHiZvXxcrwdoy+ylsjSonjdKZq9SY7Dn8gj0O4I7eTUFYkHDgrWWcT26MnOhO3Vo3R1Ej/A5e6kPzHWv2XNEn7EXyRhfZo8duUMLgz2duF0aUTC1QSOBYK89SnZhTx534gLa1uwZmdlzugXcHqF5TVtxgRkWX0lZBjp6ArHAMnC8OXuyjKs32AsNxOR/4+0Ookd4N27qA3P//rhaGzS8f170lnF3MrOX0/Rul5aaH3eGkNbWVpSXl2f6MoiyhszsadkqTaobpjWzl38DlQF/cBAps6cGewZm9uS5tQZTiqKgosiKg30OdA04MaqyKKFArHPAoa7Zk0FdKFnGdbmF5o7f4HMEB3upmrEHhG/LZkRgPkxt0NC2g0ZfjN0zIhldmdisvT67Cz/+w2acfWwtzjtutK7XUuo1NTWhqakJ3d3dqKioiHs8M3tElBS5Zk9Pg4bM7O3vsWPAER7w5PPYFcAfHETK7Pn3xTUusyfPrStgCwl0OnXsOxs4WFlulyaDulAy4+cIyOxpCdhCm0hS3ZwR+F79Dm9nsT+zl8Iyrs41e3061+z5GzT61fWXWqxr24dXPt6D372+VfNrKHsw2COihAkhdI9eAbyBQ5lvHdXXHeHZvXweqAz4M3uR5uzJx4xYs2cyKeoOFX12l7r+LpkyqZZAzL+ezuUv40aZIZjqMm4qg72yQv97Heyzq2NhUtqg4dtfesDpjviDUCi5g4bWYG9Upffv1KDTozmgBIDP9/YAALYd7IuYkabsxmCPiBLWPeiCyzeJf1iJvm+q/nV7wcGeECJgq7T8LOPKrF2kHTTUbJEBmT3vub3/7O/r8Q+01pM58wdT2jtdA1/r1DhU2RXQjZtI5jHVM/YA3z7Avh9S5J9RILX3qqTArAbkWsavqJk9jWv2bBYzqstsAPSVcrf69tP1COCrA32aX0fZgcEeESVMZvVKbRbdZUd13d7B4GCve9CfccrXMq6WzJ4Ra/a87+u9T3u6vI01ZTaLpnl+gWVSIbQ3dwQe09HvULNh1ihlXEtAGVft+E0gGNWz3k8PuW5vb7f381OU6IFrIhRFUX9w0jJYWe/oFSCxJg0Z7AHA1r29MY6kbMRgj4gSdrBPztjT/w117IjIHblyvd6wYmteDlQG/Jk9R4TM3mCaMntyqzqtDQyBwdSg06OWYys1NObIAOlAr3+LrmhlXKs5QhlXx5y97gEnPB6h67V6yM9hvy8zWmgxx92mTK9hOtbt6W3QAKDuYKN11p7D5cG2gGxeYOBHuYHBHhHFJITAO58fUPdRDaSu19PRiSvVDYu8ZZp/vV5+lnCB2Jk9u8GZPXluuTeqljl5QPBgZRlImU2KpvKhfO2BXn/wEi0bJkuYQvh/mNAzZ88jgF6Hy5A1e4HvJzN7RqytHFGqI9jzZcGLbdp/OBgzTF9H7vaDfepyDQD4fF+P5nNRdmCwR0QxvfrxHlzyxL+x5C8fhT2XyFZpktxFoz0k2NuT5wOVgYA9ajOyZs/7vvt8mT2twVBgZi8wkNKS1fIHewGZvThl3MDjtVxjodWsZi27+p2GB3tyzaMRXdOJZPYSKeNqzezJTJ4s98cr4+rp8qX0YLBHRDH98/ODAIB/fH4w7B/xRLZKkwKDvcD33d2Z32NXAH8pNRsye1qDofIowZ4W8riDvuDNbFJgirJOMDDjd0hHZi/wuESuUSv5fnsMzOzpGaycSBlXbpmmNbMng7uTxo0A4G3QkI02oXoGnZj167/jwkfeCWoCosxisEdEMX3wdScAb5Zld1fwP97JlHFHVxZBUbxlqMAMRr5vlQYE7KARa82eQesVZSZqr87MXuDes3LGnt71frISGKuhITDj5/a9IJF1hcYFe94/6zIzmvHMnkPfDhpA8Kw9Lbb6yrYzxo9ESYEZLo/A9oORO3L//eUh7DjUj9ZtHTi/+R1s3cuSbzZgsKcTt0ujocTucuOT3d3q72XgJ8k1VXI2mB6FVjNqyrwBXWCTxp7u/F+zJzN7bo+AKyRDIjN7hVEaGJKVaGYvsBtXbyAVGqxF2yoN8M4CDO0OTiSzZ8TolcD3k59fxtfsJdGg0TPoQvdg/J06PveVcSfUlOGomjIA0Uu5G9s71P/f2TmACx5+B+98cUDztZE2erdLY7CnU2trKz755BM0NTVl+lKIDNe2u0fduB4ANrV3BT2fTGYP8M/aC2zSGEqZPSA8uyd31bAZlNmT59a7nVjgHDu9wV6ZzYLApX2xgj3v8/6Di6xmzdmzwGCv0+BgTwZiRtwnrZk9j0eoY4r0rNkrsVkwzHc/441fcbk9+HK/N4t3VHUpxleXAojekbtxRycAYNF3JuIb9cPQM+jClU+9izUbvtZ8fRRfU1MTPvnkE7S2tmo6nsEeEUUlM3nyG3VoZi+RrdIChTZpCCGGxJq9goBgxx6ybm/QJfdbNWjOXsj7JpM10zL/DvBm6wLPE28uXWAwqCdYC1wbqGd3ED1C38+I+6R1zV5/wJ8dPZk9QHuTxo5D/XC4PSiymjG6sihmsOf2CGxu7wQAzJ5Ug2eu+SbOmXIYnG6BH6/ejEff/ELXNVLqMNgjoqhkJm/2pGoAwIdfd8ETMIIhmW5cAKgb7v2GI4O9HrtLXYOUr1ulAb5ty2SThiu0jJuezJ6kN9hzeYSafU0kEAPiZ/YKEg32fNmq9kP+AEZr5lLzOULez4i1lf7MXuwSqyzhmhT9Qacs5e6Ms25PBnVHVZfCZFIwvsYX7EVYi/fZ3h70OdwotVlwVHUpCq1mPPj9abhu1pEAgPte/VTNClN6MdgjoqhkJm/e9DoUWk3osbvwZcBw1UN9iXfjAuFbpu0JCCKKC/RlKnKNXJMXLbNn1Jq90KBA65y9IqtZzcht9wXniQZ7BXGCPUtA5i+Rc8hlAWWF2nYH0SP08zIisyfX7HX0O4J+uAoVuHuG3sHOWmftyfV6MqM3vtq7Zu/LA31h601lCXdqXYX6uZtMCn529iSMqyqB2yPwry8O6rpOSg0Ge0RDwM7OAdz50sdqB6EWvXYXPt/v/Yf++PpKHD2qAoA/AHS4POgZ9H6zGZFkGVd+cx4K6/UkmbmTa/Qkmdkzqhs30cyeovhLsXKLu0SDPYuOMq6ezFxosJfqEm6k9zTiPsmA0u0R6t+xSBJpzpBGaxy/IjN4R/kyeqMri1BoNcHh8oTtfrNxh7c5Y1rdsLD3mXHUSADAPz7fr/taKXkM9oiGgGVrt2D5P7fh/r99qvk1H+3sghDewKu6rBBTx1QCgLomR47fMClAeWFi31RlZm9X5yBcbs+QWK8nqbtouHJjzR7gD7z26NxqLfRYw8q4vmPllntGBHuhX7MR3bg2i1kN4A7FWLfXZ9c/dkXSumZPLeNWeYM9k0nBUdWRS7kbff82TBtbGfY+M8ZXAQDe3srO3ExgsEeU5wadbrzRtg8A8None8NKL9HIoE4GeVPrvJm9zV971/GpA5WLC6IOyI2nqtSGAosJbt86sKGwVZokO0ztac7sha4F1BMQhTZkGLVmL9kyrqx8GhHshXYWGzFnD/DvNx2rIzeZzN6YYXLNXvRgz+0R/jKub+QK4C/lBjZpdA041WOPq6sMe68TjxwBi0nB9oP9amaY0ofBHlGee3vrAbXpoaPfiX9/dUjT6z7wBXVTfEGeDPo+2d0Nh8uDQ73JNWcA3iyB3CO3/VD/kNgqTcpUZi80iCzTkZUNDZ4SD/a0l3G1rimMdD1GBHsmkxKUyTYiswcAw0tsAOIEew79W6VJYyq9WfWDfQ4MOMJ3cgG8gaDd5UGBxaT+PQWgZvY+Dwj25A+Hh48oxohSW9h7ldosOH6st7z7Nku5acdgjyjPvfzRbgD+fS3Xfrhb0+s2+9bmySCvfkQxKoqscLg8+HRPT1JbpQUKXLe3Wx2onP/BXsYyewFBpN4GhtDgKdFALP6cveTKuIm8Vo/Ar9uozN5w3zk6Ymb29M/Yk8qLLGpGMNq6PblzxriRJUF7FvvHr/jLuLI5Y9rY8PV60ozx3nV7b3/GUm66MdgjymMOlwevf7IXAHDtzHEAgFc/3qtuQxXNwV67upbnmNHezJ6iKJgyRpZyO5MeqCwFDlaWa/ZGDYEyrswI2UMye/L3xu2N6w9O9AZDyQRTlWlcs5fIa/UIfF+jMnvyh6jYa/Z8mb0E1uwpiqI2aUTbNm1rhBJu4O8/39erdgu/L5szIqzXk07xBXvvfHFA83ISSg0GezpxuzTKJf/68iC6B10YWVqAhbPHo6zQggO9dmzY3hHzdbKEO66qJOgbW2CTRjJbpQWqGybHrwyoZdyhkNkrjJLZk925hQZljAIze8kEexaToqsxIB1r9kKbJ1I9Y08KDvaMyuz5xq/EyOwFjl5JhLpuL1pmb2/w2BWpblgRCiwmDDo92Nk5AI9HYJNszojQiStNGVOJ8kILugdd+GBnV9TjKD5ul2YwbpdGueQVXwn3zKNrUWg144zJNQD8pd1oQku4kszsffB1V8oye7KMu2V3N3p837yGQrBni7JmT2b20jF6RU8ZFggOniqKrLpmuyW6Zk9PwFZoNQdl2vR+fVoFXpNRayvlD1EHYwR7/Y7EGzQAf0dutCaNz31l2tBgz2I2YdzIEgDeUu5XB/vQNeCEzWLCpMPKwt5HMpsUfEuOYGFXblK4XRoRAfB20v3tY28J9+xjagEA3/H999WP9kCI6KVctTnDF9xJsstu674etcybTIMG4C/jysXeZYWWhL955RKZuRsMGKrs9gh1L+J0jF5JJrOn97V6Rq8kumYv9Pj0lHEzmdmTo1cSDPZizNoTQgSUcUvDnpel3K17e9X1elPGVMS9t/4RLGzSSCcGe0R56t2vDuFgnwMVRVacOG4EAGDmhCoUF5ixq2tQHaESSgihDk6eGjJCobq8ELXlhfAIb4kYSD7Yk1umSUNhvR7gz+wFlnED1++lI7OXTCClt0Sqr0EjsTJu6PGGNWikIbOna82eLbE/K7Fm7e3qGkS/ww2LSUH9iJKw5wP3yFWHKcdozpBkk8bGHZ3oGQzeOs3h8uDqllZc8N//RPcgt1VLpYwFe21tbZg3bx5qa2tRXV2NxsZGrFy5Uvf7PP3002hsbER1dTVqa2tx4YUX4rPPPjP8vETZTpZwz2ioUb+5FlrNOM23z220Uu7OzgEc6HXAYlLQcFh52PNy3p7caD7ZbtyyQiuGBZTbhkIJF/B3cQaWcQN300hHZi+ZgE13EFacWBk3G4O9wPc1ag9j+UNU7G7c5Mq46pZpEYI9OTD5iJElEYPz4GCvEwAwLcJ8vVB1w4tx+IhiuDwC678MHgN1/98+xf+27cP7Ozpx2wsfxqw+kD4ZCfY2btyIE044AW63G21tbdi7dy+amppwxRVXYOnSpZrf54477sCCBQvQ1NSEvXv3oq2tDS6XC42Njfjggw8MOy9RtvN4BF75eA8AfwlXmnPMYQCAV6KUcmUJd2JtWcTs0pSQdXyJbpUWSK7bA4bGjD0gcmZPlnQLzKaEB1XHk0xmrzJgfabe9XClBRbIL0lrGbe4wIwCnUFv2su4Ro1ekZk9DXP2ihNds+cr4+7tGYTDFdwo9HmMEm7g45/t6UHbnm4A2jJ7QORS7t8/3YfH3voSgHdt318/2I0/vNeu9UuhONIe7AkhcNVVVwEAWlpaUFlZCUVRsGDBAlx66aW46667sGnTprjvs2HDBtxzzz247LLLsGDBAiiKgsrKSrS0tEAIgauvvjroG1mqzkuUCza2d2Jvtx2lNos67kA6dWIVbBYTth/sx5bdPWGvlc0ZoUGdFDodP9nMHhAc7A2VzF5hhMye3fcN16ixK0DwqJB0Zs1MJv/eunFHr1iUhM4BhDeRGCE4s2dQg4YvsO4edMEZZUyJnLNXmmAZd2RpAWwWE4TwbzEnyU7co6ojN1zUjyiBxaRgwOmGx7etota/u/LfJNmksa9nELeu3gwAuOKketx65kQAwJK/fBy2JRslJu3B3ttvv43Nmzdjzpw5qKgIXvw9f/58eDweTWNNmpubIYTA/Pnzgx6vqKjA2WefjQ0bNuCdd95J+XmJcoEs4X57UnXY0NcSmwWzJlQFHRfog3ZvZu+4uoqw5wD/3D0p2W5cwD9+BRg6a/Zkhi1SZs+oQb2h753uEqk/2IudtbSYTEmfA9C3O0ii5zAqs1deZFUzoR1R1u355+wlltkLnLUXWsrdGqUTV7KaTThipH8t3/Eas3oAcNKRI2A2KfjyQB/aD/Xjx3/YjAO9DkyqLcNtcybj2pnjMGP8SAw6Pbhx1cagJiZKTNqDvXXr1gEApk+fHvacfOy1115L+fuk6rxE2U4IgZc/8pZw5xxbG/GYs32Py+Mkj0fgw52yE7cy4msriqzq2IUiqxlFCQx0DTV2CGb25Nq5QVdgg4bcPSM7M3uFVpM68Di5YE9bGTeROXmVRd4fPsp17g6iR+D6Q6Mye2aTopbNO/oiNysks12apDZpBHTkxuvElQKfizVMOVR5oVWtEPzo2ffx9tYDKLSa8NAl01BoNcNkUvCbi6ZiZGkB2vb04Jf/s0XHV0SRpH2+wZYt3ps2evTosOeqqqpgtVqxfft2DAwMoKgo8k/4/f392LFjBwoKClBVVRX2vHzvtra2lJ7XSE63R/2HnigZn+7pxtcdAyiymjFrQnXEY749qQZWs4Kt+3qxqb0T9b5ga/uhfvTaXSi0mqL+RA94u3S/PNCXdCeuFNiRO1TW7MnMXme/A18d6IPbI/CF7xusUc0Z3vcOmLNXpO/+KYqC8iIrDvTaEwrEyrUGe0mUcSuKvN/WKgyasec9h/GjVwDvur1DfY6o6/aS2S5NkoOVdxzsh8vtgdmkYF+PHT2DLpgUBGXvQnlLvN4fGPUEe4C3K3fD9g51KsDS/zg6qGRcXVaI3150HK546l08vX47vjluOE6dGPnfs2xmVpSU/ECcrLQHe52dnQCAkpLwP0CKoqC4uBhdXV3o7OyMGnTJ9yguLo74vHzvjg7/LgGpOC8AdHd3B/3eZrPBZgvf9FmvP23ciUV/DG8qIUrUqROrov4jU1FkxbeOGom/f7of323+Z9jzx46uCNoLM9SUMRX408adGFaSmm+oQzmz9/bWAzjt/r8HPWdkAJHMnD3va7y7sCST2bPE68ZNpozrC/KMWq8X+t5GBuZyiUSkYE8IEZDZS/zPiyzjPvTG53jojc+hKN7dUQDg8BElMZcUyB8IrWYFR4+KvOwjmhnjq/D/Xt8KADjn2MNwcWNd2DEzJ1Th2lnj8OibX+JHz27U9f7Z4rSJVVh+1Qkpez+73Q673a7+PjQmiYZz9nSqq6tDRUWF+mvZsmWZviSiMIVWEy47sT7mMQtOPhxFEYIKi0nBBcePifna7xxTi6OqS3H+tNjHaVU3rBinT67BBdNGG7bOKtt8c9xwjB1ejOICM8psFlQUWTG8pAA15TZc9I3wb3ypYjIpmD2pGseOrsCoSv2B9dwpozB2eDGm12tfoyWdeXQtasptOPnIETGPO3HcCFQUWXHqxPDKTTzT6oah1GZROz6NUGqzoPHwYTh6VDmGpWDNajQj1F007GHPDTjdkD2IyQwhnzWhGmUBrxcC6mDvmRNif4bfHDcc5YUWnOXboUePqWMqMGVMBSbVluGeC46NuhvLrWdOjPvnZShZtmxZUAxSV6ft3wpFpHmQzUUXXYTVq1dj5cqVuOSSS4KeE0LAZrPB6XSiv78/Zhm3pKQEBQUFQRGutHLlSlx22WW4+OKL8dxzz6XkvN3d3aioqEB7ezvKy/2zx1KV2XO5PXDF2ZyeSCuLSYmZmZOEEOo3jMA/fUatdaLsIP/Z17PdWboJIRK+Ppfbo+nPfzLk3x2jRuQAwM///BF+/6/t+NFpR+HWsyYGPbevZxAn/HIdFAX48p45Sd1Ll28ZkdPtgcPtgdMt4PEIjBlWFPd9XW4PFEVJ+N8Mj0do+gxztUnDpCi6xwfFEimzV1dXh66urqDYJFTay7iTJ08GAOzcuTPsuf3798PpdKK+vj5mKbW4uBhjx47Fjh07sH///rB1e/K9J02alNLzAkB5eXnMDzRRFrMJBjbgEUWkKAqy+Ps9GSSbgzwpmWs0OtAD0vN3p6rUm0jY3xOe1FDX6xVYkr6f3u8/iX1myX7WWoNlI5c25JJEE0xpL+POnj0bgHdOXij52BlnnJHy90nVeYmIiNKhutz7TX1fz2DYc8lulUZDS9qDvRkzZmDq1KlYu3YturqC9+ZctWoVTCYTmpqa1MeEEGhvD5+i3dTUBEVRsGrVqqDHu7q68PLLL+P444/HySefnPB5iYiIMqmqzJfZ642U2Utuxh4NLWkP9hRFwfLly9UdLbq6uiCEQEtLC1auXIk77rgDxx13nHr8woULMXbsWNx0001B7zN9+nTcdttteOaZZ7BixQoIIdDV1YUFCxYAAJ566qmg1Lbe8xIREWVSVam3gSZiGTcFM/Zo6MhIN+60adPQ2toKRVEwYcIEVFdX46GHHsKKFStw5513Bh1bV1eH4uLiiB0nd999N5YvX44HHngANTU1mDBhAsxmM1pbWzF16tSkzktERJRJsox7oNcBd0gDX686Y49lXIov7d24uUp248breCEiIkoFl9uD8Xe8DCGA9+44HSNL/Qvzn3t3B372woc4fXI1nriyMYNXSZmkNTbhnD0iIqIsZDGbMMK3S01oKbfXt2avmGv2SAMGe0RERFlKZvP2hQR7qdgqjYYOBntERERZSu3IDQn2+n0NGqVcs0caMNjTqbGxEQ0NDWhubs70pRARUZ6rLvN25IbO2mMZd2hrbm5GQ0MDGhu1rdfknxKdWltb2aBBRERpES2zJ+fsJbMvLuWupqYmNDU1qQ0a8TCzR0RElKWiBXu9XLNHOjDYIyIiylLVZZEbNPod3C6NtGOwR0RElKVkZu9AlDIut0sjLRjsERERZalomT3ZoMEyLmnBYI+IiChLycxer92llm4BoN/hXbPHBg3SgsEeERFRliq1WVBo9X6rPtDjUB9XR69wzR5pwGCPiIgoSymKEjZrTwjB0SukC4M9IiKiLBY6fsXu8sAjvM9xzR5pwWCPiIgoi4U2acgSLgAUW1nGpfgY7OnE7dKIiCidQjN7fepWaWaYTErGrosyh9ulGYzbpRERUTpVlQYHexy7QtwujYiIKI9Ul8syrrdBg2NXSC8Ge0RERFlMLeP2Bmf2igu4Xo+0YbBHRESUxapKfaNXuoPX7LGMS1ox2CMiIspisox7sM8Bt0eg384yLunDYI+IiCiLjSgpgKIAbo9AR7+DZVzSjcEeERFRFrOYTRhRUgDAW8rl7hmkF4M9IiKiLDey1N+k0efrxuWaPdKKwR4REVGWkx25+7oH2aBBujHYIyIiynLVZd6O3P29/jJuCdfskUYM9nTidmlERJRugVumcQcN4nZpBuN2aURElG5qGbfHzh00SPd2afyTQkRElOWqAzJ7DpcHAEevkHYM9oiIiLJcYBnXYlIAMLNH2nHNHhERUZYLzOz1c/QK6cQ/KURERFlOZvZ67S443d4ybomNZVzShpk9IiKiLFdqs6DQ6v2WbXfJYI/5GtKGwR4REVGWUxRFnbUnMdgjrRjsERER5QBZypVKChjskTYM9oiIiHJAdUCwV2g1wezryiWKh8EeERFRDgjM7HHsCunBYE8nbpdGRESZUFXqD/a4Xm9o43ZpBuN2aURElAnV5f5gr5jr9YY0vdulMbNHRESUA4LLuJyxR9ox2CMiIsoBVaX+0Sss45IeaQ/2BgcHsWTJEowfPx7V1dWor6/HzTffjK6uLs3vYbfb8fzzz2Pu3Lmora3FiBEjUFVVhXPOOQevv/56xNe0tLSgqKgItbW1EX9t27YtRV8hERFR6gWWcRnskR5pDfacTifmzJmDRx55BM8++yz27duH119/HWvXrsWMGTPQ3d2t6X1+8pOf4Pvf/z6mTJmCrVu34uDBg9iwYQMcDgfOOOMMPPTQQxFfd/HFF2PPnj0Rfx1++OEp/EqJiIhSa0RJARTftJWSApZxSbu0BnsPPvgg3njjDdx7771qB8n48ePxyCOP4MMPP8TSpUs1vY/H48GMGTNwzz33oKysDAAwduxYrFq1CkVFRbj11lvR2dlp0FdBRESUfhazCSNKCgAws0f6pDXYa25uhtlsxoUXXhj0+GmnnYaamho88cQTGBwcjPs+3/nOd3D77beHPT5y5EhMmjQJdrsd77//fsqum4iIKBuM9I1f4Zw90iNtwd5XX32FL7/8EhMnTkRpaWnQc4qi4Pjjj0dPTw/Wr18f973mzp2Ls846K+JzDocDADBixIjkL5qIiCiLyI5cjl4hPdIW7G3ZsgUAMHr06IjPy8fb2toSPseBAwewdetWNDQ0YMqUKWHPf/7555g/fz7Gjx+PqqoqHHPMMbj55puxc+fOhM9JRESULtPrhwEAGkZx3itpl7ZgT66hKykpifi8fLyjoyPhczzwwANwuVx44IEHoCjhewZ+/vnnmDdvHj7++GPs2LED999/P9asWYMpU6Zg8+bNms7R3d0d9Mtutyd8vURERHrcNHs8NtxxOmZNqMr0pVAG2O32sDhEC9154HvuuUctlWqxYMGCtHS6rl+/Hvfeey9+8YtfYPbs2WHPX3TRRfje976nNnQA3rV/LS0tOP3003H11Vdjw4YNcc9TV1cX9PslS5ZobiwhIiJKhqIoGBGwbRoNLcuWLcOdd96p+3UJBXt9fX2ajz/11FNx+OGHo7KyEgCivlY+PmzYML2XhE8++QRz587FwoULIzZuAEBxcXHEx2fPno1hw4bh/fffx1dffYUjjjgi5rna29uDtkuz2fiXjoiIiIy3ePFi3HLLLervu7u7w5JQkegO9np7e/W+BAAwefJkAIi6Pk4+PmnSJF3v+9FHH6mZufvuuy+haxs1ahQ6Ojqwe/fuuMFeeXk598YlIiKitLPZbAklmdK2Zu+II47AuHHj8Nlnn4UFjEIIbNy4EWVlZTjxxBM1v+fGjRtx2mmn4brrrgsK9LZt24Zdu3YFHbt06VLs378/4vvIY6urqzWfm4iIiCgXpHXOXlNTE1wuF1avXh30+BtvvIE9e/bgmmuuQWFhYdBzBw4cQH9/f9h7tba2Yvbs2fjJT34StmZu6dKleOyxx4Ieu/POO/HGG2+Evc+bb76Jjo4OTJ48GUcddVSCXxkRERFRdkrroJ4bb7wRL730En72s5/hmGOOQWNjI7Zu3Yrrr78exx57bFjQtn79esyYMQNVVVX4/PPP1XV377zzDs4++2yMGjUK/f39Ya/btGlTxKaQH//4x6iursbMmTMhhMA///lPXHXVVSgpKcGTTz5p0FdNRERElDlpDfasVitefvllLFu2DN///vfR09ODwsJCXHDBBbjzzjvD1sJVVFRgxIgRqKurg8Xiv9T77rtPbTmO1pXy3e9+N+j3f//737F69WosXLgQ+/btw8DAAIYPH47TTz8dP/vZz3DkkUem/OslIiIiyjRFCCEyfRG5oLu7GxUVFejq6jKsQcNut2PZsmVYvHgxu3yzBO9J9uE9yT68J9mJ9yX7pPqeaI1NGOxplI5gLx3nIH14T7IP70n24T3JTrwv2SfV90Tr+6W1QYOyQ3Nzc16cI53nMRrvSfbJp88rX+4JkD+fF+/J0DxHpjDYG4Ly6S9Nvvzl5D3JPvn0eeXLPQHy5/PiPRma58iUtDZo5DJZ7T7++ONhNpvxgx/8AD/84Q9Teg65x53Wve4S5Xa78+Ic6TgP70n2nSef7km6zpMv9wTIj88rXefIp78r+XKOVN2Txx57DI8//jjcbjcAf4wSDdfsafT1119r2pKEiIiIKJ3a29sxZsyYqM8z2NPI4/Fg165dKCsrg6Iomb4cIiIiGuKEEOjp6cGoUaNgMkVfmcdgj4iIiCiPsUGDiIiIKI8x2CMiIiLKYwz2skBbWxvmzZuH2tpaVFdXo7GxEStXrsz0ZeU1u92O559/HnPnzkVtbS1GjBiBqqoqnHPOOXj99dcjvmZwcBBLlizB+PHjUV1djfr6etx8883o6upK89UPHT/60Y+gKAoWLFgQ8Xnek/Rwu9347//+b5x00kkYO3YsKisrceSRR+L73/8+Nm/eHHQs74nx3G43VqxYgZNOOgmjRo1CTU0NpkyZgl/+8pfo7e0NO573xBgfffQRTj75ZCiKgm3btkU9LpHPf+3atZg5cyaqq6tRU1ODs88+G++++27iFysoo95//31RVlYmvvvd74qOjg7h8XjE8uXLhclkEkuWLMn05eWtG2+8UQAQixcvFt3d3UIIIbZv3y5OP/10AUA8+OCDQcc7HA5x2mmnierqavHuu+8KIYT47LPPxPjx48Wxxx4rurq60v415LvXXntNKIoiAIgrr7wy7Hnek/QYGBgQZ5xxhjjppJPERx99JIQQwul0ivvvv18AEMuXL1eP5T1Jj2uuuUYAEL/4xS+E3W4XHo9H/PWvfxVFRUVi2rRpwm63q8fynqTewMCAuO2228Tw4cPFyJEjBQDx1VdfRTw2kc//8ccfFwDE3XffLZxOp+jv7xfXX3+9sFqt4m9/+1tC18xgL4M8Ho+YOnWqKCsrE52dnUHPXX755cJkMomNGzdm5uLyXFNTk5gxY0bY4/v37xdFRUXCZrOJjo4O9fHf/OY3AoB46qmngo5ft26dACD+z//5P0Zf8pDS0dEhxowZIy6//PKowR7vSXrcdNNNYsSIEUF/H6QLLrhAvPTSS+rveU+M9/XXXwsA4rjjjgt77uabbxYAxKpVq9THeE9S79prrxXnnXeeaG9vF7NmzYoZ7On9/L/++mtRVFQkZs6cGfS40+kU48aNE6NHjxb9/f26r5nBXga9+eabAoC4+OKLw55bu3atACCuueaaDFxZ/nvppZfEK6+8EvG5adOmCQBi3bp16mPjxo0TZrNZ9PT0BB3r8XhETU2NKCsrEwMDA4Ze81By6aWXirlz54o33ngjarDHe2K8vXv3CovFIm666SZNx/OeGG/9+vUCgLjooovCnmtubhYAxL333qs+xnuSetu2bVP/P16wp/fzv/POOwUA8fDDD4e916JFiwQA8cwzz+i+Zq7Zy6B169YBAKZPnx72nHzstddeS+s1DRVz587FWWedFfE5h8MBABgxYgQA4KuvvsKXX36JiRMnorS0NOhYRVFw/PHHo6enB+vXrzf2ooeINWvW4NVXX8Xjjz8e9Rjek/R48cUX4XK5cOKJJ8Y9lvckPSZMmIDCwkJs2bIl7Dn52LHHHguA98Qo9fX1mo5L5PM3Ki5gsJdB8i/m6NGjw56rqqqC1WrF9u3bMTAwkO5LG7IOHDiArVu3oqGhAVOmTAEQ+z4FPt7W1paei8xje/fuxXXXXYeHH34YtbW1UY/jPUmPDRs2AAAqKirw85//HEcffTSqqqowfvx4XHfdddixY4d6LO9JegwbNgwPPvgg2tracNttt6G7uxsOhwOrV6/G448/jvnz52POnDkAeE8yLZHPP9ZrkrlfDPYyqLOzEwBQUlIS9pyiKCguLg46joz3wAMPwOVy4YEHHlB3Sol1nwIf7+joSMs15rNrrrkGZ555JubNmxfzON6T9Ni1axcA4Morr8SOHTvw+uuvY9euXWhubsaLL76I448/Hp9++ikA3pN0uuaaa/DHP/4Rzz33HCoqKlBaWoof/OAHuOeee/Dss8+qx/GeZFYin3+s1yRzvxjsEfmsX78e9957L37xi19g9uzZmb6cIefJJ5/E+++/j4ceeijTl0I+sqpQWlqKJ554AocddhisVivOPPNM/Pa3v8XBgwdx8803Z/YihxghBK699lqcf/75uO6669DR0YGenh48++yz+PWvf405c+YwQUBhGOxlUGVlJQCgr68v7DkhBPr7+4OOI+N88sknmDt3LhYuXIjbb7896LlY9ynw8WHDhhl6jfls27ZtuOWWW/Dkk09q+hx5T9JDZhJmz54Ni8US9Ny5554LAHj99dcxODjIe5ImLS0teOyxx3DZZZdh0aJFqKyshM1mw5w5c/C73/0OL7/8shqA855kViKff6zXJHO/GOxl0OTJkwEAO3fuDHtu//79cDqdqK+vR1FRUbovbUj56KOP8O1vfxtXX3017r///rDnY92nwMcnTZpk3EXmubVr18Lj8WDBggWora1Vf11wwQUAgOeff1597M9//jPvSZocfvjhAICRI0eGPVdaWoqSkhK4XC4cOnSI9yRNXnnlFQCIWH2Qj/3pT38CwH+7Mi2Rzz/Wa5K5Xwz2Mkj+xZSLoAPJx84444y0XtNQs3HjRpx22mm47rrrcN9996mPb9u2TV2vdMQRR2DcuHH47LPPwqbTCyGwceNGlJWVaepYpMhuuOEG9PT0YM+ePUG/XnjhBQDAxRdfrD523nnn8Z6kycyZMwEAe/bsCXuuv78ffX19sFgsGD58OO9JmsjPVq4pDiQf6+3thdvt5j3JsEQ+f6PiAgZ7GTRjxgxMnToVa9euDds2ZdWqVTCZTGhqasrQ1eW/1tZWzJ49Gz/5yU+wdOnSoOeWLl2Kxx57TP19U1MTXC4XVq9eHXTcG2+8gT179uCaa65BYWFhOi6bfHhPjHfOOedgzJgxeO2119SRRNLLL78MADj77LPVz5n3xHgyMHjzzTfDnnvrrbcAAN/4xjdgNpsB8J5kmt7P/+qrr0ZRURFWrVoVdLzL5cIf//hHjB49Gueff77+C9E9mY9S6v333xelpaXi/PPPF52dnUHbpf385z/P9OXlrX/+85+ivLxcTJo0SSxZsiTs19SpU4O2q3M4HOLUU08N2/JmwoQJ3HLIQLGGKvOepMff/vY3UVBQIC677DJx8OBB4fF4xDvvvCPGjBkjDjvsMPHll1+qx/KeGK+jo0NMnDhRmM1m8cgjj4jBwUHh8XjE22+/LcaOHStsNpt488031eN5T4wVb6hyIp//Y489JgCIX/7yl8LlcomBgQFx/fXXC4vFIl599dWErpPBXhbYsmWLuOCCC0R1dbUYOXKkmD59unj66aczfVl57bzzzhMAYv4K3Zt4YGBA/PznPxfjxo0TVVVVoq6uTtx0001hW91R8u6++25RU1Mjhg0bJgCIwsJCUVNTI4499tig43hP0uO9994T5557rhg+fLiorKwURxxxhLjxxhvFnj17wo7lPTFeZ2enuO2228TRRx8tysrKREVFhRgzZoy49NJLxebNm8OO5z1JrX//+9+ipqZG1NTUCKvVKgCIkSNHipqaGnHLLbeEHZ/I5/8///M/4pRTThEjR44UVVVV4qyzzhLr169P+JoVIYTQnw8kIiIiolzANXtEREREeYzBHhEREVEeY7BHRERElMcY7BERERHlMQZ7RERERHmMwR4RERFRHmOwR0RERJTHGOwRERER5TEGe0RERER5jMEeERERUR5jsEdERESUxxjsEREREeUxBntEREREeez/A9CXx9JdRCW+AAAAAElFTkSuQmCC", + "text/plain": [ + "
" + ] + }, + "metadata": {}, + "output_type": "display_data" + } + ], + "source": [ + "plt.plot(g-data)" + ] + }, + { + "cell_type": "code", + "execution_count": 12, + "metadata": {}, + "outputs": [ + { + "data": { + "text/plain": [ + "[]" + ] + }, + "execution_count": 12, + "metadata": {}, + "output_type": "execute_result" + }, + { + "data": { + "image/png": "iVBORw0KGgoAAAANSUhEUgAAAncAAAFeCAYAAADngTkBAAAAOXRFWHRTb2Z0d2FyZQBNYXRwbG90bGliIHZlcnNpb24zLjkuMiwgaHR0cHM6Ly9tYXRwbG90bGliLm9yZy8hTgPZAAAACXBIWXMAAA9hAAAPYQGoP6dpAABagklEQVR4nO3deXxU5b0/8M+ZmezLhJBMJhuRIAHCEkIakCAVpGAFCmjVllJRKVTKWNDW671YXgq1iv3JVaSkVVGWi4ht3ZCyKFCkiAsxCZsQFtmGAEkIyWRfZub5/TE5Q8ZJmEy2M5n5vF+veRGe85xzvpPDkG+eVRJCCBARERGRV1ApHQARERERdR4md0RERERehMkdERERkRdhckdERETkRZjcEREREXkRJndEREREXoTJHREREZEX0SgdgKeyWq24fPkywsLCIEmS0uEQERGRjxNCoLKyEnFxcVCpWm+fY3LXisuXLyMxMVHpMIiIiIgcGI1GJCQktHqcyV0rwsLCANi+geHh4V1yj4qKCiQmJnbpPQAgMzMTOTk5XXb97rxPV9+Dz8Tz7tFdzwTwju9Xd93Dmz4r3nIPPhPPu09nPxP5enKO0homd62Qu2LDw8O7/AdKV99DrVZ3+Xvorvt013vhM/GsewDd81n0lu9Xdz0TwDs+K95yDxmfiefdp7OfiavhYpxQ4QMMBoPX3Ke73ktX4zPxTN7y/eIz8c17dBdv+n5503NpThJCCKWD8EQVFRXQarUwmUxd2i3b1fcg9/CZeB4+E8/E5+J5+Ew8T2c/k7Zejy13LmRmZiI1NRXZ2dmdfu2AgAA8++yzCAgI6PRrU/vwmXgePhPPxOfiefhMPE9nPZPs7GykpqYiMzOzTfXZctcK/gZEREREnoQtd0REREQ+qEPJ3bFjx5CVlQVJknD+/Pl2XWPjxo3IzMyETqeDXq/H/fffj1OnTrVav6CgAPfddx/0ej10Oh0yMzOxadOmVuvX1dXh2WefRf/+/aHT6ZCUlITHH38cJpOpXfESERERebJ2JXd1dXX4wx/+gDvuuAOnT59u982XLFmChx9+GAaDAUVFRSgoKIDZbEZmZiaOHDniVD8/Px8jR46ExWJBQUEBioqKYDAYMHv2bCxdutSpfmNjIyZPnozXXnsN77zzDoqLi7F7925s374dY8eORUVFRbtjJyIiIvJIoh0effRRMX36dGE0GsUdd9whAIhz5865dY1vvvlGSJIkZs+e7VBeXl4uwsLCREZGhrBarfZyq9Uq0tLSRFhYmCgvL3c458EHHxQqlUrk5+c7lP/v//6vACDWrl3rUL5nzx4BQDzxxBOtxmcymQQAYTKZ3HpfRERERF2hrblJu1ruFi9ejI8++uimW1+4kp2dDSEEZs6c6VCu1Wpx9913Izc3F1988YW9fP/+/Th8+DAmT54MrVbrcM7MmTNhtVqdZrRmZ2dDrVbj/vvvdygfP348YmJi8Oabb6Kurq7d74GIiIjI07QruUtKSurwjffs2QMAyMjIcDoml+3atavd9c+dO4ezZ89iwIABCA0NdagvSRJGjBiByspKfPXVVx18J0RERESeQ5Htx2pqanDx4kX4+/sjOjra6Xh8fDwA2+QJ2YkTJxyONRcdHQ0/Pz9cuHABtbW1CAoKumn9799j3Lhxrcb6/XF5AQEBnbKGUGF5LWZkH+jwdYgAQAIwMDYct9/aG2NujcIgfThUqptvT0NEpLRPv72Ktz4/h7pGC+rNVjSYrbY/LValQ2uXQD8V9j91Z6ddr76+HvX19fa/t3WugCLJXXl5OQAgODi4xeMhISEAgLKyMqdz5GPNSZKE4OBgmEwmlJeXIygo6Kb1W7tHSxITEx3+/uyzz7Y4ecNdVqtASWW964pEbVRcWYL/nCoBAESG+COrX288/qMU3KoLdXEmEVH3q22wYPEHR1Fa3aB0KJ0myE/dqddbvnw5li1b5vZ5iiR3PYnRaHRYKLCzVv6OCQ/EjkVjO+VaRPVmK/IulOHAmWv46mwprlc34F9HruBYoQn//v04tuIRkcf5Z64RpdUNSOgVhGXTBiNAo0aAnwoBGhU0KhWkHvjfVmfHvHjxYvzud7+z/72iosKp0akliiR3ERERAGzdsy2prq4GAPTq1cvpHPlYc0II+7Xkejer39o9WhIeHt4lO1T4a1QYFMudL6jzDE+MwJzb+6LRYkX+xXLMWZ+D86U1+OpsKbJujVI6PCIiu0aLFa/vOwsAePSHyZgwKEbhiDxTe4eCKbJDRXBwMPr06YOGhgaUlJQ4HS8sLAQADBw40F42aNAgh2PNlZSUoLGxEUlJSQgKCnJZv7V7EHkDP7UKI/tGYvrwOADAOwcvKhwREZGjrYcvo7C8FlGh/rj/B65bosg9im0/NmHCBABAbm6u0zG5bOLEie2u37dvXyQnJ+PUqVOoqqpyqC+EQH5+PsLCwnDbbbd18J0QeaZfjOoDAPjk26u4VsXxnUTkGaxWgb999h0A4JExfRHYyePUqBuSOyEEjEajU7nBYIAkSdi8ebNDuclkwo4dOzBixAhkZWXZy8eOHYu0tDRs377daeuwzZs3Q6VSwWAwON3DbDbjn//8p0P53r17cfXqVcydOxeBgYEdfYtEHmlwnBZpCVo0WgTez72kdDhERACA3SeKcLq4CmEBGjw4uuNLq5GzLk/uFi5ciD59+mDRokUO5RkZGXj66afx9ttvY8OGDRBCwGQy4eGHHwYArF27FlKzkYmSJGHdunUQQuCRRx6ByWSCEALr16/Hpk2bsGTJEgwfPtzhHr/97W8xbtw4/M///A9ycnIAAKdPn8ZvfvMbDB06tFNmvRJ5spkjba13mw9ehBBC4WiIyNcJIfDXpla7X45OQnign8IRead2JXcHDx6EXq+HXq+37yKRmZkJvV6P3//+9w51ExMTERwc3OLsjj/96U9Yt24dVq1ahZiYGKSkpECtViMnJwdpaWlO9dPT05GTkwNJkpCSkgKdTofVq1djw4YNLU4V9vPzw44dOzB//nz8/Oc/h06nw4QJE3D33Xdj//79XTJRgsiT/CQtDqEBGpwvrcGXZ0uVDoeIfNxXZ6/jkLEc/hoVHhlzi9LheC1J8Nf5FlVUVECr1cJkMjEJpB7tDx8exaavL2LqsFis/sUIpcMhIh/24FtfY//pa/jlbX3wpxlDlQ6nx2lrbqLYhAoi6h5y1+wn315FKSdWEJFCjl4yYf/pa1CrJDz6w35Kh+PVmNy5kJmZidTUVGRnZysdClG7DIlvNrEijxMriEgZb+y3rWv3k2GxSIxseYcqall2djZSU1ORmZnZpvrslm0Fu2XJm7x78CL+54Oj6BsVgn///g6HyUpERF2t3mxB+h93oabBgi2GMUhLjFA6pB6J3bJEZPeTtDiE+Ktx7lo1J1YQUbf75nwZahosiAoNwNB4rdLheD0md0Q+ICRAg+np8QCAzQed150kIupKn50sBgDckRLNva67AZM7Ih/xQNMWP3sLitFosSocDRH5kn2nbFuNjhsQrXAkvoHJHZGPGBavRWSIP6rqzThkLFc6HCLyEZfLa3GqqAoqCRjbP0rpcHwCkzsiH6FSScjq1xsAsP/0NYWjISJf8dlJW6tdep9eiAj2Vzga38DkjsiHyL817z9donAkROQr5PF241LYJdtdmNwR+ZDb+9v+cz1sLIeptlHhaIjI2zWYrThwxtZTcAfH23UbJncucBFj8ibxEUFIjgqBVQBffsclUYioa31z4TqqGyyICvXHkDgugdJe7i5irOnieHq8nJwcLmJMXmVs/yicvVaNz8+U4MdD9EqHQ0RebF/TeLsf9ucSKB1hMBhgMBjsixi7wpY7Ih8jd81+zkkVRNTF5CVQ2CXbvZjcEfmY25IjoVZJOF9aA+P1GqXDISIvdcVUi4KrlZAkW8sddR8md0Q+JizQD+lN+zpySRQi6ipyl2xaQgR6hXAJlO7E5I7IB93etCTK52e4JAoRdQ15fTvuStH9mNwR+SB5vbsDZ0phsQqFoyEib9NoubEEyrgBOoWj8T1M7oh8UFpCBMICNDDVNuJYoUnpcIjIy+ReKENlvRmRIf4YFs8lULobkzsiH6RRqzC6aSuyz89w3B0RdS55luwP+0dxCRQFMLkj8lHcioyIuso++3g7dskqgcmdC9yhgryVvN5d7oUyVNebFY6GiLxFRV0jTlytAABkNfUQUMdwh4pOxh0qyFvd0jsY8RFBKCyvxcFz1zF+IH/DJqKOy7tQBiGApN7B0IUHKh2OV+AOFUTUJpIkNeua5bg7Iuoc35wvAwBkJPVSOBLfxeSOyIdxvTsi6mzfXLgOAMi8JVLhSHwXkzsiHzY62TYe5lRRFUw1jQpHQ0Q9XYPZikPGcgBA5i1suVMKkzsiH9Y7NAB9o0IAAHnGMoWjIaKe7tvLJtQ1WtEr2A/9okOVDsdnMbkj8nEj+th+u867wOSOiDom98KN8XaSxPXtlMLkjsjHyYOec5ncEVEH5Zy3jbf7AcfbKYrJHZGPk5O7Q8ZymC1WhaMhop5KCGGfKcvxdspickfk4/rrQhEWqEFNgwUFVyuVDoeIeqjzpTUorW6Av0aFIdxPVlFM7lzgDhXk7VQqyT7ujl2zRNRecpdsWoIWARq1wtF4F3d3qGBy50JOTg6OHz8Og8GgdChEXYbj7oioo77heLsuYzAYcPz4ceTk5LSpPpM7ImJyR0Qd9s0FjrfzFO1K7goKCnDfffdBr9dDp9MhMzMTmzZtcusaRUVFWLhwIfr164fIyEhERUVh+vTpyM3NbfWcDz74AHfeeSciIyPRq1cvpKam4oUXXkB9fb1T3fPnz0OtVkOv17f4euedd9x+30TeKi0xAioJKCyvxVVTndLhEFEPU1pVj7Ml1QBuLK9EynE7ucvPz8fIkSNhsVhQUFCAoqIiGAwGzJ49G0uXLm3TNc6dO4f09HRs3boV7777Lq5fv44TJ04AALKysrB7926ncxYvXoyf/vSnyMzMxMWLF3Ht2jW88MILWL58OaZNmwaLxeJ0TmJiIq5evdri6xe/+IW7b53Ia4UGaDBQHw4AyLvI1jsico/capcSE4qIYH+FoyG3kjshBB555BEAwPr16xEREQFJkvDwww9j1qxZeO6553Do0CGX11m4cCGuXLmCV1991T44MDo6Ghs3bkRQUBDmzJnj0BqXm5uLF198Eenp6fjzn/+M0NBQqNVqzJgxA08++SQ+/fRTvP766+68FSL6HnbNElF7yf9vcLydZ3Arudu/fz8OHz6MyZMnQ6t1nOY8c+ZMWK1Wl7NK6+rqsHPnTgDApEmTHI6Fh4dj7NixMBqN2LZtm738ww8/bLE+AEydOhUA8Nprr7nzVojoe5jcEVF7yTNlOd7OM7iV3O3ZswcAkJGR4XRMLtu1a9dNr1FaWgqz2YzQ0FAEBgY6Hdfr9QBsiaSsqKgIgK11r7X6R48ehclkasvbIKIWyMmdbW9I52EOREQtqWu04Fih7efvD5LYcucJ3Eru5HFx8fHxTseio6Ph5+eHCxcuoLa2ttVrREZGQq1Wo6qqCjU1NU7Hi4uLAdjG5cl0Oh2AG0leS/W/fw4A1NTU4He/+x0GDx6MmJgYJCcn4xe/+EWbpxIDQEVFhcOrpckbRN4goVcQdGEBaLQIHLnEX5SIqG0OG8vRaBGICQ9AQq8gpcPxKvX19U55SFu4ldyVl5cDAEJCQpyOSZKE4OBgh3otCQoKwvjx4wHAoesVAKqqqnDgwAH717LJkycDAHbs2AEhhMM5chfv988BgLKyMuj1enz++ee4fPkyPvroIxiNRowePRrr16+/yTu9ITExEVqt1v5avnx5m84j6mkkSWLXLBG57Ztm4+0kSVI4Gu+yfPlyhxwkMTGxTecpss7dypUrodVq8cQTT2Dv3r0wm80wGo2YNWsW1GrbqtbNE8gxY8Zg7ty5OHbsGB577DGUlJSgrq4O7733Hl555RX7+L/m5yQmJuLKlSt46qmn0KtXL6jVagwbNgxbtmxBaGgoFixY0GJL4PcZjUaYTCb7a/HixZ383SDyHEzuiMhd8ni7HyRxvF1nW7x4sUMOYjQa23SeW8ldREQEAKC6utrpmBDC3s0q12vN4MGDkZeXh0mTJmHOnDnQ6/WYMmUKRo0ahRUrVgAAYmNjHc554403sGbNGuTn52PQoEHo378/Nm3ahB07diAuLs7pHLVajaioKKd7R0ZG4s4770RtbS22b9/u8j2Hh4c7vAICAlyeQ9RTjWj6zznvYplTKzkR0fdZrQJ5cssdx9t1uoCAAKc8pC007txk0KBBAIDCwkKnYyUlJWhsbERSUhKCglz3uScnJ2Pt2rVO5a+88goAYMSIEQ7lkiRh7ty5mDt3rtM5hYWFiI2NtU+ucEVOBq9cudKm+kS+YnBcOPw1KlyvbsD50hr0jXIegkFEJDtfWo2KOjMCNCoMjA1TOhxq4lbL3YQJEwCgxV0k5LKJEyd2KKCvv/4aGo0GM2bMaFP9goICVFRU4P7773coX79+fasTJy5fvgzgxkQNIrIJ0KgxLN42zIFds0Tkijz5aki8Fn5q7mjqKdx6EmPHjkVaWhq2b9/utOzI5s2boVKpYDAY7GVCiBb7h7ds2YJp06Y5lRcWFuLjjz/GggULnBKvu+66y2HyhOyvf/0rQkND8eSTTzqUr1+/HuvWrXOqX15ejs8++wz+/v748Y9/fPM3TOSDMm7huDsiaptDxnIAwLAE7c0rUrdyK7mTJAnr1q2z71RhMpkghMD69euxadMmLFmyBMOHD7fXX7hwIfr06YNFixY5XKesrAxbt27FypUr7duG5efnY8qUKRg9enSLM1JPnjyJp556CmfPngVgG/f35z//GWvWrMGmTZtanEGyZs0avPnmm2hoaAAAfPfdd7jvvvtQXl6Ol156CQkJCe68fSKfkNFHTu6uKxwJEXm6w5fKAQDDEyMUjYMcud2Gmp6ejpycHEiShJSUFOh0OqxevRobNmzAsmXLHOomJiYiODjYKfFKT0/HAw88gFWrVqF3795ISEjA/PnzMW/ePHzyySf2JVWa+9WvfoWQkBCMGjUKMTExGDJkCI4fP468vLwWWwFff/11LFmyBG+++Sb69u2LyMhIZGVlITQ0FHv27MHChQvdfetEPkGeVHG6uApV9WaFoyEiT9VoseLby7Z119ISIpQNhhxIglPiWlRRUQGtVguTydTm2SlE3mLMi/9GYXktNs+7DaP79VY6HCLyQMcKTZj6l8+hDfLDoWcmco27btDW3ISjH4nIiTx+5khTlwsR0fc1H2/HxM6zMLlzITMzE6mpqcjOzlY6FKJuM9Se3HEbMiJq2RGOt+s22dnZSE1NRWZmZpvqu7XOnS/Kyclhtyz5HHn8zJHCckXjICLPddho++VvGMfbdTmDwQCDwWDvlnWFLXdE5GRI01p3xuu1uF7doHA0RORpquvNOF1cCQBI4zIoHofJHRE50Qb5IblpdwqOuyOi7ztWaIJVALHaQOjCA5UOh76HyR0RtWgYx90RUSvk9e24BIpnYnJHRC2Sx9Gw5Y6Ivk8eb5fGyRQeickdEbUoLdHWcnf4km0nGiIimbwMCsfbeSYmd0TUotRYLdQqCSWV9bhaUad0OETkIa5V1aOwvBaSBAxhcueRmNwRUYuC/NXorwsFwHF3RHSDPFSjX3QowgP9lA2GWsTkzgUuYky+LI3j7ojoew7Z17djq1134SLGnYyLGJMvG5aoxd+/MbLljojsuDNF9+MixkTUaW603HFSBREBQggctu8pG6FoLNQ6JndE1KoB+jD4a1Qw1TbiQmmN0uEQkcKM12tRVtMIP7WEQbFhSodDrWByR0St8lOrkBprG5ZwmOPuiHye/P9Aamw4AjRqZYOhVjG5I6KbSuNOFUTUhF2yPQOTOyK6Kfk/8aNM7oh8nn3bMU6m8GhM7ojopuTlDo5dNsFi5aQKIl9lsQocK6wAwJ0pPB2TOyK6qeToUIT4q1HTYMGZ4iqlwyEihXxXUoXaRguC/dVIjg5VOhy6CSZ3RHRTapWEIfHyPrPlygZDRIqRh2YMjguHWiUpHA3dDJM7F7hDBdGN8TXcqYLIdx27bEvu5F/2qPtwh4pOxh0qiG6Mu+OMWSLfdaywKbmLY3LX3bhDBRF1OnmnihNXKtBgtiobDBF1O4tV4NvLtskUQzmZwuMxuSMilxJ6BUEb5IdGi8CpokqlwyGibnbuWjVqGiwI9FMhOSpE6XDIBSZ3ROSSJEkY2jTORu6aISLfIX/uU2PDoVEzdfB0fEJE1CaD421jT+VB1UTkO442JXdDOZmiR2ByR0RtIg+ilhcxJSLfIbfcDWZy1yMwuSOiNpGXPzhxpQJmCydVEPkKa/PJFEzuegQmd0TUJkmRwQgL0KDebMWZEu5UQeQrLlyvQVW9GQEaFfrruDNFT8DkjojaRKWSkBrXNO6OXbNEPkMebzeQkyl6DD4lF7hDBdENQzhjlsjnHLNPpuCC/krhDhWdjDtUEN3A5VCIfM8xzpRVHHeoIKIuM6TpN/fjVypgsQqFoyGiriaEuDFTltuO9RjtSu4KCgpw3333Qa/XQ6fTITMzE5s2bXLrGkVFRVi4cCH69euHyMhIREVFYfr06cjNzW31nA8++AB33nknIiMj0atXL6SmpuKFF15AfX19q+ds3LgRmZmZ0Ol00Ov1uP/++3Hq1Cm3YiUim75RoQjyU6OmwYJz16qVDoeIutjF6zWoqDPDX61CSkyY0uFQG7md3OXn52PkyJGwWCwoKChAUVERDAYDZs+ejaVLl7bpGufOnUN6ejq2bt2Kd999F9evX8eJEycAAFlZWdi9e7fTOYsXL8ZPf/pTZGZm4uLFi7h27RpeeOEFLF++HNOmTYPFYnE6Z8mSJXj44YdhMBhQVFSEgoICmM1mZGZm4siRI+6+dSKfp3aYVMGuWSJvJ0+eGhgbBn8NO/t6DOEGq9Uq0tLSRFhYmCgvL3c49uCDDwqVSiXy8/NdXmfq1KkCgNiyZYtDuclkElqtViQmJoq6ujp7+TfffCMAiPT0dKdrLV26VAAQ2dnZDuXffPONkCRJzJ4926G8vLxchIWFiYyMDGG1WluN0WQyCQDCZDK5fD9EvuTZLcdE0n//Szy39VulQyGiLrZ8+wmR9N//Ev/z/hGlQyHR9tzErTR8//79OHz4MCZPnuw0oG/mzJmwWq0uZ5XW1dVh586dAIBJkyY5HAsPD8fYsWNhNBqxbds2e/mHH37YYn0AmDp1KgDgtddecyjPzs6GEAIzZ850KNdqtbj77ruRm5uLL7744qaxEpGzwXHchozIV3AyRc/kVnK3Z88eAEBGRobTMbls165dN71GaWkpzGYzQkNDERgY6HRcr9cDsCWSsqKiIgBAdHR0q/WPHj0Kk+nGD5vOiJWInMnLoXxbWAErJ1UQeS0hhP2XuCFcBqVHcSu5k8fFxcfHOx2Ljo6Gn58fLly4gNra2lavERkZCbVajaqqKtTU1DgdLy4uBmAblyfT6XQAbiR5LdVvfk5NTQ0uXrwIf3//FhNCOf6CgoJW45RVVFQ4vG42eYPIF9yqC4W/RoXKejMuXnf+DBORd7hUVovymkb4qSUM0HMyhRLq6+ud8pC2cCu5Ky8vBwCEhIQ4HZMkCcHBwQ71WhIUFITx48cDgEPXKwBUVVXhwIED9q9lkydPBgDs2LEDQji2FMhdvM3Pke8vx/N9cvxlZWWtxilLTEyEVqu1v5YvX+7yHCJv5qdWYVAsu2aJvJ3cJZsSE4YAjVrhaHzT8uXLHXKQxMTENp2nyNSXlStXQqvV4oknnsDevXthNpthNBoxa9YsqNW2f0DNE8gxY8Zg7ty5OHbsGB577DGUlJSgrq4O7733Hl555RX7+L+Wks6OMhqNMJlM9tfixYs7/R5EPc0QbkNG5PXsXbJc304xixcvdshBjEZjm85zK7mLiIgAAFRXO69vJYSwd7PK9VozePBg5OXlYdKkSZgzZw70ej2mTJmCUaNGYcWKFQCA2NhYh3PeeOMNrFmzBvn5+Rg0aBD69++PTZs2YceOHYiLi3M4R75/S92+zePv1auXy/ccHh7u8AoICHB5DpG3s4+7Y8sdkdc62vTL25AEJndKCQgIcMpD2sKt7ccGDRoEACgsLHQ6VlJSgsbGRiQlJSEoKMjltZKTk7F27Vqn8ldeeQUAMGLECIdySZIwd+5czJ071+mcwsJCxMbG2idXBAcHo0+fPrh48SJKSkqcxt3J8Q8cONBlnETkTP5N/mihCUIISJKkcERE1JlEs50pOFO253Gr5W7ChAkA0OIuEnLZxIkTOxTQ119/DY1GgxkzZrSpfkFBASoqKnD//fd3e6xEvipFHwo/tYTymkYUlrc+gYqIeqYrpjpcr26AWiVhICdT9DhuJXdjx45FWloatm/f7rDsCABs3rwZKpUKBoPBXiaEaLF/eMuWLZg2bZpTeWFhIT7++GMsWLDAPkNWdtdddzlMnpD99a9/RWhoKJ588kmHcoPBAEmSsHnzZodyk8mEHTt2YMSIEcjKynL9ponISYBGbd+KiOPuiLzPt5dtn+v+ulAE+nEyRU/jVnInSRLWrVsHIQQeeeQRmEy2Lpn169dj06ZNWLJkCYYPH26vv3DhQvTp0weLFi1yuE5ZWRm2bt2KlStX2rcNy8/Px5QpUzB69OgWZ6SePHkSTz31FM6ePQvANm7uz3/+M9asWYNNmzY5zSDJyMjA008/jbfffhsbNmyAEAImkwkPP/wwAGDt2rXsSiLqALlrltuQEXkfeTytvN0g9Sxuz5ZNT09HTk4OJElCSkoKdDodVq9ejQ0bNmDZsmUOdRMTExEcHOyUeKWnp+OBBx7AqlWr0Lt3byQkJGD+/PmYN28ePvnkkxaXMPnVr36FkJAQjBo1CjExMRgyZAiOHz+OvLy8FlsBAeBPf/oT1q1bh1WrViEmJgYpKSlQq9XIyclBWlqau2+diJqRB1lzORQi7yO3yHOmbM8kie8vHEcAbIsXa7VamEymNs9OIfIl+RfLcM9fv0BUqD9y/vAjtoQTeZGs5Xtw2VSHv//6NoxK7q10ONSkrbmJIuvcEVHPNyg2HGqVhGtVDSiq4M4tRN7ienUDLpvqALBbtqdicudCZmYmUlNTkZ2drXQoRB4l0E+NftG2hcO53h2R95A/z7f0DkZYoJ/C0RAAZGdnIzU1FZmZmW2q79Y6d74oJyeH3bJErRgSp8Wpoip8e7kCEwbFKB0OEXUCeabsYI638xgGgwEGg8HeLesKW+6IqN3kLhu23BF5D3kG/OB4Nmz0VEzuiKjdBtuXQ+Fad0Te4jhb7no8JndE1G5yy11heS3KaxoUjoaIOqqq3oyz12z7rw/mZIoei8kdEbWbNsgPfSJt61LKv+0TUc914ortc6wPD0RUaIDC0VB7Mbkjog6Rf7vnYsZEPd+3TePthnC8XY/G5I6IOmRIvG1czrdsuSPq8Y41fY5TOd6uR2NyR0QdIo+74x6zRD2f/EvaEI6369GY3LnARYyJbk7ulj17rRo1DWaFoyGi9qo3W3C6qBIAMDieLXeehIsYdzIuYkx0c7qwQOjCAlBcWY8TVyqRkdRL6ZCIqB1OXa2C2SrQK9gPcdpApcOhZriIMRF1u8FczJiox5M/v4PjtJAkSeFoqCOY3BFRh8mLnX7LxYyJeqxj9uSOvVU9HZM7IuowedmEb6+w5Y6op7LvKcvxdj0ekzsi6jC55e7k1Uo0mK0KR0NE7rJYhX0BY7bc9XxM7oiowxJ6BSE8UINGi8Dp4kqlwyEiN50tqUJdoxUh/mr07R2idDjUQUzuiKjDJEm6Me6OixkT9TjyeLtBseFQqTiZoqdjckdEncI+Y5aLGRP1OPJkqCEcb+cVmNwRUacYLE+qYMsdUY/zrX3bMY638wZM7lzgDhVEbTOkqVv2+JUKWK1C4WiIqK2EEPY17oZwT1mPxB0qOhl3qCBqm+ToUAT6qVDTYMG50mr0iw5VOiQiaoNLZbWoqDPDX63CrTp+bj0Rd6ggIkWoVRIG6tk1S9TTHGsaJztAHwZ/DdMCb8CnSESdxr6YMSdVEPUY9sWLOd7OazC5I6JOw+VQiHoe+7ZjnCnrNZjcEVGnsS+HctkEITipgqgnYMud92FyR0SdJiUmDBqVhLKaRlw21SkdDhG5UFxRh5LKeqgkYJCeyZ23YHJHRJ0m0E9tn23HcXdEnk/uku0XHYogf7XC0VBnYXJHRJ1KXuH+GMfdEXk87kzhnZjcucBFjIncM4TbkBH1GPbJFBxv59G4iHEn4yLGRO6RZ9xxxiyR57sxmYItd56MixgTkaIGxYZDkoCrTQO1icgzldc04FJZLQDuKettmNwRUacKDdCgb1QIANj3qyQiz3O8qdWuT2QwtEF+CkdDnaldyV1BQQHuu+8+6PV66HQ6ZGZmYtOmTW5do6ioCAsXLkS/fv0QGRmJqKgoTJ8+Hbm5ua2es2XLFtx5551ISEhATEwMUlNT8eSTT6KkpMSp7meffQZ/f3/o9foWX/v373f7fRNR2wzhYsZEHo/j7byX28ldfn4+Ro4cCYvFgoKCAhQVFcFgMGD27NlYunRpm65x7tw5pKenY+vWrXj33Xdx/fp1nDhxAgCQlZWF3bt3O53z/PPPY8aMGUhJSbHf980338Tbb7+NjIwMlJaWOp2TlZWFq1evtvgaO3asu2+diNqo+WLGROSZjnGmrNdyK7kTQuCRRx4BAKxfvx4RERGQJAkPP/wwZs2aheeeew6HDh1yeZ2FCxfiypUrePXVV+0zP6Kjo7Fx40YEBQVhzpw5qK+/MVanoaEBy5cvR3R0NP7yl78gNNS2jlZWVhYWL14Mo9GINWvWuPNWiKgL2ZdDKWTLHZGnkn/54ng77+NWcrd//34cPnwYkydPdpqtMXPmTFitVpdLhtTV1WHnzp0AgEmTJjkcCw8Px9ixY2E0GrFt2zZ7eVlZGaqrq9G3b1/4+TmOC+jfvz8A4MKFC+68FSLqQnLL3cXrNTDVNiocDRF9X3W9GWevVQO4MYyCvIdbyd2ePXsAABkZGU7H5LJdu3bd9BqlpaUwm80IDQ1FYGCg03G9Xg8ADmPidDodYmJi8N1336GhocGhvtydO3ToUDfeCRF1pYhgf8RHBAG4MWibiDxHwdUKCAHowgIQHRagdDjUydxK7uREKj4+3ulYdHQ0/Pz8cOHCBdTW1rZ6jcjISKjValRVVaGmpsbpeHFxMQDbuDyZJEl46623UF9fj0cffRQlJSUwm83YvXs3XnzxRYwbNw6/+tWvWrzWvHnzMHDgQOh0OgwYMADz5s3DyZMn2/yeKyoqHF7Nu4uJqHVD4jnujshTcbxdz1BfX++Uh7SFW8ldeXk5ACAkJMTpmCRJCA4OdqjXkqCgIIwfPx4AHLpeAaCqqgoHDhywf93clClTsHPnTuTl5UGn0yEkJAQ/+clPMG/ePHz66acICHD+zcNoNGLUqFHIzc1FYWEh1q1bhy+//BLp6ekuWxhliYmJ0Gq19tfy5cvbdB6Rr5O7eo5xpwoij/MtZ8r2CMuXL3fIQRITE9t0niLr3K1cuRJarRZPPPEE9u7dC7PZDKPRiFmzZkGttm1c/P0E8rnnnsMdd9yBCRMmoLi4GNXV1di9ezfef/993H777bh48aJD/dGjR+PixYuYO3cuQkJC4Ofnh6ysLLz//vtoaGjAQw891KZWOKPRCJPJZH8tXry4874RRF5sCHeqIPJYcssdd6bwbIsXL3bIQYxGY5vOcyu5i4iIAABUV1c7HRNC2LtZ5XqtGTx4MPLy8jBp0iTMmTMHer0eU6ZMwahRo7BixQoAQGxsrL3+3r178cwzz2DMmDF4+eWXER0dDY1GgzFjxmDjxo04ePAgZs+e7XCPgIAA9OrVy+neAwYMwLBhw3DlyhV88cUXLt9zeHi4w6ulFkIicia3CHxXUoWaBrPC0RCRrN5swamiSgBsufN0AQEBTnlIW7i1t+ygQYMAAIWFhU7HSkpK0NjYiKSkJAQFBbm8VnJyMtauXetU/sorrwAARowYYS+TZ9dOmDDBqf7IkSMRGhqKffv24fr164iMjHR577i4OOTn5+PKlSsu6xJR++jCAxEdFoCSynqcuFKJjCTnX7aIqPudLqqC2SqgDfJDQi/XP6+p53Gr5U5OrlraRUIumzhxYocC+vrrr6HRaDBjxgx7mTz+TpKkFs9RqWxvw2S6MbZn5cqVOH36dIv1L1++DMA2C5eIus6QplaB45xUQeQx5HGwg+PCW/25Sj2bW8nd2LFjkZaWhu3btzskUgCwefNmqFQqGAwGe5kQosX+4S1btmDatGlO5YWFhfj444+xYMECh8TrtttuAwDs27fP6ZxDhw6hoqICer0eSUlJ9vKVK1fiww8/dKp/5swZHDt2DL1790ZWVlYb3jURtdfgOC5mTORp5HGwnCnrvdxK7iRJwrp16+w7VZhMJgghsH79emzatAlLlizB8OHD7fUXLlyIPn36YNGiRQ7XKSsrw9atW7Fy5UpYLBYAtm3NpkyZgtGjRzvNSJ05cybGjBmDPXv2YOnSpfYxf0ePHsVDDz0ESZLw8ssv21vwZM8//zw++ugjWCwWCCFw6NAh3H///RBC4I033rDP7iWiriEvh3KMLXdEHoN7yno/t2fLpqenIycnB5IkISUlBTqdDqtXr8aGDRuwbNkyh7qJiYkIDg52mrqbnp6OBx54AKtWrULv3r2RkJCA+fPnY968efjkk0+cki6NRmNf027r1q2IjY1Fr169MHHiRCQnJ2Pfvn2YOXOmwzkffPAB5s+fjz/+8Y9ISEhAZGQkpk6dikGDBuHgwYO499573X3rROQmueXuVFElGsxWhaMhIotV4MQVzpT1dpIQQigdhCeqqKiAVquFyWRq8+wUInIkhMDwP+6CqbYR//rt7ewGIlLY6aJKTHzlPwjyU+PYsrugVnHMXU/S1txEkXXuiMg3SJJk7/rhThVEyjvabDIFEzvvxeTOhczMTKSmpiI7O1vpUIh6JC5mTOQ55OSOreg9S3Z2NlJTU5GZmdmm+m6tc+eLcnJy2C1L1AFyyx23ISNSnvw5HMrkrkcxGAwwGAz2bllX2HJHRF1KbiE4fqUCFiuH+BIpxWIV9hb0oQlM7rwZkzsi6lJ9e4cg2F+NukYrzpZUKR0Okc86d60KNQ0WBPqpkBwV4voE6rGY3BFRl1KpbkyqOMquWSLFyJ+/1NhwaNT88e/N+HSJqMvJXbNM7oiUI+8Uw/F23o/JHRF1OfmHydFLTO6IlMKZsr6DyR0RdblhCTeWQ+GkCqLuZ7UKHOdkCp/B5I6IulzfqFAE+6tR22jhpAoiBZwrrUZVvRmBfircGh2qdDjUxZjcucBFjIk6Ts1JFUSKkte3G8TJFD0SFzHuZFzEmKhzDInXIud8GY5cMuHeEQlKh0PkU+TxrpxM0TNxEWMi8kjyuDvuVEHU/TiZwrcwuSOibjE0npMqiJRgbbYzxZA4Jne+gMkdEXWL5pMqvuOkCqJuc+F6DarqzfDXqNA/hpMpfAGTOyLqFmqVZG814Hp3RN3naLPJFH6cTOET+JSJqNtwpwqi7iePcx0az8mBvoLJHRF1m6EJXA6FqLtxpqzvYXJHRN1maHwEAOA4J1UQdQshBI5d5kxZX8Pkjoi6TXJUCEI4qYKo21worUFlnW0yRUpMmNLhUDdhcucCd6gg6jwqlYTBnFRB1G3skyn0YZxM0YNxh4pOxh0qiDrXkHgtDp6/jqOFJvw0gztVEHWlY1y82Ctwhwoi8mjyThWcVEHU9TjezjcxuSOibiX/kDl+uQJmi1XhaIi8lxACxwptO1NwpqxvYXJHRN3KcVJFtdLhEHkt4/VamGob4a/mZApfw+SOiLqVSiVhMBczJupyhy+VAwAGxobBX8Mf976ET5uIup3cRXSMyR1RlznSlNylJUQoGgd1PyZ3RNTt5ORO/uFDRJ3vsNH2y5M8iYl8B5M7Iup2Q5t+2By/wkkVRF3BbLHahz0MT4xQNhjqdkzuXOAixkSdr2/vEIQGaFDXaMUZ7lRB1OnOlFShttGCEH81kqNDlQ6HOoiLGHcyLmJM1PlsO1WE4+tz13HkkgkD9fyMEXWmw8ZyALZWcrVKUjYY6jAuYkxEPYLcVXSo6YcQEXWew03b+3EyhW9ickdEipCTu8NM7og6nfy5SuN4O5/UruSuoKAA9913H/R6PXQ6HTIzM7Fp0ya3rlFUVISFCxeiX79+iIyMRFRUFKZPn47c3NxWz9myZQvuvPNOJCQkICYmBqmpqXjyySdRUlLSYn2r1YpXX30VQ4YMgU6nQ1xcHObMmYMrV664FSsRdT75h07B1UrUNVqUDYbIi9Q1WnDyaiUAJne+yu3kLj8/HyNHjoTFYkFBQQGKiopgMBgwe/ZsLF26tE3XOHfuHNLT07F161a8++67uH79Ok6cOAEAyMrKwu7du53Oef755zFjxgykpKTY7/vmm2/i7bffRkZGBkpLS53Oeeihh/D000/jpZdeQnFxMXJzc1FQUIDMzExcunTJ3bdORJ0oVhuI6LAAWKyC690RdaJvL1fAbBWICvVHnDZQ6XBICcINVqtVpKWlibCwMFFeXu5w7MEHHxQqlUrk5+e7vM7UqVMFALFlyxaHcpPJJLRarUhMTBR1dXX28vr6ehESEiKio6NFQ0ODwzkrV64UAMTy5csdyt9//30BQDzzzDMO5adPnxaSJIl77rnnpjGaTCYBQJhMJpfvh4jaZ+6GHJH03/8Sa/7zndKhEHmNt/afFUn//S8xZ91BpUOhTtbW3MStlrv9+/fj8OHDmDx5stNsjZkzZ8JqtbpcMqSurg47d+4EAEyaNMnhWHh4OMaOHQuj0Yht27bZy8vKylBdXY2+ffvCz8/P4Zz+/fsDAC5cuOBQvnr1antczd16663IzMzERx99xNY7IoXZx91dYssdUWeRFwcfxskUPsut5G7Pnj0AgIyMDKdjctmuXbtueo3S0lKYzWaEhoYiMNC5uViv1wOwJZIynU6HmJgYfPfdd2hoaHCoL3fnDh061F7W0NCAzz//HCEhIRgwYECLsQohWuz+JaLuI8/kO2QsUzYQIi9inymbyJ0pfJVbyZ2cSMXHxzsdi46Ohp+fHy5cuIDa2tpWrxEZGQm1Wo2qqirU1NQ4HS8uLgZgG5cnkyQJb731Furr6/Hoo4+ipKQEZrMZu3fvxosvvohx48bhV7/6lb3+mTNn0NjYiLi4OEiS8/o+cvwFBQUu33NFRYXDq76+3uU5RNQ2w5p++Biv16K0ip8too4y1TTi3LVqAGy58wb19fVOeUhbuJXclZeXAwBCQkKcjkmShODgYId6LQkKCsL48eMBwKHrFQCqqqpw4MAB+9fNTZkyBTt37kReXh50Oh1CQkLwk5/8BPPmzcOnn36KgICANsXZvLyszHVrQWJiIrRarf21fPlyl+cQUduEB/qhX7Tt83iEXbNEHXaksBwA0CcyGJEh/soGQx22fPlyhxwkMTGxTecpss7dypUrodVq8cQTT2Dv3r0wm80wGo2YNWsW1Go1AOfE7LnnnsMdd9yBCRMmoLi4GNXV1di9ezfef/993H777bh48WKXxGo0GmEymeyvxYsXd8l9iHyVvFRDPte7I+owrm/nXRYvXuyQgxiNxjad51ZyFxERAQCorq52OiaEsHezyvVaM3jwYOTl5WHSpEmYM2cO9Ho9pkyZglGjRmHFihUAgNjYWHv9vXv34plnnsGYMWPw8ssvIzo6GhqNBmPGjMHGjRtx8OBBzJ49u01xNi/v1auXy/ccHh7u8GreQkhEHZfOxYyJOs2NnSk43s4bBAQEOOUhbeHW3rKDBg0CABQWFjodKykpQWNjI5KSkhAUFOTyWsnJyVi7dq1T+SuvvAIAGDFihL1Mnl07YcIEp/ojR45EaGgo9u3bh+vXryMyMhK33nor/Pz8cPnyZQghnMbdyfEPHDjQZZxE1LXS7DNmy1v8vBJR27HljgA3W+7k5KqlXSTksokTJ3YooK+//hoajQYzZsywl8nj71r7T1+lsr0Nk8n2G4u/vz9uv/12VFdX4+TJky3GKkkSfvSjH3UoViLquIH6cPirVSivacSFUudJVkTUNldNdSiurIdKAgbHta2Fh7yTW8nd2LFjkZaWhu3bt9sTKdnmzZuhUqlgMBjsZUKIFvuHt2zZgmnTpjmVFxYW4uOPP8aCBQug0+ns5bfddhsAYN++fU7nHDp0CBUVFdDr9UhKSrKXP/bYY/a4mjtz5gxycnIwY8YMJCQktOVtE1EX8teokNr0g+hw0/pcROS+Q02tdikxYQj2d6tjjryMW8mdJElYt24dhBB45JFHYDKZIITA+vXrsWnTJixZsgTDhw+311+4cCH69OmDRYsWOVynrKwMW7duxcqVK2Gx2PaUzM/Px5QpUzB69GinGakzZ87EmDFjsGfPHixdutQ+Zu7o0aN46KGHIEkSXn75ZXsLHgDce++9mDVrFlasWGHv1r169Spmz56NuLg4rFq1yp23TkRdSF7M+BDH3RG1m/zL0XB2yfo8t2fLpqenIycnB5IkISUlBTqdDqtXr8aGDRuwbNkyh7qJiYkIDg52mrqbnp6OBx54AKtWrULv3r2RkJCA+fPnY968efjkk0/sS6rINBqNfU27rVu3IjY2Fr169cLEiRORnJyMffv2Oe1EAQD/93//h+effx6///3vodPpMGLECAwYMAAHDx5kqx2RB2FyR9Rx3JmCZJIQQigdhCeqqKiAVquFyWRq8+wUImqfc9eqMX7FZ/DXqHBs6V3w1yiyShNRj2W1CqQt+xSV9WZsW3g7Bsdxtqw3amtuwv9BiUhxt/QOhjbIDw1mK05erVQ6HKIe51xpNSrrzQjQqJASE6Z0OKQwJncuZGZmIjU1FdnZ2UqHQuS1JEmyL93AfWaJ3Jd/sRwAMCReCz81f7R7m+zsbKSmpiIzM7NN9TmdxoWcnBx2yxJ1g+EJWvznVAkOGU14cLTS0RD1LLkXbL8UZSS5Xpyfeh6DwQCDwWDvlnWF6T0ReYThfSIAcDkUovbIa0ruRvRhckdM7ojIQ8gz/L4rqUJFXaOywRD1IKbaRpwqto1VZcsdAUzuiMhDRIUGIKFXEIQAjhhNrk8gIgC2JYSEAJJ6ByM6jPufE5M7IvIg6U1dSvL4ISJyzT7ejl2y1ITJHRF5jB80dSl9c+G6wpEQ9Ry5TZ+XEeySpSZM7ojIY/zgFtsPp/yL5bBYub46kStmixWHmpZB4Xg7kjG5IyKPMVAfjtAADarqzVzMmKgNThZVorrBgtAADRcvJjsmdy5wEWOi7qNWSUhvWhKFXbNErslLoKT3iYBaJSkcDXUVdxcxZnLnQk5ODo4fPw6DwaB0KEQ+Qe5a+uY8J1UQuZLL9e18gsFgwPHjx5GTk9Om+kzuiMijZN4SCYAzZonaIvcid6YgZ0zuiMijDE+0dS8Vltficnmt0uEQeaziijoYr9dCkm7s8EIEMLkjIg8TEqDBoFjbwPBv2HpH1Kq8pla7ATFhCA/0Uzga8iRM7ojI4/wgqalr9jwnVRC1xj7ejl2y9D1M7ojI48jr3bHljqh1cnL3AyZ39D1M7ojI48gtdyeuVKCq3qxwNESep67RgmOFFQA4mYKcMbkjIo+j1wYiPiIIVgHkX2TrHdH3fXvZhAaLFVGh/ugTGax0OORhmNwRkUeyd81yvTsiJ83Xt5MkLl5MjpjcucAdKoiU8QOud0fUKvlzwS5Z3+DuDhWaLo6nx8vJyUF4eLjSYRD5HHmQeP7FMpgtVmjU/F2UCACEEMi9UA6AyZ2vMBgMMBgMqKiogFardVmf/1sSkUdKiQlDWIAG1Q0WFFytVDocIo9hvF6La1X18FNLGBLv+gc9+R4md0TkkdQqCen2fWa53h2R7GDT52FIvBaBfmqFoyFPxOSOiDxWZhLXuyP6vi+/KwUAjOrbW+FIyFMxuSMij5XRbMasEELhaIiUJ4TAV2dtyd3ofkzuqGVM7ojIYw1PjIBaJeFqRR0Ky2uVDodIccbrtSgsr4VGJSHzFk6moJYxuSMijxXsr8HgONtsda53RwR88d01ALZffIL9ueAFtYzJHRF5tNuSbV1P8g81Il/2JbtkqQ2Y3LnARYyJlJXV9EPswJlSjrsjnyaEsE+mYHLnW7iIcSfjIsZEyhrZNxJ+agmF5bW4UFqDW6JClA6JSBHflVSjuLIe/hoVRvTheDtfwkWMicirBPtrkN70g+wAu2bJh8ldsiP6RHB9O7opJndE5PHG9IsCAHxxplThSIiU81VTl2xW0+eBqDXtSu4KCgpw3333Qa/XQ6fTITMzE5s2bXLrGkVFRVi4cCH69euHyMhIREVFYfr06cjNzXWq+9lnn0GtVkOv17f4CgkJgUqlQnFxscM5/v7+rZ6zf//+9rx1IlLAmFtvTKqwWjnujnyP1cr17ajt3B5zl5+fjzvuuAMTJkxAQUEBtFotNmzYgNmzZ+P06dNYunSpy2ucO3cOY8aMQUBAAP7xj38gMzMTJSUlmDt3LrKysrBt2zb86Ec/cjgnMTER58+fb/F6I0eORHh4OHQ6nUN5VlYWPvvsM3ffIhF5mLTECIT4q1FW04jjVyq4nyb5nFPFlSitbkCQnxppCRFKh0Mezq2WOyEEHnnkEQDA+vXrERERAUmS8PDDD2PWrFl47rnncOjQIZfXWbhwIa5cuYJXX33VPvMjOjoaGzduRFBQEObMmYP6+np7/cjISNxxxx0tXisvLw85OTlYsGCBO2+FiHoQP7UKo7gkCvkweZbsD27pBX8NR1TRzbn1L2T//v04fPgwJk+e7DRbY+bMmbBarS6XDKmrq8POnTsBAJMmTXI4Fh4ejrFjx8JoNGLbtm328mHDhmHDhg0tXu+1115DfHw8pk2b5s5bIaIepvmSKES+hkugkDvcSu727NkDAMjIyHA6Jpft2rXrptcoLS2F2WxGaGgoAgMDnY7r9XoAaNOYuMrKSmzevBm//vWvodFwVRcibzbmVtsg8oPnrqPBbFU4GqLuY2k+3i6ZyR255lZyd+LECQBAfHy807Ho6Gj4+fnhwoULqK1tfQ/IyMhIqNVqVFVVoaamxum4PCni3LlzLuPZuHEj6uvrMW/evBaPFxcXY968eRg4cCB0Oh0GDBiAefPm4eTJky6vLauoqHB4Ne8uJqLuMyAmDL1D/FHbaEH+RW5FRr7jxJUKVNSZERqgwVCON/Up9fX1TnlIW7iV3JWXlwMAQkKcFxGVJAnBwcEO9VoSFBSE8ePHA4BD1ysAVFVV4cCBA/avXXn99dcxY8YMxMbGtnjcaDRi1KhRyM3NRWFhIdatW4cvv/wS6enpLlsYZYmJidBqtfbX8uXL23QeEXUulUpCVlPr3YHv2DVLvkPukh3ZNxIaNcfb+ZLly5c75CCJiYltOk+RfyUrV66EVqvFE088gb1798JsNsNoNGLWrFlQq20LM7aUQDb35Zdf4siRI61OpBg9ejQuXryIuXPnIiQkBH5+fsjKysL777+PhoYGPPTQQ21qhTMajTCZTPbX4sWL3X/DRNQpxtjH3XFSBfkOeRIRu2R9z+LFix1yEKPR2Kbz3EruIiIiAADV1dVOx4QQ9m5WuV5rBg8ejLy8PEyaNAlz5syBXq/HlClTMGrUKKxYsQIAWm2Nk7322mtITU3FuHHjWjweEBCAXr2ct2cZMGAAhg0bhitXruCLL7646T0A2ySP5q+AgACX5xBR15DH3R02lqOq3qxwNERdz2yxIue8bRgCJ1P4noCAAKc8pC3cmoUwaNAgAEBhYaHTsZKSEjQ2NiIpKQlBQUEur5WcnIy1a9c6lb/yyisAgBEjRrR6bllZGf7xj3/gpZdeamvoDuLi4pCfn48rV66063wiUkZiZDASI4NgvF6Lg+dKcefAGKVDIupSRwtNqKo3Qxvkh9RY7nNObeNWy92ECRMAoMVdJOSyiRMndiigr7/+GhqNBjNmzGi1zvr166HRaDB79uxW66xcuRKnT59u8djly5cBwGnRYyLyfLfL4+64JAr5gP+csnXJ3pYcCZVKUjga6incSu7Gjh2LtLQ0bN++HSaTyeHY5s2boVKpYDAY7GVCiBb7h7ds2dLiunSFhYX4+OOPsWDBgpsmXq+//jpmzZp10+bJlStX4sMPP3QqP3PmDI4dO4bevXsjKyur1fOJyDPJ+2py3B35gj0FRQCACWylJje4ldxJkoR169bZd6owmUwQQmD9+vXYtGkTlixZguHDh9vrL1y4EH369MGiRYscrlNWVoatW7di5cqVsFgsAGzbmk2ZMgWjR4++6YzUvXv34uTJk23akeL555/HRx99BIvFAiEEDh06hPvvvx9CCLzxxhv22b1E1HPIixkXXK3EtSouTUTe66qpDkcumSBJwPiB7GmitnN7tmx6ejpycnIgSRJSUlKg0+mwevVqbNiwAcuWLXOom5iYiODgYKepu+np6XjggQewatUq9O7dGwkJCZg/fz7mzZuHTz755KZJ1+uvv44xY8Zg2LBhN43zgw8+wPz58/HHP/4RCQkJiIyMxNSpUzFo0CAcPHgQ9957r7tvnYg8QO/QAAzUhwFg6x15N7nVbnhiBKLDOJmP2k4SQgilg/BEFRUV0Gq1MJlMbZ6dQkTdY/n2E3j9P2fxk7Q4/GVmutLhEHWJR9YdxN6TJfivuwbAMP5WpcMhD9DW3ISrIRJRjzNpsG2bwr0Fxag3WxSOhqjz1TSY7Yt1T0zleDtyD5M7FzIzM5Gamors7GylQyGiJumJEdCFBaCq3owvuFsFeaH9p6+hwWxFYmQQ+utClQ6HFJadnY3U1FRkZma2qT6TOxdycnJw/Phxh1nARKQslUrCpMG21oxPjl1VOBqizrf7uG283Y8GxUCSuASKrzMYDDh+/DhycnLaVJ/JHRH1SHc1dc3uOl4Ei5VDh8l7WKwC/y4oBgBMHMQuWXIfkzsi6pFuS+6N8EANSqsb8M3560qHQ9RpDhnLUVrdgLBADTL7RiodDvVATO6IqEfyU6vwo6ZWjU++LVI4GqLOs/uE7d/zuAE6+Kn5Y5rcx381RNRj3TXE1jX7ybdXwVWdyFvcGG/HhYupfZjcEVGP9cP+0Qj0U6GwvBbfXq5QOhyiDrtQWo3TxVXQqCSMS2FyR+3D5I6IeqwgfzXuSIkGYGu9I+rpdp+wTaQY2TcS2mA/haOhnorJHRH1aD9u1jVL1NPJXbITOEuWOoDJnQtcxJjIs905IAYalYRTRVU4W1KldDhE7WaqacTBppnfHG9HzXER407GRYyJPJs22A+j+/UGwFmz1LPtPVkMi1UgJSYUSb1DlA6HPAgXMSYinyMvaLyTXbPUg/3jGyMA4MdN/56J2ovJHRH1eJNSYyBJwGFjOa6a6pQOh8htZ0uq8MV3pVBJwM9G9lE6HOrhmNwRUY+nCw/EiD69AADbj15ROBoi920+eBGAbeHi+IgghaOhno7JHRF5hWlpcQCAjV9dgJV7zVIPUtdowT9zLwEAZo1iqx11HJM7IvIK92UkICxQg3PXqrH3ZLHS4RC12Y5jV1Be04g4bSDGDeAsWeo4JndE5BVCAjSY2TRW6a3PzykcDVHbvfO1rUt25sg+UKskhaMhb8Dkjoi8xkNZt0CtkvDFd6U4zu3IqAc4ebUSOefLoFZJeCAzUelwyEswuSMirxEfEWTfsWLtAbbeked75+sLAICJg2IQEx6ocDTkLZjcucAdKoh6ll/d3hcA8PGhyyiu5LIo5LlqGsz4IK8QADDrNk6koNa5u0OFJITgtLIWVFRUQKvVwmQyITw8XOlwiMgN9/z1APIvlmPhhP743cQUpcMhatHfcy7iv98/iqTewdj7+3FQcbwdudDW3IQtd0TkdeTWu01fXUBdo0XhaIha1nwiBRM76kxM7ojI6/x4sB7xEUEorW7AlkOFSodD5OToJRMOXzLBTy3h/owEpcMhL8Pkjoi8jkatwkNZSQBsy6Jw9Al5kvKaBjz5z8MAgB8PiUXv0ACFIyJvw+SOiLzSzzL7INhfjVNFVfj0eJHS4RABAKrrzXhkfQ5OFlVCFxaAp+4aoHRI5IWY3BGRV9IG+eFnTeuGLdiUh9X/Pg0LtyUjBdWbLZj/di7yL5YjItgPb88dhcTIYKXDIi/E5I6IvNaTkwZgWlocLFaBFZ+ewsw1X+Fyea3SYZEPMlusWLT5EPafvoZgfzXWPZyJlJgwpcMiL8Xkjoi8VkiABq/+fDhefiANIf5qHDx3HT9e+R9sO3KF4/CoWwghUF1vxtMfHsXOb6/CX63CGw/+AOl9eikdGnkxrnPXCnktmZSUFKjVahgMBhgMBqXDIqJ2ulBajYXvHsJhYzkAQCUBIf4aBAeoEeyvQbC/GoF+agT6qRCosX0d4KdCgEaNAI0K/hoV/NW2P/3UKvipJfvXGpVk+1MtQaOy/V2jtpWpVRI0KqnpTxVUKtjLVJKtXP5T7VAGqJr+rpIAlSRBavpTLpMk718+QwgBqwCsQsAqBIT9a8BiFRBCwGIVsAgBqxVNf9rqWqw3jpktjmWNFtufZqsVZovtz8bmfzZ93WC2/b3RYvu6oenPerMF9War7dVoQW2jBXWNVtQ2WFDXaEF1gxnV9bY/5Z+yKgn466wR+PGQWGW/qdTjZGdnIzs7GxaLBadOnXK5zh2Tu1ZwEWMi79NosWLl7lN44z9n0Wjxjv/65CRP/lMCIEmABKnpzxvlaP73Zl83HcKNXNE5afx+Hun4k0M4lAnA3jIqmsqFELZa4sZx+zHYkjU0+1pO5LxFaIAGy6YNxk+57Al1QFtzEyZ3rWByR+S96hotqKhtRHWDBdX1ZtQ02FpY6ptaX+oaba0vdeam1hqHFhsrGi22l9ki0NDs60aLFWarsL0s1qaWIccWIkuzViX5mLVZqxMnfbSP3KqpliRb62hTC6dafaPl1HaspRZVCRr1jRZXjcqxZdZPbrFVSQjwU9tbcOUW3SA/udXX1vIb5KdGSICm6aVGiL8GQX5qLlRMHdbW3ETTjTEREXkE+Qexp5K7Gpt3R8rdkGjeRQnAar3RAta86xK40fr1/Zayprt8r6XNXtpCPC3H2bw1r6lt0F72/ZZAx3JbbbmrWT6veZczmlof5S7q5q2T6mZd1M2PE5FNu5K7goICLFmyBJ9//jmsViuSkpLw+OOPY9asWW2+RlFREZ5//nls27YNZWVlUKlUGDNmDJ555hlkZGQ41P3ss88wYcIEREdHt3ityspK1NbW4urVq9DpdPZyq9WKv/zlL1izZg2Ki4uh0Wjw4x//GM8//zxiYznmgYg8kyTZWpCIiNrD7dmy+fn5GDlyJCwWCwoKClBUVASDwYDZs2dj6dKlbbrGuXPnkJ6ejq1bt+Ldd9/F9evXceLECQBAVlYWdu/e7XROYmIirl692uJr8ODBuPPOOx0SOwB46KGH8PTTT+Oll15CcXExcnNzUVBQgMzMTFy6dMndt05ERETk+YQbrFarSEtLE2FhYaK8vNzh2IMPPihUKpXIz893eZ2pU6cKAGLLli0O5SaTSWi1WpGYmCjq6urs5YcPHxazZ89u8Vq5ubkCgHj//fcdyt9//30BQDzzzDMO5adPnxaSJIl77rnnpjGaTCYBQJhMJpfvh4iIiKirtTU3cavlbv/+/Th8+DAmT54MrVbrcGzmzJmwWq3Izs6+6TXq6uqwc+dOAMCkSZMcjoWHh2Ps2LEwGo3Ytm2bvXzYsGHYsGFDi9d77bXXEB8fj2nTpjmUr1692h5Xc7feeisyMzPx0UcfsfWOiIiIvI5byd2ePXsAwGlMXPOyXbt23fQapaWlMJvNCA0NRWBgoNNxvV4PwJZIulJZWYnNmzfj17/+NTSaG8MHGxoa8PnnnyMkJAQDBjjv25eRkQEhRIvdv0REREQ9mVsTKuRxcfHx8U7HoqOj4efnhwsXLqC2thZBQUEtXiMyMhJqtRpVVVWoqalBcLDjvnrFxcUAbOPyXNm4cSPq6+sxb948h/IzZ86gsbERt9xyS4szqOT4CwoKXN6joqLC4e8BAQEICAhweR4RERFRR9TX16O+vt7+9+/nJK1xq+WuvLwcABASEuJ0TJIke6Im12tJUFAQxo8fDwAOXa8AUFVVhQMHDti/duX111/HjBkznGa+3izO5uVlZWUu75GYmAitVmt/LV++3OU5RERERB21fPlyhxwkMTGxTecpsrfsypUrodVq8cQTT2Dv3r0wm80wGo2YNWsW1Grb2lOtJWayL7/8EkeOHMGCBQu6NFaj0QiTyWR/LV68uNOuXV9fj6VLlzpk5aQsPhPPw2fimfhcPA+fiefp6DNZvHixQw5iNBrbdJ5byV1ERAQAoLq62umYEAI1NTUO9VozePBg5OXlYdKkSZgzZw70ej2mTJmCUaNGYcWKFQDgch261157DampqRg3bpxbcTYv79XL9cbN4eHhDq/O7JKtr6/HsmXL+EH0IHwmnofPxDPxuXgePhPP09FnEhAQ4JSHtIVbyd2gQYMAAIWFhU7HSkpK0NjYiKSkpFbH2zWXnJyMtWvX4ty5c7h27RqOHDmCp59+GteuXQMAjBgxotVzy8rK8I9//AO/+c1vWjx+6623ws/PD5cvX7bvb9icHP/AgQNdxukNXM1g7kn36a730tX4TDyTt3y/+Ex88x7dxZu+X970XBy4s77Kvn37BADxs5/9zOnY9u3bBQAxd+5cdy7p5Gc/+5nQaDSiqKio1Tovv/yyCA0Nvek6L+PHjxcAxIkTJ5yOjRw5UkiSJIxGY6vnd8c6d921lt6gQYO69PrdeZ+uvgefiefdozvXnPSG71d33cObPivecg8+E8+7T2c/k7Zez63ZsmPHjkVaWhq2b98Ok8nksNbd5s2boVKpYDAYmieOuHTpktMAwC1btuCtt97Cxx9/7FBeWFiIjz/+GAsWLHDabaK5119/HbNmzbpp8+Rjjz2GvXv3YvPmzVi2bJm9/MyZM8jJycGMGTOQkJDQ6vmiqcWvrTNT2kO+dlfeAwAsFkuX36O77tPV9+Az8bx7dNczAbzj+9Vd9/Cmz4q33IPPxPPu09nPRL6OaG3DZ5m7WWNeXp4IDQ0V99xzjygvLxdWq1WsW7dOqFQqp90gHnvsMQFALFy40KF83bp1AoB45ZVXhNlstl83LS1N3HnnnaK6urrV+//73/8WAMThw4ddxjpr1iwRHBwsduzYIYQQ4sqVK2L06NEiPj7+pq12QghhNBoFmvbT5osvvvjiiy+++PKUl6scxq2WOwBIT09HTk4O/vCHPyAlJQVWqxVJSUnYsGEDfvnLXzrUTUxMRHBwsFPLXXp6Oh544AGsWrUKS5cuRWhoKOLj4zFv3jw8+uijDgsSf9/rr7+OMWPGYNiwYS5j/b//+z+sWrUKv//97zF79mxoNBrcddddeO+99xAXF3fTc+Pi4mA0GhEWFtbiWnlERERE3UkIgcrKSpc5jCSEq7Y9IiIiIuopFFnnjoiIiIi6BpM7IiIiIi/C5I6IiIjIizC5U0BBQQHuu+8+6PV66HQ6ZGZmYtOmTUqH5dXq6+vx97//HVOnToVer0fv3r0RHR2NKVOmYPfu3S2eU1dXh2effRb9+/eHTqdDUlISHn/8cZhMpm6O3rc89thjkCQJDz/8cIvH+Vy6nsViwV//+leMHj0affr0QUREBPr164ef//znOHz4sENdPo/uYbFYsGHDBowePRpxcXGIiYnBsGHD8Pzzz7e4FzufS+c7duwYsrKyIEkSzp8/32q99nzvt2/fjh/+8IfQ6XSIiYnB3XffjYMHD7Y/WJfriVCnysvLE2FhYWLGjBmirKzMYSmZZ599VunwvNZvf/tbAUAsXrxYVFRUCCGEuHDhgvjRj34kAIi//OUvDvUbGhrE+PHjhU6nEwcPHhRCCHHq1CnRv39/MXTo0G5ZUNcX7dq1S0iSJACIhx56yOk4n0vXq62tFRMnThSjR48Wx44dE0II0djYKFasWCEAiHXr1tnr8nl0n7lz5woA4o9//KOor68XVqtV/Otf/xJBQUEiPT1d1NfX2+vyuXSu2tpa8fTTT4vIyEgRFRUlAIhz5861WLc93/s1a9YIAOJPf/qTaGxsFDU1NeI3v/mN8PPzE59++mm7YmZy142sVqtIS0sTYWFhory83OHYgw8+KFQqlcjPz1cmOC9nMBjE2LFjncpLSkpEUFCQCAgIEGVlZfby//3f/xUAxNq1ax3q79mzRwAQTzzxRFeH7HPKyspEQkKCePDBB1tN7vhcut6iRYtE7969HT4PsnvvvVds3brV/nc+j+5x6dIlAUAMHz7c6djjjz8uAIjNmzfby/hcOtejjz4qpk+fLoxGo7jjjjtumty5+72/dOmSCAoKEj/84Q8dyhsbG0VycrKIj48XNTU1bsfM5K4bdcf2bdSyrVu3ip07d7Z4LD09XQAQe/bssZclJycLtVotKisrHeparVYRExMjwsLCRG1tbZfG7GtmzZolpk6dKvbu3dtqcsfn0rWKioqERqMRixYtalN9Po/u8dVXXwkA4oEHHnA6lp2dLQCIF1980V7G59K5zp8/b//aVXLn7vd+2bJlAoD429/+5nStp556SgAQb7/9ttsxc8xdN9qzZw8AICMjw+mYXLZr165ujclXTJ06FXfddVeLxxoaGgAAvXv3BgCcO3cOZ8+exYABAxAaGupQV5IkjBgxApWVlfjqq6+6Nmgf8v777+OTTz7BmjVrWq3D59L1PvroI5jNZtx2220u6/J5dJ+UlBQEBgbixIkTTsfksqFDhwLgc+kKSUlJbarXnu99V+UFTO66kfwhjI+PdzoWHR0NPz8/XLhwAbW1td0dms+6du0aTp8+jdTUVPuuJzd7Ts3LCwoKuidIL1dUVIT58+fjb3/7G/R6fav1+Fy6Xm5uLgBAq9XimWeeweDBgxEdHY3+/ftj/vz5uHjxor0un0f36dWrF/7yl7+goKAATz/9NCoqKtDQ0IB//vOfWLNmDWbOnInJkycD4HNRUnu+9zc7pyPPisldNyovLwcAhISEOB2TJAnBwcEO9ajrrVq1CmazGatWrbJvM3ez59S8vKysrFti9HZz587FpEmTcN999920Hp9L17t8+TIA4KGHHsLFixexe/duXL58GdnZ2fjoo48wYsQInDx5EgCfR3ebO3cu3nvvPbz77rvQarUIDQ3FvHnz8MILL+Cdd96x1+NzUU57vvc3O6cjz4rJHfmsr776Ci+++CL++Mc/YsKECUqH45Peeust5OXlYfXq1UqHQoC91yA0NBRvvvkmYmNj4efnh0mTJuHll19GaWkpHn/8cWWD9EFCCDz66KO45557MH/+fJSVlaGyshLvvPMOXnrpJUyePJmNAuSAyV03ioiIAABUV1c7HRNCoKamxqEedZ3jx49j6tSpWLhwIf7whz84HLvZc2pe3qtXry6N0dudP38ev/vd7/DWW2+16XvJ59L15JaCCRMmQKPROBybNm0aAGD37t2oq6vj8+hG69evxxtvvIFf/vKXeOqppxAREYGAgABMnjwZr776Knbs2GFPuvlclNOe7/3NzunIs2Jy140GDRoEACgsLHQ6VlJSgsbGRiQlJSEoKKi7Q/Mpx44dw5133ok5c+ZgxYoVTsdv9pyalw8cOLDrgvQB27dvh9VqxcMPPwy9Xm9/3XvvvQCAv//97/ayLVu28Ll0g1tuuQUAEBUV5XQsNDQUISEhMJvNuH79Op9HN9q5cycAtNjDIJd9+OGHAPj/l5La872/2TkdeVZM7rqR/CGUBy03J5dNnDixW2PyNfn5+Rg/fjzmz5+P//f//p+9/Pz58/bxRn379kVycjJOnTrltPK7EAL5+fkICwtr04xCat2CBQtQWVmJq1evOrw++OADAMDPfvYze9n06dP5XLrBD3/4QwDA1atXnY7V1NSguroaGo0GkZGRfB7dSP7+yuOCm5PLqqqqYLFY+FwU1J7vfVflBUzuutHYsWORlpaG7du3O21DsnnzZqhUKhgMBoWi8345OTmYMGEC/uu//gtLly51OLZ06VK88cYb9r8bDAaYzWb885//dKi3d+9eXL16FXPnzkVgYGB3hE3N8Ll0rSlTpiAhIQG7du2yLxEk27FjBwDg7rvvtn+P+Ty6h5wM7Nu3z+nYf/7zHwDAD37wA6jVagB8Lkpy93s/Z84cBAUFYfPmzQ71zWYz3nvvPcTHx+Oee+5xPxC3V8ajDsnLyxOhoaHinnvuEeXl5Q7bjz3zzDNKh+e1Dhw4IMLDw8XAgQPFs88+6/RKS0tz2P6toaFBjBs3zmkLmZSUFG7f08Vutogxn0vX+/TTT4W/v7/45S9/KUpLS4XVahVffPGFSEhIELGxseLs2bP2unwe3aOsrEwMGDBAqNVq8dprr4m6ujphtVrF/v37RZ8+fURAQIDYt2+fvT6fS9dxtYhxe773b7zxhgAgnn/+eWE2m0Vtba34zW9+IzQajfjkk0/aFSeTOwWcOHFC3HvvvUKn04moqCiRkZEhNm7cqHRYXm369OkCwE1f39/bt7a2VjzzzDMiOTlZREdHi8TERLFo0SKnreOoc/zpT38SMTExolevXgKACAwMFDExMWLo0KEO9fhcut4333wjpk2bJiIjI0VERITo27ev+O1vfyuuXr3qVJfPo3uUl5eLp59+WgwePFiEhYUJrVYrEhISxKxZs8Thw4ed6vO5dJ6vv/5axMTEiJiYGOHn5ycAiKioKBETEyN+97vfOdVvz/d+27Zt4vbbbxdRUVEiOjpa3HXXXeKrr75qd8ySEEK4395HRERERJ6IY+6IiIiIvAiTOyIiIiIvwuSOiIiIyIswuSMiIiLyIkzuiIiIiLwIkzsiIiIiL8LkjoiIiMiLMLkjIiIi8iJM7oiIiIi8CJM7IiIiIi/C5I6IiIjIizC5IyIiIvIi/x+TxiXFR496+AAAAABJRU5ErkJggg==", + "text/plain": [ + "
" + ] + }, + "metadata": {}, + "output_type": "display_data" + } + ], + "source": [ + "from squishyplanet import OblateSystem\n", + "\n", + "state = {\n", + " \"times\" : jnp.linspace(-1,1,100),\n", + " \"a\" : 200.0,\n", + " \"e\" : 0.3,\n", + " \"i\" : 89.75 * jnp.pi / 180,\n", + " \"Omega\" : 95 * jnp.pi / 180,\n", + " \"omega\" : jnp.pi / 3.5,\n", + " \"period\" : 1001.0,\n", + " \"t0\" : 0.2,\n", + " \"parameterize_with_projected_ellipse\" : False,\n", + " \"r\" : 0.2,\n", + " \"f1\" : 0.1,\n", + " \"f2\" : 0.2,\n", + " \"obliq\" : 0.3,\n", + " \"prec\" : 0.4,\n", + " \"tidally_locked\" : True,\n", + " \"ld_u_coeffs\" : jnp.array([0.008, 0.007, 0.006, 0.005, 0.004, 0.003, 0.002, 0.001])\n", + "}\n", + "\n", + "p = OblateSystem(**state)\n", + "\n", + "g = p.lightcurve()\n", + "\n", + "plt.plot(g)" + ] + }, + { + "cell_type": "code", + "execution_count": 13, + "metadata": {}, + "outputs": [ + { + "name": "stdout", + "output_type": "stream", + "text": [ + "(100,)\n" + ] + }, + { + "data": { + "text/plain": [ + "[]" + ] + }, + "execution_count": 13, + "metadata": {}, + "output_type": "execute_result" + }, + { + "data": { + "image/png": "iVBORw0KGgoAAAANSUhEUgAAAncAAAFeCAYAAADngTkBAAAAOXRFWHRTb2Z0d2FyZQBNYXRwbG90bGliIHZlcnNpb24zLjkuMiwgaHR0cHM6Ly9tYXRwbG90bGliLm9yZy8hTgPZAAAACXBIWXMAAA9hAAAPYQGoP6dpAABagklEQVR4nO3deXxU5b0/8M+ZmezLhJBMJhuRIAHCEkIakCAVpGAFCmjVllJRKVTKWNDW671YXgq1iv3JVaSkVVGWi4ht3ZCyKFCkiAsxCZsQFtmGAEkIyWRfZub5/TE5Q8ZJmEy2M5n5vF+veRGe85xzvpPDkG+eVRJCCBARERGRV1ApHQARERERdR4md0RERERehMkdERERkRdhckdERETkRZjcEREREXkRJndEREREXoTJHREREZEX0SgdgKeyWq24fPkywsLCIEmS0uEQERGRjxNCoLKyEnFxcVCpWm+fY3LXisuXLyMxMVHpMIiIiIgcGI1GJCQktHqcyV0rwsLCANi+geHh4V1yj4qKCiQmJnbpPQAgMzMTOTk5XXb97rxPV9+Dz8Tz7tFdzwTwju9Xd93Dmz4r3nIPPhPPu09nPxP5enKO0homd62Qu2LDw8O7/AdKV99DrVZ3+Xvorvt013vhM/GsewDd81n0lu9Xdz0TwDs+K95yDxmfiefdp7OfiavhYpxQ4QMMBoPX3Ke73ktX4zPxTN7y/eIz8c17dBdv+n5503NpThJCCKWD8EQVFRXQarUwmUxd2i3b1fcg9/CZeB4+E8/E5+J5+Ew8T2c/k7Zejy13LmRmZiI1NRXZ2dmdfu2AgAA8++yzCAgI6PRrU/vwmXgePhPPxOfiefhMPE9nPZPs7GykpqYiMzOzTfXZctcK/gZEREREnoQtd0REREQ+qEPJ3bFjx5CVlQVJknD+/Pl2XWPjxo3IzMyETqeDXq/H/fffj1OnTrVav6CgAPfddx/0ej10Oh0yMzOxadOmVuvX1dXh2WefRf/+/aHT6ZCUlITHH38cJpOpXfESERERebJ2JXd1dXX4wx/+gDvuuAOnT59u982XLFmChx9+GAaDAUVFRSgoKIDZbEZmZiaOHDniVD8/Px8jR46ExWJBQUEBioqKYDAYMHv2bCxdutSpfmNjIyZPnozXXnsN77zzDoqLi7F7925s374dY8eORUVFRbtjJyIiIvJIoh0effRRMX36dGE0GsUdd9whAIhz5865dY1vvvlGSJIkZs+e7VBeXl4uwsLCREZGhrBarfZyq9Uq0tLSRFhYmCgvL3c458EHHxQqlUrk5+c7lP/v//6vACDWrl3rUL5nzx4BQDzxxBOtxmcymQQAYTKZ3HpfRERERF2hrblJu1ruFi9ejI8++uimW1+4kp2dDSEEZs6c6VCu1Wpx9913Izc3F1988YW9fP/+/Th8+DAmT54MrVbrcM7MmTNhtVqdZrRmZ2dDrVbj/vvvdygfP348YmJi8Oabb6Kurq7d74GIiIjI07QruUtKSurwjffs2QMAyMjIcDoml+3atavd9c+dO4ezZ89iwIABCA0NdagvSRJGjBiByspKfPXVVx18J0RERESeQ5Htx2pqanDx4kX4+/sjOjra6Xh8fDwA2+QJ2YkTJxyONRcdHQ0/Pz9cuHABtbW1CAoKumn9799j3Lhxrcb6/XF5AQEBnbKGUGF5LWZkH+jwdYgAQAIwMDYct9/aG2NujcIgfThUqptvT0NEpLRPv72Ktz4/h7pGC+rNVjSYrbY/LValQ2uXQD8V9j91Z6ddr76+HvX19fa/t3WugCLJXXl5OQAgODi4xeMhISEAgLKyMqdz5GPNSZKE4OBgmEwmlJeXIygo6Kb1W7tHSxITEx3+/uyzz7Y4ecNdVqtASWW964pEbVRcWYL/nCoBAESG+COrX288/qMU3KoLdXEmEVH3q22wYPEHR1Fa3aB0KJ0myE/dqddbvnw5li1b5vZ5iiR3PYnRaHRYKLCzVv6OCQ/EjkVjO+VaRPVmK/IulOHAmWv46mwprlc34F9HruBYoQn//v04tuIRkcf5Z64RpdUNSOgVhGXTBiNAo0aAnwoBGhU0KhWkHvjfVmfHvHjxYvzud7+z/72iosKp0akliiR3ERERAGzdsy2prq4GAPTq1cvpHPlYc0II+7Xkejer39o9WhIeHt4lO1T4a1QYFMudL6jzDE+MwJzb+6LRYkX+xXLMWZ+D86U1+OpsKbJujVI6PCIiu0aLFa/vOwsAePSHyZgwKEbhiDxTe4eCKbJDRXBwMPr06YOGhgaUlJQ4HS8sLAQADBw40F42aNAgh2PNlZSUoLGxEUlJSQgKCnJZv7V7EHkDP7UKI/tGYvrwOADAOwcvKhwREZGjrYcvo7C8FlGh/rj/B65bosg9im0/NmHCBABAbm6u0zG5bOLEie2u37dvXyQnJ+PUqVOoqqpyqC+EQH5+PsLCwnDbbbd18J0QeaZfjOoDAPjk26u4VsXxnUTkGaxWgb999h0A4JExfRHYyePUqBuSOyEEjEajU7nBYIAkSdi8ebNDuclkwo4dOzBixAhkZWXZy8eOHYu0tDRs377daeuwzZs3Q6VSwWAwON3DbDbjn//8p0P53r17cfXqVcydOxeBgYEdfYtEHmlwnBZpCVo0WgTez72kdDhERACA3SeKcLq4CmEBGjw4uuNLq5GzLk/uFi5ciD59+mDRokUO5RkZGXj66afx9ttvY8OGDRBCwGQy4eGHHwYArF27FlKzkYmSJGHdunUQQuCRRx6ByWSCEALr16/Hpk2bsGTJEgwfPtzhHr/97W8xbtw4/M///A9ycnIAAKdPn8ZvfvMbDB06tFNmvRJ5spkjba13mw9ehBBC4WiIyNcJIfDXpla7X45OQnign8IRead2JXcHDx6EXq+HXq+37yKRmZkJvV6P3//+9w51ExMTERwc3OLsjj/96U9Yt24dVq1ahZiYGKSkpECtViMnJwdpaWlO9dPT05GTkwNJkpCSkgKdTofVq1djw4YNLU4V9vPzw44dOzB//nz8/Oc/h06nw4QJE3D33Xdj//79XTJRgsiT/CQtDqEBGpwvrcGXZ0uVDoeIfNxXZ6/jkLEc/hoVHhlzi9LheC1J8Nf5FlVUVECr1cJkMjEJpB7tDx8exaavL2LqsFis/sUIpcMhIh/24FtfY//pa/jlbX3wpxlDlQ6nx2lrbqLYhAoi6h5y1+wn315FKSdWEJFCjl4yYf/pa1CrJDz6w35Kh+PVmNy5kJmZidTUVGRnZysdClG7DIlvNrEijxMriEgZb+y3rWv3k2GxSIxseYcqall2djZSU1ORmZnZpvrslm0Fu2XJm7x78CL+54Oj6BsVgn///g6HyUpERF2t3mxB+h93oabBgi2GMUhLjFA6pB6J3bJEZPeTtDiE+Ktx7lo1J1YQUbf75nwZahosiAoNwNB4rdLheD0md0Q+ICRAg+np8QCAzQed150kIupKn50sBgDckRLNva67AZM7Ih/xQNMWP3sLitFosSocDRH5kn2nbFuNjhsQrXAkvoHJHZGPGBavRWSIP6rqzThkLFc6HCLyEZfLa3GqqAoqCRjbP0rpcHwCkzsiH6FSScjq1xsAsP/0NYWjISJf8dlJW6tdep9eiAj2Vzga38DkjsiHyL817z9donAkROQr5PF241LYJdtdmNwR+ZDb+9v+cz1sLIeptlHhaIjI2zWYrThwxtZTcAfH23UbJncucBFj8ibxEUFIjgqBVQBffsclUYioa31z4TqqGyyICvXHkDgugdJe7i5irOnieHq8nJwcLmJMXmVs/yicvVaNz8+U4MdD9EqHQ0RebF/TeLsf9ucSKB1hMBhgMBjsixi7wpY7Ih8jd81+zkkVRNTF5CVQ2CXbvZjcEfmY25IjoVZJOF9aA+P1GqXDISIvdcVUi4KrlZAkW8sddR8md0Q+JizQD+lN+zpySRQi6ipyl2xaQgR6hXAJlO7E5I7IB93etCTK52e4JAoRdQ15fTvuStH9mNwR+SB5vbsDZ0phsQqFoyEib9NoubEEyrgBOoWj8T1M7oh8UFpCBMICNDDVNuJYoUnpcIjIy+ReKENlvRmRIf4YFs8lULobkzsiH6RRqzC6aSuyz89w3B0RdS55luwP+0dxCRQFMLkj8lHcioyIuso++3g7dskqgcmdC9yhgryVvN5d7oUyVNebFY6GiLxFRV0jTlytAABkNfUQUMdwh4pOxh0qyFvd0jsY8RFBKCyvxcFz1zF+IH/DJqKOy7tQBiGApN7B0IUHKh2OV+AOFUTUJpIkNeua5bg7Iuoc35wvAwBkJPVSOBLfxeSOyIdxvTsi6mzfXLgOAMi8JVLhSHwXkzsiHzY62TYe5lRRFUw1jQpHQ0Q9XYPZikPGcgBA5i1suVMKkzsiH9Y7NAB9o0IAAHnGMoWjIaKe7tvLJtQ1WtEr2A/9okOVDsdnMbkj8nEj+th+u867wOSOiDom98KN8XaSxPXtlMLkjsjHyYOec5ncEVEH5Zy3jbf7AcfbKYrJHZGPk5O7Q8ZymC1WhaMhop5KCGGfKcvxdspickfk4/rrQhEWqEFNgwUFVyuVDoeIeqjzpTUorW6Av0aFIdxPVlFM7lzgDhXk7VQqyT7ujl2zRNRecpdsWoIWARq1wtF4F3d3qGBy50JOTg6OHz8Og8GgdChEXYbj7oioo77heLsuYzAYcPz4ceTk5LSpPpM7ImJyR0Qd9s0FjrfzFO1K7goKCnDfffdBr9dDp9MhMzMTmzZtcusaRUVFWLhwIfr164fIyEhERUVh+vTpyM3NbfWcDz74AHfeeSciIyPRq1cvpKam4oUXXkB9fb1T3fPnz0OtVkOv17f4euedd9x+30TeKi0xAioJKCyvxVVTndLhEFEPU1pVj7Ml1QBuLK9EynE7ucvPz8fIkSNhsVhQUFCAoqIiGAwGzJ49G0uXLm3TNc6dO4f09HRs3boV7777Lq5fv44TJ04AALKysrB7926ncxYvXoyf/vSnyMzMxMWLF3Ht2jW88MILWL58OaZNmwaLxeJ0TmJiIq5evdri6xe/+IW7b53Ia4UGaDBQHw4AyLvI1jsico/capcSE4qIYH+FoyG3kjshBB555BEAwPr16xEREQFJkvDwww9j1qxZeO6553Do0CGX11m4cCGuXLmCV1991T44MDo6Ghs3bkRQUBDmzJnj0BqXm5uLF198Eenp6fjzn/+M0NBQqNVqzJgxA08++SQ+/fRTvP766+68FSL6HnbNElF7yf9vcLydZ3Arudu/fz8OHz6MyZMnQ6t1nOY8c+ZMWK1Wl7NK6+rqsHPnTgDApEmTHI6Fh4dj7NixMBqN2LZtm738ww8/bLE+AEydOhUA8Nprr7nzVojoe5jcEVF7yTNlOd7OM7iV3O3ZswcAkJGR4XRMLtu1a9dNr1FaWgqz2YzQ0FAEBgY6Hdfr9QBsiaSsqKgIgK11r7X6R48ehclkasvbIKIWyMmdbW9I52EOREQtqWu04Fih7efvD5LYcucJ3Eru5HFx8fHxTseio6Ph5+eHCxcuoLa2ttVrREZGQq1Wo6qqCjU1NU7Hi4uLAdjG5cl0Oh2AG0leS/W/fw4A1NTU4He/+x0GDx6MmJgYJCcn4xe/+EWbpxIDQEVFhcOrpckbRN4goVcQdGEBaLQIHLnEX5SIqG0OG8vRaBGICQ9AQq8gpcPxKvX19U55SFu4ldyVl5cDAEJCQpyOSZKE4OBgh3otCQoKwvjx4wHAoesVAKqqqnDgwAH717LJkycDAHbs2AEhhMM5chfv988BgLKyMuj1enz++ee4fPkyPvroIxiNRowePRrr16+/yTu9ITExEVqt1v5avnx5m84j6mkkSWLXLBG57Ztm4+0kSVI4Gu+yfPlyhxwkMTGxTecpss7dypUrodVq8cQTT2Dv3r0wm80wGo2YNWsW1GrbqtbNE8gxY8Zg7ty5OHbsGB577DGUlJSgrq4O7733Hl555RX7+L/m5yQmJuLKlSt46qmn0KtXL6jVagwbNgxbtmxBaGgoFixY0GJL4PcZjUaYTCb7a/HixZ383SDyHEzuiMhd8ni7HyRxvF1nW7x4sUMOYjQa23SeW8ldREQEAKC6utrpmBDC3s0q12vN4MGDkZeXh0mTJmHOnDnQ6/WYMmUKRo0ahRUrVgAAYmNjHc554403sGbNGuTn52PQoEHo378/Nm3ahB07diAuLs7pHLVajaioKKd7R0ZG4s4770RtbS22b9/u8j2Hh4c7vAICAlyeQ9RTjWj6zznvYplTKzkR0fdZrQJ5cssdx9t1uoCAAKc8pC007txk0KBBAIDCwkKnYyUlJWhsbERSUhKCglz3uScnJ2Pt2rVO5a+88goAYMSIEQ7lkiRh7ty5mDt3rtM5hYWFiI2NtU+ucEVOBq9cudKm+kS+YnBcOPw1KlyvbsD50hr0jXIegkFEJDtfWo2KOjMCNCoMjA1TOhxq4lbL3YQJEwCgxV0k5LKJEyd2KKCvv/4aGo0GM2bMaFP9goICVFRU4P7773coX79+fasTJy5fvgzgxkQNIrIJ0KgxLN42zIFds0Tkijz5aki8Fn5q7mjqKdx6EmPHjkVaWhq2b9/utOzI5s2boVKpYDAY7GVCiBb7h7ds2YJp06Y5lRcWFuLjjz/GggULnBKvu+66y2HyhOyvf/0rQkND8eSTTzqUr1+/HuvWrXOqX15ejs8++wz+/v748Y9/fPM3TOSDMm7huDsiaptDxnIAwLAE7c0rUrdyK7mTJAnr1q2z71RhMpkghMD69euxadMmLFmyBMOHD7fXX7hwIfr06YNFixY5XKesrAxbt27FypUr7duG5efnY8qUKRg9enSLM1JPnjyJp556CmfPngVgG/f35z//GWvWrMGmTZtanEGyZs0avPnmm2hoaAAAfPfdd7jvvvtQXl6Ol156CQkJCe68fSKfkNFHTu6uKxwJEXm6w5fKAQDDEyMUjYMcud2Gmp6ejpycHEiShJSUFOh0OqxevRobNmzAsmXLHOomJiYiODjYKfFKT0/HAw88gFWrVqF3795ISEjA/PnzMW/ePHzyySf2JVWa+9WvfoWQkBCMGjUKMTExGDJkCI4fP468vLwWWwFff/11LFmyBG+++Sb69u2LyMhIZGVlITQ0FHv27MHChQvdfetEPkGeVHG6uApV9WaFoyEiT9VoseLby7Z119ISIpQNhhxIglPiWlRRUQGtVguTydTm2SlE3mLMi/9GYXktNs+7DaP79VY6HCLyQMcKTZj6l8+hDfLDoWcmco27btDW3ISjH4nIiTx+5khTlwsR0fc1H2/HxM6zMLlzITMzE6mpqcjOzlY6FKJuM9Se3HEbMiJq2RGOt+s22dnZSE1NRWZmZpvqu7XOnS/Kyclhtyz5HHn8zJHCckXjICLPddho++VvGMfbdTmDwQCDwWDvlnWFLXdE5GRI01p3xuu1uF7doHA0RORpquvNOF1cCQBI4zIoHofJHRE50Qb5IblpdwqOuyOi7ztWaIJVALHaQOjCA5UOh76HyR0RtWgYx90RUSvk9e24BIpnYnJHRC2Sx9Gw5Y6Ivk8eb5fGyRQeickdEbUoLdHWcnf4km0nGiIimbwMCsfbeSYmd0TUotRYLdQqCSWV9bhaUad0OETkIa5V1aOwvBaSBAxhcueRmNwRUYuC/NXorwsFwHF3RHSDPFSjX3QowgP9lA2GWsTkzgUuYky+LI3j7ojoew7Z17djq1134SLGnYyLGJMvG5aoxd+/MbLljojsuDNF9+MixkTUaW603HFSBREBQggctu8pG6FoLNQ6JndE1KoB+jD4a1Qw1TbiQmmN0uEQkcKM12tRVtMIP7WEQbFhSodDrWByR0St8lOrkBprG5ZwmOPuiHye/P9Aamw4AjRqZYOhVjG5I6KbSuNOFUTUhF2yPQOTOyK6Kfk/8aNM7oh8nn3bMU6m8GhM7ojopuTlDo5dNsFi5aQKIl9lsQocK6wAwJ0pPB2TOyK6qeToUIT4q1HTYMGZ4iqlwyEihXxXUoXaRguC/dVIjg5VOhy6CSZ3RHRTapWEIfHyPrPlygZDRIqRh2YMjguHWiUpHA3dDJM7F7hDBdGN8TXcqYLIdx27bEvu5F/2qPtwh4pOxh0qiG6Mu+OMWSLfdaywKbmLY3LX3bhDBRF1OnmnihNXKtBgtiobDBF1O4tV4NvLtskUQzmZwuMxuSMilxJ6BUEb5IdGi8CpokqlwyGibnbuWjVqGiwI9FMhOSpE6XDIBSZ3ROSSJEkY2jTORu6aISLfIX/uU2PDoVEzdfB0fEJE1CaD421jT+VB1UTkO442JXdDOZmiR2ByR0RtIg+ilhcxJSLfIbfcDWZy1yMwuSOiNpGXPzhxpQJmCydVEPkKa/PJFEzuegQmd0TUJkmRwQgL0KDebMWZEu5UQeQrLlyvQVW9GQEaFfrruDNFT8DkjojaRKWSkBrXNO6OXbNEPkMebzeQkyl6DD4lF7hDBdENQzhjlsjnHLNPpuCC/krhDhWdjDtUEN3A5VCIfM8xzpRVHHeoIKIuM6TpN/fjVypgsQqFoyGiriaEuDFTltuO9RjtSu4KCgpw3333Qa/XQ6fTITMzE5s2bXLrGkVFRVi4cCH69euHyMhIREVFYfr06cjNzW31nA8++AB33nknIiMj0atXL6SmpuKFF15AfX19q+ds3LgRmZmZ0Ol00Ov1uP/++3Hq1Cm3YiUim75RoQjyU6OmwYJz16qVDoeIutjF6zWoqDPDX61CSkyY0uFQG7md3OXn52PkyJGwWCwoKChAUVERDAYDZs+ejaVLl7bpGufOnUN6ejq2bt2Kd999F9evX8eJEycAAFlZWdi9e7fTOYsXL8ZPf/pTZGZm4uLFi7h27RpeeOEFLF++HNOmTYPFYnE6Z8mSJXj44YdhMBhQVFSEgoICmM1mZGZm4siRI+6+dSKfp3aYVMGuWSJvJ0+eGhgbBn8NO/t6DOEGq9Uq0tLSRFhYmCgvL3c49uCDDwqVSiXy8/NdXmfq1KkCgNiyZYtDuclkElqtViQmJoq6ujp7+TfffCMAiPT0dKdrLV26VAAQ2dnZDuXffPONkCRJzJ4926G8vLxchIWFiYyMDGG1WluN0WQyCQDCZDK5fD9EvuTZLcdE0n//Szy39VulQyGiLrZ8+wmR9N//Ev/z/hGlQyHR9tzErTR8//79OHz4MCZPnuw0oG/mzJmwWq0uZ5XW1dVh586dAIBJkyY5HAsPD8fYsWNhNBqxbds2e/mHH37YYn0AmDp1KgDgtddecyjPzs6GEAIzZ850KNdqtbj77ruRm5uLL7744qaxEpGzwXHchozIV3AyRc/kVnK3Z88eAEBGRobTMbls165dN71GaWkpzGYzQkNDERgY6HRcr9cDsCWSsqKiIgBAdHR0q/WPHj0Kk+nGD5vOiJWInMnLoXxbWAErJ1UQeS0hhP2XuCFcBqVHcSu5k8fFxcfHOx2Ljo6Gn58fLly4gNra2lavERkZCbVajaqqKtTU1DgdLy4uBmAblyfT6XQAbiR5LdVvfk5NTQ0uXrwIf3//FhNCOf6CgoJW45RVVFQ4vG42eYPIF9yqC4W/RoXKejMuXnf+DBORd7hUVovymkb4qSUM0HMyhRLq6+ud8pC2cCu5Ky8vBwCEhIQ4HZMkCcHBwQ71WhIUFITx48cDgEPXKwBUVVXhwIED9q9lkydPBgDs2LEDQji2FMhdvM3Pke8vx/N9cvxlZWWtxilLTEyEVqu1v5YvX+7yHCJv5qdWYVAsu2aJvJ3cJZsSE4YAjVrhaHzT8uXLHXKQxMTENp2nyNSXlStXQqvV4oknnsDevXthNpthNBoxa9YsqNW2f0DNE8gxY8Zg7ty5OHbsGB577DGUlJSgrq4O7733Hl555RX7+L+Wks6OMhqNMJlM9tfixYs7/R5EPc0QbkNG5PXsXbJc304xixcvdshBjEZjm85zK7mLiIgAAFRXO69vJYSwd7PK9VozePBg5OXlYdKkSZgzZw70ej2mTJmCUaNGYcWKFQCA2NhYh3PeeOMNrFmzBvn5+Rg0aBD69++PTZs2YceOHYiLi3M4R75/S92+zePv1auXy/ccHh7u8AoICHB5DpG3s4+7Y8sdkdc62vTL25AEJndKCQgIcMpD2sKt7ccGDRoEACgsLHQ6VlJSgsbGRiQlJSEoKMjltZKTk7F27Vqn8ldeeQUAMGLECIdySZIwd+5czJ071+mcwsJCxMbG2idXBAcHo0+fPrh48SJKSkqcxt3J8Q8cONBlnETkTP5N/mihCUIISJKkcERE1JlEs50pOFO253Gr5W7ChAkA0OIuEnLZxIkTOxTQ119/DY1GgxkzZrSpfkFBASoqKnD//fd3e6xEvipFHwo/tYTymkYUlrc+gYqIeqYrpjpcr26AWiVhICdT9DhuJXdjx45FWloatm/f7rDsCABs3rwZKpUKBoPBXiaEaLF/eMuWLZg2bZpTeWFhIT7++GMsWLDAPkNWdtdddzlMnpD99a9/RWhoKJ588kmHcoPBAEmSsHnzZodyk8mEHTt2YMSIEcjKynL9ponISYBGbd+KiOPuiLzPt5dtn+v+ulAE+nEyRU/jVnInSRLWrVsHIQQeeeQRmEy2Lpn169dj06ZNWLJkCYYPH26vv3DhQvTp0weLFi1yuE5ZWRm2bt2KlStX2rcNy8/Px5QpUzB69OgWZ6SePHkSTz31FM6ePQvANm7uz3/+M9asWYNNmzY5zSDJyMjA008/jbfffhsbNmyAEAImkwkPP/wwAGDt2rXsSiLqALlrltuQEXkfeTytvN0g9Sxuz5ZNT09HTk4OJElCSkoKdDodVq9ejQ0bNmDZsmUOdRMTExEcHOyUeKWnp+OBBx7AqlWr0Lt3byQkJGD+/PmYN28ePvnkkxaXMPnVr36FkJAQjBo1CjExMRgyZAiOHz+OvLy8FlsBAeBPf/oT1q1bh1WrViEmJgYpKSlQq9XIyclBWlqau2+diJqRB1lzORQi7yO3yHOmbM8kie8vHEcAbIsXa7VamEymNs9OIfIl+RfLcM9fv0BUqD9y/vAjtoQTeZGs5Xtw2VSHv//6NoxK7q10ONSkrbmJIuvcEVHPNyg2HGqVhGtVDSiq4M4tRN7ienUDLpvqALBbtqdicudCZmYmUlNTkZ2drXQoRB4l0E+NftG2hcO53h2R95A/z7f0DkZYoJ/C0RAAZGdnIzU1FZmZmW2q79Y6d74oJyeH3bJErRgSp8Wpoip8e7kCEwbFKB0OEXUCeabsYI638xgGgwEGg8HeLesKW+6IqN3kLhu23BF5D3kG/OB4Nmz0VEzuiKjdBtuXQ+Fad0Te4jhb7no8JndE1G5yy11heS3KaxoUjoaIOqqq3oyz12z7rw/mZIoei8kdEbWbNsgPfSJt61LKv+0TUc914ortc6wPD0RUaIDC0VB7Mbkjog6Rf7vnYsZEPd+3TePthnC8XY/G5I6IOmRIvG1czrdsuSPq8Y41fY5TOd6uR2NyR0QdIo+74x6zRD2f/EvaEI6369GY3LnARYyJbk7ulj17rRo1DWaFoyGi9qo3W3C6qBIAMDieLXeehIsYdzIuYkx0c7qwQOjCAlBcWY8TVyqRkdRL6ZCIqB1OXa2C2SrQK9gPcdpApcOhZriIMRF1u8FczJiox5M/v4PjtJAkSeFoqCOY3BFRh8mLnX7LxYyJeqxj9uSOvVU9HZM7IuowedmEb6+w5Y6op7LvKcvxdj0ekzsi6jC55e7k1Uo0mK0KR0NE7rJYhX0BY7bc9XxM7oiowxJ6BSE8UINGi8Dp4kqlwyEiN50tqUJdoxUh/mr07R2idDjUQUzuiKjDJEm6Me6OixkT9TjyeLtBseFQqTiZoqdjckdEncI+Y5aLGRP1OPJkqCEcb+cVmNwRUacYLE+qYMsdUY/zrX3bMY638wZM7lzgDhVEbTOkqVv2+JUKWK1C4WiIqK2EEPY17oZwT1mPxB0qOhl3qCBqm+ToUAT6qVDTYMG50mr0iw5VOiQiaoNLZbWoqDPDX63CrTp+bj0Rd6ggIkWoVRIG6tk1S9TTHGsaJztAHwZ/DdMCb8CnSESdxr6YMSdVEPUY9sWLOd7OazC5I6JOw+VQiHoe+7ZjnCnrNZjcEVGnsS+HctkEITipgqgnYMud92FyR0SdJiUmDBqVhLKaRlw21SkdDhG5UFxRh5LKeqgkYJCeyZ23YHJHRJ0m0E9tn23HcXdEnk/uku0XHYogf7XC0VBnYXJHRJ1KXuH+GMfdEXk87kzhnZjcucBFjIncM4TbkBH1GPbJFBxv59G4iHEn4yLGRO6RZ9xxxiyR57sxmYItd56MixgTkaIGxYZDkoCrTQO1icgzldc04FJZLQDuKettmNwRUacKDdCgb1QIANj3qyQiz3O8qdWuT2QwtEF+CkdDnaldyV1BQQHuu+8+6PV66HQ6ZGZmYtOmTW5do6ioCAsXLkS/fv0QGRmJqKgoTJ8+Hbm5ua2es2XLFtx5551ISEhATEwMUlNT8eSTT6KkpMSp7meffQZ/f3/o9foWX/v373f7fRNR2wzhYsZEHo/j7byX28ldfn4+Ro4cCYvFgoKCAhQVFcFgMGD27NlYunRpm65x7tw5pKenY+vWrXj33Xdx/fp1nDhxAgCQlZWF3bt3O53z/PPPY8aMGUhJSbHf980338Tbb7+NjIwMlJaWOp2TlZWFq1evtvgaO3asu2+diNqo+WLGROSZjnGmrNdyK7kTQuCRRx4BAKxfvx4RERGQJAkPP/wwZs2aheeeew6HDh1yeZ2FCxfiypUrePXVV+0zP6Kjo7Fx40YEBQVhzpw5qK+/MVanoaEBy5cvR3R0NP7yl78gNNS2jlZWVhYWL14Mo9GINWvWuPNWiKgL2ZdDKWTLHZGnkn/54ng77+NWcrd//34cPnwYkydPdpqtMXPmTFitVpdLhtTV1WHnzp0AgEmTJjkcCw8Px9ixY2E0GrFt2zZ7eVlZGaqrq9G3b1/4+TmOC+jfvz8A4MKFC+68FSLqQnLL3cXrNTDVNiocDRF9X3W9GWevVQO4MYyCvIdbyd2ePXsAABkZGU7H5LJdu3bd9BqlpaUwm80IDQ1FYGCg03G9Xg8ADmPidDodYmJi8N1336GhocGhvtydO3ToUDfeCRF1pYhgf8RHBAG4MWibiDxHwdUKCAHowgIQHRagdDjUydxK7uREKj4+3ulYdHQ0/Pz8cOHCBdTW1rZ6jcjISKjValRVVaGmpsbpeHFxMQDbuDyZJEl46623UF9fj0cffRQlJSUwm83YvXs3XnzxRYwbNw6/+tWvWrzWvHnzMHDgQOh0OgwYMADz5s3DyZMn2/yeKyoqHF7Nu4uJqHVD4jnujshTcbxdz1BfX++Uh7SFW8ldeXk5ACAkJMTpmCRJCA4OdqjXkqCgIIwfPx4AHLpeAaCqqgoHDhywf93clClTsHPnTuTl5UGn0yEkJAQ/+clPMG/ePHz66acICHD+zcNoNGLUqFHIzc1FYWEh1q1bhy+//BLp6ekuWxhliYmJ0Gq19tfy5cvbdB6Rr5O7eo5xpwoij/MtZ8r2CMuXL3fIQRITE9t0niLr3K1cuRJarRZPPPEE9u7dC7PZDKPRiFmzZkGttm1c/P0E8rnnnsMdd9yBCRMmoLi4GNXV1di9ezfef/993H777bh48aJD/dGjR+PixYuYO3cuQkJC4Ofnh6ysLLz//vtoaGjAQw891KZWOKPRCJPJZH8tXry4874RRF5sCHeqIPJYcssdd6bwbIsXL3bIQYxGY5vOcyu5i4iIAABUV1c7HRNC2LtZ5XqtGTx4MPLy8jBp0iTMmTMHer0eU6ZMwahRo7BixQoAQGxsrL3+3r178cwzz2DMmDF4+eWXER0dDY1GgzFjxmDjxo04ePAgZs+e7XCPgIAA9OrVy+neAwYMwLBhw3DlyhV88cUXLt9zeHi4w6ulFkIicia3CHxXUoWaBrPC0RCRrN5swamiSgBsufN0AQEBTnlIW7i1t+ygQYMAAIWFhU7HSkpK0NjYiKSkJAQFBbm8VnJyMtauXetU/sorrwAARowYYS+TZ9dOmDDBqf7IkSMRGhqKffv24fr164iMjHR577i4OOTn5+PKlSsu6xJR++jCAxEdFoCSynqcuFKJjCTnX7aIqPudLqqC2SqgDfJDQi/XP6+p53Gr5U5OrlraRUIumzhxYocC+vrrr6HRaDBjxgx7mTz+TpKkFs9RqWxvw2S6MbZn5cqVOH36dIv1L1++DMA2C5eIus6QplaB45xUQeQx5HGwg+PCW/25Sj2bW8nd2LFjkZaWhu3btzskUgCwefNmqFQqGAwGe5kQosX+4S1btmDatGlO5YWFhfj444+xYMECh8TrtttuAwDs27fP6ZxDhw6hoqICer0eSUlJ9vKVK1fiww8/dKp/5swZHDt2DL1790ZWVlYb3jURtdfgOC5mTORp5HGwnCnrvdxK7iRJwrp16+w7VZhMJgghsH79emzatAlLlizB8OHD7fUXLlyIPn36YNGiRQ7XKSsrw9atW7Fy5UpYLBYAtm3NpkyZgtGjRzvNSJ05cybGjBmDPXv2YOnSpfYxf0ePHsVDDz0ESZLw8ssv21vwZM8//zw++ugjWCwWCCFw6NAh3H///RBC4I033rDP7iWiriEvh3KMLXdEHoN7yno/t2fLpqenIycnB5IkISUlBTqdDqtXr8aGDRuwbNkyh7qJiYkIDg52mrqbnp6OBx54AKtWrULv3r2RkJCA+fPnY968efjkk0+cki6NRmNf027r1q2IjY1Fr169MHHiRCQnJ2Pfvn2YOXOmwzkffPAB5s+fjz/+8Y9ISEhAZGQkpk6dikGDBuHgwYO499573X3rROQmueXuVFElGsxWhaMhIotV4MQVzpT1dpIQQigdhCeqqKiAVquFyWRq8+wUInIkhMDwP+6CqbYR//rt7ewGIlLY6aJKTHzlPwjyU+PYsrugVnHMXU/S1txEkXXuiMg3SJJk7/rhThVEyjvabDIFEzvvxeTOhczMTKSmpiI7O1vpUIh6JC5mTOQ55OSOreg9S3Z2NlJTU5GZmdmm+m6tc+eLcnJy2C1L1AFyyx23ISNSnvw5HMrkrkcxGAwwGAz2bllX2HJHRF1KbiE4fqUCFiuH+BIpxWIV9hb0oQlM7rwZkzsi6lJ9e4cg2F+NukYrzpZUKR0Okc86d60KNQ0WBPqpkBwV4voE6rGY3BFRl1KpbkyqOMquWSLFyJ+/1NhwaNT88e/N+HSJqMvJXbNM7oiUI+8Uw/F23o/JHRF1OfmHydFLTO6IlMKZsr6DyR0RdblhCTeWQ+GkCqLuZ7UKHOdkCp/B5I6IulzfqFAE+6tR22jhpAoiBZwrrUZVvRmBfircGh2qdDjUxZjcucBFjIk6Ts1JFUSKkte3G8TJFD0SFzHuZFzEmKhzDInXIud8GY5cMuHeEQlKh0PkU+TxrpxM0TNxEWMi8kjyuDvuVEHU/TiZwrcwuSOibjE0npMqiJRgbbYzxZA4Jne+gMkdEXWL5pMqvuOkCqJuc+F6DarqzfDXqNA/hpMpfAGTOyLqFmqVZG814Hp3RN3naLPJFH6cTOET+JSJqNtwpwqi7iePcx0az8mBvoLJHRF1m6EJXA6FqLtxpqzvYXJHRN1maHwEAOA4J1UQdQshBI5d5kxZX8Pkjoi6TXJUCEI4qYKo21worUFlnW0yRUpMmNLhUDdhcucCd6gg6jwqlYTBnFRB1G3skyn0YZxM0YNxh4pOxh0qiDrXkHgtDp6/jqOFJvw0gztVEHWlY1y82Ctwhwoi8mjyThWcVEHU9TjezjcxuSOibiX/kDl+uQJmi1XhaIi8lxACxwptO1NwpqxvYXJHRN3KcVJFtdLhEHkt4/VamGob4a/mZApfw+SOiLqVSiVhMBczJupyhy+VAwAGxobBX8Mf976ET5uIup3cRXSMyR1RlznSlNylJUQoGgd1PyZ3RNTt5ORO/uFDRJ3vsNH2y5M8iYl8B5M7Iup2Q5t+2By/wkkVRF3BbLHahz0MT4xQNhjqdkzuXOAixkSdr2/vEIQGaFDXaMUZ7lRB1OnOlFShttGCEH81kqNDlQ6HOoiLGHcyLmJM1PlsO1WE4+tz13HkkgkD9fyMEXWmw8ZyALZWcrVKUjYY6jAuYkxEPYLcVXSo6YcQEXWew03b+3EyhW9ickdEipCTu8NM7og6nfy5SuN4O5/UruSuoKAA9913H/R6PXQ6HTIzM7Fp0ya3rlFUVISFCxeiX79+iIyMRFRUFKZPn47c3NxWz9myZQvuvPNOJCQkICYmBqmpqXjyySdRUlLSYn2r1YpXX30VQ4YMgU6nQ1xcHObMmYMrV664FSsRdT75h07B1UrUNVqUDYbIi9Q1WnDyaiUAJne+yu3kLj8/HyNHjoTFYkFBQQGKiopgMBgwe/ZsLF26tE3XOHfuHNLT07F161a8++67uH79Ok6cOAEAyMrKwu7du53Oef755zFjxgykpKTY7/vmm2/i7bffRkZGBkpLS53Oeeihh/D000/jpZdeQnFxMXJzc1FQUIDMzExcunTJ3bdORJ0oVhuI6LAAWKyC690RdaJvL1fAbBWICvVHnDZQ6XBICcINVqtVpKWlibCwMFFeXu5w7MEHHxQqlUrk5+e7vM7UqVMFALFlyxaHcpPJJLRarUhMTBR1dXX28vr6ehESEiKio6NFQ0ODwzkrV64UAMTy5csdyt9//30BQDzzzDMO5adPnxaSJIl77rnnpjGaTCYBQJhMJpfvh4jaZ+6GHJH03/8Sa/7zndKhEHmNt/afFUn//S8xZ91BpUOhTtbW3MStlrv9+/fj8OHDmDx5stNsjZkzZ8JqtbpcMqSurg47d+4EAEyaNMnhWHh4OMaOHQuj0Yht27bZy8vKylBdXY2+ffvCz8/P4Zz+/fsDAC5cuOBQvnr1antczd16663IzMzERx99xNY7IoXZx91dYssdUWeRFwcfxskUPsut5G7Pnj0AgIyMDKdjctmuXbtueo3S0lKYzWaEhoYiMNC5uViv1wOwJZIynU6HmJgYfPfdd2hoaHCoL3fnDh061F7W0NCAzz//HCEhIRgwYECLsQohWuz+JaLuI8/kO2QsUzYQIi9inymbyJ0pfJVbyZ2cSMXHxzsdi46Ohp+fHy5cuIDa2tpWrxEZGQm1Wo2qqirU1NQ4HS8uLgZgG5cnkyQJb731Furr6/Hoo4+ipKQEZrMZu3fvxosvvohx48bhV7/6lb3+mTNn0NjYiLi4OEiS8/o+cvwFBQUu33NFRYXDq76+3uU5RNQ2w5p++Biv16K0ip8too4y1TTi3LVqAGy58wb19fVOeUhbuJXclZeXAwBCQkKcjkmShODgYId6LQkKCsL48eMBwKHrFQCqqqpw4MAB+9fNTZkyBTt37kReXh50Oh1CQkLwk5/8BPPmzcOnn36KgICANsXZvLyszHVrQWJiIrRarf21fPlyl+cQUduEB/qhX7Tt83iEXbNEHXaksBwA0CcyGJEh/soGQx22fPlyhxwkMTGxTecpss7dypUrodVq8cQTT2Dv3r0wm80wGo2YNWsW1Go1AOfE7LnnnsMdd9yBCRMmoLi4GNXV1di9ezfef/993H777bh48WKXxGo0GmEymeyvxYsXd8l9iHyVvFRDPte7I+owrm/nXRYvXuyQgxiNxjad51ZyFxERAQCorq52OiaEsHezyvVaM3jwYOTl5WHSpEmYM2cO9Ho9pkyZglGjRmHFihUAgNjYWHv9vXv34plnnsGYMWPw8ssvIzo6GhqNBmPGjMHGjRtx8OBBzJ49u01xNi/v1auXy/ccHh7u8GreQkhEHZfOxYyJOs2NnSk43s4bBAQEOOUhbeHW3rKDBg0CABQWFjodKykpQWNjI5KSkhAUFOTyWsnJyVi7dq1T+SuvvAIAGDFihL1Mnl07YcIEp/ojR45EaGgo9u3bh+vXryMyMhK33nor/Pz8cPnyZQghnMbdyfEPHDjQZZxE1LXS7DNmy1v8vBJR27HljgA3W+7k5KqlXSTksokTJ3YooK+//hoajQYzZsywl8nj71r7T1+lsr0Nk8n2G4u/vz9uv/12VFdX4+TJky3GKkkSfvSjH3UoViLquIH6cPirVSivacSFUudJVkTUNldNdSiurIdKAgbHta2Fh7yTW8nd2LFjkZaWhu3bt9sTKdnmzZuhUqlgMBjsZUKIFvuHt2zZgmnTpjmVFxYW4uOPP8aCBQug0+ns5bfddhsAYN++fU7nHDp0CBUVFdDr9UhKSrKXP/bYY/a4mjtz5gxycnIwY8YMJCQktOVtE1EX8teokNr0g+hw0/pcROS+Q02tdikxYQj2d6tjjryMW8mdJElYt24dhBB45JFHYDKZIITA+vXrsWnTJixZsgTDhw+311+4cCH69OmDRYsWOVynrKwMW7duxcqVK2Gx2PaUzM/Px5QpUzB69GinGakzZ87EmDFjsGfPHixdutQ+Zu7o0aN46KGHIEkSXn75ZXsLHgDce++9mDVrFlasWGHv1r169Spmz56NuLg4rFq1yp23TkRdSF7M+BDH3RG1m/zL0XB2yfo8t2fLpqenIycnB5IkISUlBTqdDqtXr8aGDRuwbNkyh7qJiYkIDg52mrqbnp6OBx54AKtWrULv3r2RkJCA+fPnY968efjkk0/sS6rINBqNfU27rVu3IjY2Fr169cLEiRORnJyMffv2Oe1EAQD/93//h+effx6///3vodPpMGLECAwYMAAHDx5kqx2RB2FyR9Rx3JmCZJIQQigdhCeqqKiAVquFyWRq8+wUImqfc9eqMX7FZ/DXqHBs6V3w1yiyShNRj2W1CqQt+xSV9WZsW3g7Bsdxtqw3amtuwv9BiUhxt/QOhjbIDw1mK05erVQ6HKIe51xpNSrrzQjQqJASE6Z0OKQwJncuZGZmIjU1FdnZ2UqHQuS1JEmyL93AfWaJ3Jd/sRwAMCReCz81f7R7m+zsbKSmpiIzM7NN9TmdxoWcnBx2yxJ1g+EJWvznVAkOGU14cLTS0RD1LLkXbL8UZSS5Xpyfeh6DwQCDwWDvlnWF6T0ReYThfSIAcDkUovbIa0ruRvRhckdM7ojIQ8gz/L4rqUJFXaOywRD1IKbaRpwqto1VZcsdAUzuiMhDRIUGIKFXEIQAjhhNrk8gIgC2JYSEAJJ6ByM6jPufE5M7IvIg6U1dSvL4ISJyzT7ejl2y1ITJHRF5jB80dSl9c+G6wpEQ9Ry5TZ+XEeySpSZM7ojIY/zgFtsPp/yL5bBYub46kStmixWHmpZB4Xg7kjG5IyKPMVAfjtAADarqzVzMmKgNThZVorrBgtAADRcvJjsmdy5wEWOi7qNWSUhvWhKFXbNErslLoKT3iYBaJSkcDXUVdxcxZnLnQk5ODo4fPw6DwaB0KEQ+Qe5a+uY8J1UQuZLL9e18gsFgwPHjx5GTk9Om+kzuiMijZN4SCYAzZonaIvcid6YgZ0zuiMijDE+0dS8Vltficnmt0uEQeaziijoYr9dCkm7s8EIEMLkjIg8TEqDBoFjbwPBv2HpH1Kq8pla7ATFhCA/0Uzga8iRM7ojI4/wgqalr9jwnVRC1xj7ejl2y9D1M7ojI48jr3bHljqh1cnL3AyZ39D1M7ojI48gtdyeuVKCq3qxwNESep67RgmOFFQA4mYKcMbkjIo+j1wYiPiIIVgHkX2TrHdH3fXvZhAaLFVGh/ugTGax0OORhmNwRkUeyd81yvTsiJ83Xt5MkLl5MjpjcucAdKoiU8QOud0fUKvlzwS5Z3+DuDhWaLo6nx8vJyUF4eLjSYRD5HHmQeP7FMpgtVmjU/F2UCACEEMi9UA6AyZ2vMBgMMBgMqKiogFardVmf/1sSkUdKiQlDWIAG1Q0WFFytVDocIo9hvF6La1X18FNLGBLv+gc9+R4md0TkkdQqCen2fWa53h2R7GDT52FIvBaBfmqFoyFPxOSOiDxWZhLXuyP6vi+/KwUAjOrbW+FIyFMxuSMij5XRbMasEELhaIiUJ4TAV2dtyd3ofkzuqGVM7ojIYw1PjIBaJeFqRR0Ky2uVDodIccbrtSgsr4VGJSHzFk6moJYxuSMijxXsr8HgONtsda53RwR88d01ALZffIL9ueAFtYzJHRF5tNuSbV1P8g81Il/2JbtkqQ2Y3LnARYyJlJXV9EPswJlSjrsjnyaEsE+mYHLnW7iIcSfjIsZEyhrZNxJ+agmF5bW4UFqDW6JClA6JSBHflVSjuLIe/hoVRvTheDtfwkWMicirBPtrkN70g+wAu2bJh8ldsiP6RHB9O7opJndE5PHG9IsCAHxxplThSIiU81VTl2xW0+eBqDXtSu4KCgpw3333Qa/XQ6fTITMzE5s2bXLrGkVFRVi4cCH69euHyMhIREVFYfr06cjNzXWq+9lnn0GtVkOv17f4CgkJgUqlQnFxscM5/v7+rZ6zf//+9rx1IlLAmFtvTKqwWjnujnyP1cr17ajt3B5zl5+fjzvuuAMTJkxAQUEBtFotNmzYgNmzZ+P06dNYunSpy2ucO3cOY8aMQUBAAP7xj38gMzMTJSUlmDt3LrKysrBt2zb86Ec/cjgnMTER58+fb/F6I0eORHh4OHQ6nUN5VlYWPvvsM3ffIhF5mLTECIT4q1FW04jjVyq4nyb5nFPFlSitbkCQnxppCRFKh0Mezq2WOyEEHnnkEQDA+vXrERERAUmS8PDDD2PWrFl47rnncOjQIZfXWbhwIa5cuYJXX33VPvMjOjoaGzduRFBQEObMmYP6+np7/cjISNxxxx0tXisvLw85OTlYsGCBO2+FiHoQP7UKo7gkCvkweZbsD27pBX8NR1TRzbn1L2T//v04fPgwJk+e7DRbY+bMmbBarS6XDKmrq8POnTsBAJMmTXI4Fh4ejrFjx8JoNGLbtm328mHDhmHDhg0tXu+1115DfHw8pk2b5s5bIaIepvmSKES+hkugkDvcSu727NkDAMjIyHA6Jpft2rXrptcoLS2F2WxGaGgoAgMDnY7r9XoAaNOYuMrKSmzevBm//vWvodFwVRcibzbmVtsg8oPnrqPBbFU4GqLuY2k+3i6ZyR255lZyd+LECQBAfHy807Ho6Gj4+fnhwoULqK1tfQ/IyMhIqNVqVFVVoaamxum4PCni3LlzLuPZuHEj6uvrMW/evBaPFxcXY968eRg4cCB0Oh0GDBiAefPm4eTJky6vLauoqHB4Ne8uJqLuMyAmDL1D/FHbaEH+RW5FRr7jxJUKVNSZERqgwVCON/Up9fX1TnlIW7iV3JWXlwMAQkKcFxGVJAnBwcEO9VoSFBSE8ePHA4BD1ysAVFVV4cCBA/avXXn99dcxY8YMxMbGtnjcaDRi1KhRyM3NRWFhIdatW4cvv/wS6enpLlsYZYmJidBqtfbX8uXL23QeEXUulUpCVlPr3YHv2DVLvkPukh3ZNxIaNcfb+ZLly5c75CCJiYltOk+RfyUrV66EVqvFE088gb1798JsNsNoNGLWrFlQq20LM7aUQDb35Zdf4siRI61OpBg9ejQuXryIuXPnIiQkBH5+fsjKysL777+PhoYGPPTQQ21qhTMajTCZTPbX4sWL3X/DRNQpxtjH3XFSBfkOeRIRu2R9z+LFix1yEKPR2Kbz3EruIiIiAADV1dVOx4QQ9m5WuV5rBg8ejLy8PEyaNAlz5syBXq/HlClTMGrUKKxYsQIAWm2Nk7322mtITU3FuHHjWjweEBCAXr2ct2cZMGAAhg0bhitXruCLL7646T0A2ySP5q+AgACX5xBR15DH3R02lqOq3qxwNERdz2yxIue8bRgCJ1P4noCAAKc8pC3cmoUwaNAgAEBhYaHTsZKSEjQ2NiIpKQlBQUEur5WcnIy1a9c6lb/yyisAgBEjRrR6bllZGf7xj3/gpZdeamvoDuLi4pCfn48rV66063wiUkZiZDASI4NgvF6Lg+dKcefAGKVDIupSRwtNqKo3Qxvkh9RY7nNObeNWy92ECRMAoMVdJOSyiRMndiigr7/+GhqNBjNmzGi1zvr166HRaDB79uxW66xcuRKnT59u8djly5cBwGnRYyLyfLfL4+64JAr5gP+csnXJ3pYcCZVKUjga6incSu7Gjh2LtLQ0bN++HSaTyeHY5s2boVKpYDAY7GVCiBb7h7ds2dLiunSFhYX4+OOPsWDBgpsmXq+//jpmzZp10+bJlStX4sMPP3QqP3PmDI4dO4bevXsjKyur1fOJyDPJ+2py3B35gj0FRQCACWylJje4ldxJkoR169bZd6owmUwQQmD9+vXYtGkTlixZguHDh9vrL1y4EH369MGiRYscrlNWVoatW7di5cqVsFgsAGzbmk2ZMgWjR4++6YzUvXv34uTJk23akeL555/HRx99BIvFAiEEDh06hPvvvx9CCLzxxhv22b1E1HPIixkXXK3EtSouTUTe66qpDkcumSBJwPiB7GmitnN7tmx6ejpycnIgSRJSUlKg0+mwevVqbNiwAcuWLXOom5iYiODgYKepu+np6XjggQewatUq9O7dGwkJCZg/fz7mzZuHTz755KZJ1+uvv44xY8Zg2LBhN43zgw8+wPz58/HHP/4RCQkJiIyMxNSpUzFo0CAcPHgQ9957r7tvnYg8QO/QAAzUhwFg6x15N7nVbnhiBKLDOJmP2k4SQgilg/BEFRUV0Gq1MJlMbZ6dQkTdY/n2E3j9P2fxk7Q4/GVmutLhEHWJR9YdxN6TJfivuwbAMP5WpcMhD9DW3ISrIRJRjzNpsG2bwr0Fxag3WxSOhqjz1TSY7Yt1T0zleDtyD5M7FzIzM5Gamors7GylQyGiJumJEdCFBaCq3owvuFsFeaH9p6+hwWxFYmQQ+utClQ6HFJadnY3U1FRkZma2qT6TOxdycnJw/Phxh1nARKQslUrCpMG21oxPjl1VOBqizrf7uG283Y8GxUCSuASKrzMYDDh+/DhycnLaVJ/JHRH1SHc1dc3uOl4Ei5VDh8l7WKwC/y4oBgBMHMQuWXIfkzsi6pFuS+6N8EANSqsb8M3560qHQ9RpDhnLUVrdgLBADTL7RiodDvVATO6IqEfyU6vwo6ZWjU++LVI4GqLOs/uE7d/zuAE6+Kn5Y5rcx381RNRj3TXE1jX7ybdXwVWdyFvcGG/HhYupfZjcEVGP9cP+0Qj0U6GwvBbfXq5QOhyiDrtQWo3TxVXQqCSMS2FyR+3D5I6IeqwgfzXuSIkGYGu9I+rpdp+wTaQY2TcS2mA/haOhnorJHRH1aD9u1jVL1NPJXbITOEuWOoDJnQtcxJjIs905IAYalYRTRVU4W1KldDhE7WaqacTBppnfHG9HzXER407GRYyJPJs22A+j+/UGwFmz1LPtPVkMi1UgJSYUSb1DlA6HPAgXMSYinyMvaLyTXbPUg/3jGyMA4MdN/56J2ovJHRH1eJNSYyBJwGFjOa6a6pQOh8htZ0uq8MV3pVBJwM9G9lE6HOrhmNwRUY+nCw/EiD69AADbj15ROBoi920+eBGAbeHi+IgghaOhno7JHRF5hWlpcQCAjV9dgJV7zVIPUtdowT9zLwEAZo1iqx11HJM7IvIK92UkICxQg3PXqrH3ZLHS4RC12Y5jV1Be04g4bSDGDeAsWeo4JndE5BVCAjSY2TRW6a3PzykcDVHbvfO1rUt25sg+UKskhaMhb8Dkjoi8xkNZt0CtkvDFd6U4zu3IqAc4ebUSOefLoFZJeCAzUelwyEswuSMirxEfEWTfsWLtAbbeked75+sLAICJg2IQEx6ocDTkLZjcucAdKoh6ll/d3hcA8PGhyyiu5LIo5LlqGsz4IK8QADDrNk6koNa5u0OFJITgtLIWVFRUQKvVwmQyITw8XOlwiMgN9/z1APIvlmPhhP743cQUpcMhatHfcy7iv98/iqTewdj7+3FQcbwdudDW3IQtd0TkdeTWu01fXUBdo0XhaIha1nwiBRM76kxM7ojI6/x4sB7xEUEorW7AlkOFSodD5OToJRMOXzLBTy3h/owEpcMhL8Pkjoi8jkatwkNZSQBsy6Jw9Al5kvKaBjz5z8MAgB8PiUXv0ACFIyJvw+SOiLzSzzL7INhfjVNFVfj0eJHS4RABAKrrzXhkfQ5OFlVCFxaAp+4aoHRI5IWY3BGRV9IG+eFnTeuGLdiUh9X/Pg0LtyUjBdWbLZj/di7yL5YjItgPb88dhcTIYKXDIi/E5I6IvNaTkwZgWlocLFaBFZ+ewsw1X+Fyea3SYZEPMlusWLT5EPafvoZgfzXWPZyJlJgwpcMiL8Xkjoi8VkiABq/+fDhefiANIf5qHDx3HT9e+R9sO3KF4/CoWwghUF1vxtMfHsXOb6/CX63CGw/+AOl9eikdGnkxrnPXCnktmZSUFKjVahgMBhgMBqXDIqJ2ulBajYXvHsJhYzkAQCUBIf4aBAeoEeyvQbC/GoF+agT6qRCosX0d4KdCgEaNAI0K/hoV/NW2P/3UKvipJfvXGpVk+1MtQaOy/V2jtpWpVRI0KqnpTxVUKtjLVJKtXP5T7VAGqJr+rpIAlSRBavpTLpMk718+QwgBqwCsQsAqBIT9a8BiFRBCwGIVsAgBqxVNf9rqWqw3jpktjmWNFtufZqsVZovtz8bmfzZ93WC2/b3RYvu6oenPerMF9War7dVoQW2jBXWNVtQ2WFDXaEF1gxnV9bY/5Z+yKgn466wR+PGQWGW/qdTjZGdnIzs7GxaLBadOnXK5zh2Tu1ZwEWMi79NosWLl7lN44z9n0Wjxjv/65CRP/lMCIEmABKnpzxvlaP73Zl83HcKNXNE5afx+Hun4k0M4lAnA3jIqmsqFELZa4sZx+zHYkjU0+1pO5LxFaIAGy6YNxk+57Al1QFtzEyZ3rWByR+S96hotqKhtRHWDBdX1ZtQ02FpY6ptaX+oaba0vdeam1hqHFhsrGi22l9ki0NDs60aLFWarsL0s1qaWIccWIkuzViX5mLVZqxMnfbSP3KqpliRb62hTC6dafaPl1HaspRZVCRr1jRZXjcqxZdZPbrFVSQjwU9tbcOUW3SA/udXX1vIb5KdGSICm6aVGiL8GQX5qLlRMHdbW3ETTjTEREXkE+Qexp5K7Gpt3R8rdkGjeRQnAar3RAta86xK40fr1/Zayprt8r6XNXtpCPC3H2bw1r6lt0F72/ZZAx3JbbbmrWT6veZczmlof5S7q5q2T6mZd1M2PE5FNu5K7goICLFmyBJ9//jmsViuSkpLw+OOPY9asWW2+RlFREZ5//nls27YNZWVlUKlUGDNmDJ555hlkZGQ41P3ss88wYcIEREdHt3ityspK1NbW4urVq9DpdPZyq9WKv/zlL1izZg2Ki4uh0Wjw4x//GM8//zxiYznmgYg8kyTZWpCIiNrD7dmy+fn5GDlyJCwWCwoKClBUVASDwYDZs2dj6dKlbbrGuXPnkJ6ejq1bt+Ldd9/F9evXceLECQBAVlYWdu/e7XROYmIirl692uJr8ODBuPPOOx0SOwB46KGH8PTTT+Oll15CcXExcnNzUVBQgMzMTFy6dMndt05ERETk+YQbrFarSEtLE2FhYaK8vNzh2IMPPihUKpXIz893eZ2pU6cKAGLLli0O5SaTSWi1WpGYmCjq6urs5YcPHxazZ89u8Vq5ubkCgHj//fcdyt9//30BQDzzzDMO5adPnxaSJIl77rnnpjGaTCYBQJhMJpfvh4iIiKirtTU3cavlbv/+/Th8+DAmT54MrVbrcGzmzJmwWq3Izs6+6TXq6uqwc+dOAMCkSZMcjoWHh2Ps2LEwGo3Ytm2bvXzYsGHYsGFDi9d77bXXEB8fj2nTpjmUr1692h5Xc7feeisyMzPx0UcfsfWOiIiIvI5byd2ePXsAwGlMXPOyXbt23fQapaWlMJvNCA0NRWBgoNNxvV4PwJZIulJZWYnNmzfj17/+NTSaG8MHGxoa8PnnnyMkJAQDBjjv25eRkQEhRIvdv0REREQ9mVsTKuRxcfHx8U7HoqOj4efnhwsXLqC2thZBQUEtXiMyMhJqtRpVVVWoqalBcLDjvnrFxcUAbOPyXNm4cSPq6+sxb948h/IzZ86gsbERt9xyS4szqOT4CwoKXN6joqLC4e8BAQEICAhweR4RERFRR9TX16O+vt7+9+/nJK1xq+WuvLwcABASEuJ0TJIke6Im12tJUFAQxo8fDwAOXa8AUFVVhQMHDti/duX111/HjBkznGa+3izO5uVlZWUu75GYmAitVmt/LV++3OU5RERERB21fPlyhxwkMTGxTecpsrfsypUrodVq8cQTT2Dv3r0wm80wGo2YNWsW1Grb2lOtJWayL7/8EkeOHMGCBQu6NFaj0QiTyWR/LV68uNOuXV9fj6VLlzpk5aQsPhPPw2fimfhcPA+fiefp6DNZvHixQw5iNBrbdJ5byV1ERAQAoLq62umYEAI1NTUO9VozePBg5OXlYdKkSZgzZw70ej2mTJmCUaNGYcWKFQDgch261157DampqRg3bpxbcTYv79XL9cbN4eHhDq/O7JKtr6/HsmXL+EH0IHwmnofPxDPxuXgePhPP09FnEhAQ4JSHtIVbyd2gQYMAAIWFhU7HSkpK0NjYiKSkpFbH2zWXnJyMtWvX4ty5c7h27RqOHDmCp59+GteuXQMAjBgxotVzy8rK8I9//AO/+c1vWjx+6623ws/PD5cvX7bvb9icHP/AgQNdxukNXM1g7kn36a730tX4TDyTt3y/+Ex88x7dxZu+X970XBy4s77Kvn37BADxs5/9zOnY9u3bBQAxd+5cdy7p5Gc/+5nQaDSiqKio1Tovv/yyCA0Nvek6L+PHjxcAxIkTJ5yOjRw5UkiSJIxGY6vnd8c6d921lt6gQYO69PrdeZ+uvgefiefdozvXnPSG71d33cObPivecg8+E8+7T2c/k7Zez63ZsmPHjkVaWhq2b98Ok8nksNbd5s2boVKpYDAYmieOuHTpktMAwC1btuCtt97Cxx9/7FBeWFiIjz/+GAsWLHDabaK5119/HbNmzbpp8+Rjjz2GvXv3YvPmzVi2bJm9/MyZM8jJycGMGTOQkJDQ6vmiqcWvrTNT2kO+dlfeAwAsFkuX36O77tPV9+Az8bx7dNczAbzj+9Vd9/Cmz4q33IPPxPPu09nPRL6OaG3DZ5m7WWNeXp4IDQ0V99xzjygvLxdWq1WsW7dOqFQqp90gHnvsMQFALFy40KF83bp1AoB45ZVXhNlstl83LS1N3HnnnaK6urrV+//73/8WAMThw4ddxjpr1iwRHBwsduzYIYQQ4sqVK2L06NEiPj7+pq12QghhNBoFmvbT5osvvvjiiy+++PKUl6scxq2WOwBIT09HTk4O/vCHPyAlJQVWqxVJSUnYsGEDfvnLXzrUTUxMRHBwsFPLXXp6Oh544AGsWrUKS5cuRWhoKOLj4zFv3jw8+uijDgsSf9/rr7+OMWPGYNiwYS5j/b//+z+sWrUKv//97zF79mxoNBrcddddeO+99xAXF3fTc+Pi4mA0GhEWFtbiWnlERERE3UkIgcrKSpc5jCSEq7Y9IiIiIuopFFnnjoiIiIi6BpM7IiIiIi/C5I6IiIjIizC5U0BBQQHuu+8+6PV66HQ6ZGZmYtOmTUqH5dXq6+vx97//HVOnToVer0fv3r0RHR2NKVOmYPfu3S2eU1dXh2effRb9+/eHTqdDUlISHn/8cZhMpm6O3rc89thjkCQJDz/8cIvH+Vy6nsViwV//+leMHj0affr0QUREBPr164ef//znOHz4sENdPo/uYbFYsGHDBowePRpxcXGIiYnBsGHD8Pzzz7e4FzufS+c7duwYsrKyIEkSzp8/32q99nzvt2/fjh/+8IfQ6XSIiYnB3XffjYMHD7Y/WJfriVCnysvLE2FhYWLGjBmirKzMYSmZZ599VunwvNZvf/tbAUAsXrxYVFRUCCGEuHDhgvjRj34kAIi//OUvDvUbGhrE+PHjhU6nEwcPHhRCCHHq1CnRv39/MXTo0G5ZUNcX7dq1S0iSJACIhx56yOk4n0vXq62tFRMnThSjR48Wx44dE0II0djYKFasWCEAiHXr1tnr8nl0n7lz5woA4o9//KOor68XVqtV/Otf/xJBQUEiPT1d1NfX2+vyuXSu2tpa8fTTT4vIyEgRFRUlAIhz5861WLc93/s1a9YIAOJPf/qTaGxsFDU1NeI3v/mN8PPzE59++mm7YmZy142sVqtIS0sTYWFhory83OHYgw8+KFQqlcjPz1cmOC9nMBjE2LFjncpLSkpEUFCQCAgIEGVlZfby//3f/xUAxNq1ax3q79mzRwAQTzzxRFeH7HPKyspEQkKCePDBB1tN7vhcut6iRYtE7969HT4PsnvvvVds3brV/nc+j+5x6dIlAUAMHz7c6djjjz8uAIjNmzfby/hcOtejjz4qpk+fLoxGo7jjjjtumty5+72/dOmSCAoKEj/84Q8dyhsbG0VycrKIj48XNTU1bsfM5K4bdcf2bdSyrVu3ip07d7Z4LD09XQAQe/bssZclJycLtVotKisrHeparVYRExMjwsLCRG1tbZfG7GtmzZolpk6dKvbu3dtqcsfn0rWKioqERqMRixYtalN9Po/u8dVXXwkA4oEHHnA6lp2dLQCIF1980V7G59K5zp8/b//aVXLn7vd+2bJlAoD429/+5nStp556SgAQb7/9ttsxc8xdN9qzZw8AICMjw+mYXLZr165ujclXTJ06FXfddVeLxxoaGgAAvXv3BgCcO3cOZ8+exYABAxAaGupQV5IkjBgxApWVlfjqq6+6Nmgf8v777+OTTz7BmjVrWq3D59L1PvroI5jNZtx2220u6/J5dJ+UlBQEBgbixIkTTsfksqFDhwLgc+kKSUlJbarXnu99V+UFTO66kfwhjI+PdzoWHR0NPz8/XLhwAbW1td0dms+6du0aTp8+jdTUVPuuJzd7Ts3LCwoKuidIL1dUVIT58+fjb3/7G/R6fav1+Fy6Xm5uLgBAq9XimWeeweDBgxEdHY3+/ftj/vz5uHjxor0un0f36dWrF/7yl7+goKAATz/9NCoqKtDQ0IB//vOfWLNmDWbOnInJkycD4HNRUnu+9zc7pyPPisldNyovLwcAhISEOB2TJAnBwcEO9ajrrVq1CmazGatWrbJvM3ez59S8vKysrFti9HZz587FpEmTcN999920Hp9L17t8+TIA4KGHHsLFixexe/duXL58GdnZ2fjoo48wYsQInDx5EgCfR3ebO3cu3nvvPbz77rvQarUIDQ3FvHnz8MILL+Cdd96x1+NzUU57vvc3O6cjz4rJHfmsr776Ci+++CL++Mc/YsKECUqH45Peeust5OXlYfXq1UqHQoC91yA0NBRvvvkmYmNj4efnh0mTJuHll19GaWkpHn/8cWWD9EFCCDz66KO45557MH/+fJSVlaGyshLvvPMOXnrpJUyePJmNAuSAyV03ioiIAABUV1c7HRNCoKamxqEedZ3jx49j6tSpWLhwIf7whz84HLvZc2pe3qtXry6N0dudP38ev/vd7/DWW2+16XvJ59L15JaCCRMmQKPROBybNm0aAGD37t2oq6vj8+hG69evxxtvvIFf/vKXeOqppxAREYGAgABMnjwZr776Knbs2GFPuvlclNOe7/3NzunIs2Jy140GDRoEACgsLHQ6VlJSgsbGRiQlJSEoKKi7Q/Mpx44dw5133ok5c+ZgxYoVTsdv9pyalw8cOLDrgvQB27dvh9VqxcMPPwy9Xm9/3XvvvQCAv//97/ayLVu28Ll0g1tuuQUAEBUV5XQsNDQUISEhMJvNuH79Op9HN9q5cycAtNjDIJd9+OGHAPj/l5La872/2TkdeVZM7rqR/CGUBy03J5dNnDixW2PyNfn5+Rg/fjzmz5+P//f//p+9/Pz58/bxRn379kVycjJOnTrltPK7EAL5+fkICwtr04xCat2CBQtQWVmJq1evOrw++OADAMDPfvYze9n06dP5XLrBD3/4QwDA1atXnY7V1NSguroaGo0GkZGRfB7dSP7+yuOCm5PLqqqqYLFY+FwU1J7vfVflBUzuutHYsWORlpaG7du3O21DsnnzZqhUKhgMBoWi8345OTmYMGEC/uu//gtLly51OLZ06VK88cYb9r8bDAaYzWb885//dKi3d+9eXL16FXPnzkVgYGB3hE3N8Ll0rSlTpiAhIQG7du2yLxEk27FjBwDg7rvvtn+P+Ty6h5wM7Nu3z+nYf/7zHwDAD37wA6jVagB8Lkpy93s/Z84cBAUFYfPmzQ71zWYz3nvvPcTHx+Oee+5xPxC3V8ajDsnLyxOhoaHinnvuEeXl5Q7bjz3zzDNKh+e1Dhw4IMLDw8XAgQPFs88+6/RKS0tz2P6toaFBjBs3zmkLmZSUFG7f08Vutogxn0vX+/TTT4W/v7/45S9/KUpLS4XVahVffPGFSEhIELGxseLs2bP2unwe3aOsrEwMGDBAqNVq8dprr4m6ujphtVrF/v37RZ8+fURAQIDYt2+fvT6fS9dxtYhxe773b7zxhgAgnn/+eWE2m0Vtba34zW9+IzQajfjkk0/aFSeTOwWcOHFC3HvvvUKn04moqCiRkZEhNm7cqHRYXm369OkCwE1f39/bt7a2VjzzzDMiOTlZREdHi8TERLFo0SKnreOoc/zpT38SMTExolevXgKACAwMFDExMWLo0KEO9fhcut4333wjpk2bJiIjI0VERITo27ev+O1vfyuuXr3qVJfPo3uUl5eLp59+WgwePFiEhYUJrVYrEhISxKxZs8Thw4ed6vO5dJ6vv/5axMTEiJiYGOHn5ycAiKioKBETEyN+97vfOdVvz/d+27Zt4vbbbxdRUVEiOjpa3HXXXeKrr75qd8ySEEK4395HRERERJ6IY+6IiIiIvAiTOyIiIiIvwuSOiIiIyIswuSMiIiLyIkzuiIiIiLwIkzsiIiIiL8LkjoiIiMiLMLkjIiIi8iJM7oiIiIi8CJM7IiIiIi/C5I6IiIjIizC5IyIiIvIi/x+TxiXFR496+AAAAABJRU5ErkJggg==", + "text/plain": [ + "
" + ] + }, + "metadata": {}, + "output_type": "display_data" + } + ], + "source": [ + "import numpy as np\n", + "\n", + "data = np.fromfile('3d_lightcurve_tl.bin', dtype=np.float64)\n", + "print(data.shape)\n", + "\n", + "plt.plot(data)" + ] + }, + { + "cell_type": "code", + "execution_count": 14, + "metadata": {}, + "outputs": [ + { + "data": { + "text/plain": [ + "[]" + ] + }, + "execution_count": 14, + "metadata": {}, + "output_type": "execute_result" + }, + { + "data": { + "image/png": "iVBORw0KGgoAAAANSUhEUgAAAlwAAAFxCAYAAACmxnbFAAAAOXRFWHRTb2Z0d2FyZQBNYXRwbG90bGliIHZlcnNpb24zLjkuMiwgaHR0cHM6Ly9tYXRwbG90bGliLm9yZy8hTgPZAAAACXBIWXMAAA9hAAAPYQGoP6dpAABAdUlEQVR4nO3deXxU9b3/8fdkm+xhCwlLBFEUg4BbrNqKC3VBcaO2at3A0oqNVkqrvWh/BawFr9b21hr1alW4XqVeq6VWqVbcW6BEQSoqSqtIENlJJutMMvP9/UFmMkMmk8ky52ROXs/Hg4dkzpk5X885JJ98vp/z+bqMMUYAAABImBS7BwAAAOB0BFwAAAAJRsAFAACQYARcAAAACUbABQAAkGAEXAAAAAlGwAUAAJBgBFwAAAAJRsAFAACQYEkfcG3cuFGnnHKKXC6XtmzZYvdwIuzdu1czZ86Uy+XSkiVL4n5fdXW1SkpK5HK59MYbbyRsfAAAwBpJG3A1NTXp9ttv12mnnabNmzfbPZx2nnjiCZWWlur111/v8ntvvPFGbdu2LQGjAgAAdkjagGvOnDn64IMPtGHDBo0fP97u4UT4/e9/r7vvvlvLly/XjBkzuvTeZ599Vi+//LLOPffcxAwOAABYLmkDrnnz5mn58uUaOXKk3UNpZ/LkyVq3bp1OPvnkLr1v586dmj17th566CEVFRUlaHQAAMBqSRtwjRo1qkv7v/baazr77LM1aNAgDRo0SEceeaTmzZun2traXh/b8OHDlZ6e3uX3zZo1S+ecc46+8Y1v9PqYAACAfZI24OqKRx99VF//+tdVWlqqqqoq7d27Vw899JAeffRRTZ48WQ0NDXYPUb/73e+0fv163X///XYPBQAA9DLHB1zbt29XeXm5jj76aP3qV79STk6OXC6XzjjjDM2fP1/vvfee7UHOli1b9KMf/UiPPfaYBgwYYOtYAABA70uzewCJ9swzz8jr9Wrq1KlKSYmML4M1Vs8//7xuvfVWSVJDQ4PuvvvuLh1jzpw53Q6UAoGAZsyYoSuvvFJnn312tz4DAAD0bY4PuD7++GNJ0oMPPqilS5dGbDPGKCcnR3v27Am91tDQoIULF3bpGDNmzOh2wPXrX/9a27Zt04svvtit9wMAgL7P8QFX0Lx58zRv3rxO9xsyZIiMMRaM6IBnn31W+/bt02GHHRbxek1NjSRp+vTpysjIUGZmZp9r7AoAAOLj+BqucePGSZKqqqqibn///fe1fv16K4cUYdWqVdq3b5927NgR8eeyyy6TJD333HPasWMHwRYAAEnM8QHXN7/5TWVmZmr58uXy+XwR27xer8455xytXLnSptEBAID+wPEB17Bhw/Tggw9q586d+t73vqd9+/ZJOvD04mWXXaaioiJdf/31No8SAAA4mctYWbDUi9auXasLL7xQkrRv3z41NzdryJAhSk1N1ZVXXql77703Yv+33npLd911l9auXauMjAzl5eXp4osv1k9+8hMNGjSo18c3cuRItbS0qK6uTvX19crPz1dWVpYOPfRQrV69usP3TZw4Ubt27VJNTY2ampo0cOBAZWRk6KabbtLtt9/e6+MEAACJl7QBFwAAQLJw/JQiAACA3Qi4AAAAEiyp+nAFAgFt375deXl5crlcdg8HAAD0c8YY1dbWavjw4e1WtAmXVAHX9u3bVVJSYvcwAAAAIlRVVWnkyJEdbk+qgCsvL0/Sgf+p/Pz8hBzD4/GopKQkoceQpLKyMlVWVibs8606hhXHcdI1seo4TrkmkjPOlxXH4Jr0zWM46fuXU75H9vY1CX5eMEbpSFIFXMFpxClTpig1NVXl5eUqLy9PyLHy8/MT+o8jNTU14d8UrTiGlcdxwjWx6jhOuSaSc84X16R/HiPICd+/nPQ9Uur5NamoqFBFRYX8fr8kdVrqlFQBV1BlZaVl/0gSJVGBotXHsPI4ieak8+WUayI553xxTfrnMazipPOVLNclmPTxeDwqKCjodP+k6sMV/J+qqalJ6JRioo+BruGa9D1ck76Ha9I3cV36nt6+JvF+Hm0hDuJ2uzV//ny53W67h4JWXJO+h2vS93BN+iauS99j1zUhwwUAANBNZLgAAAD6CAIuAACABCPgAgAASDACLgAAgARLyoCrrKxMpaWlqqiosHsoAACgH6qoqFBpaanKysri2p+nFAEAALqJpxQBIMHmPv2e5j79nt3DAJAECLiAfuD9bTXatMNj9zAcpaaxWc+t/0LPrf9CnqZmu4cDoI8j4AIcrtHn17f+e7Uuf3iNAoGkqSDo8xp8LW1/9/ptHAmAZEDABTjc/gafGpv9qm5oVkMzgUFvqQ8LsurDgi8AiIaAC3C4yEwMgUFvqQ87l/WcVwCdIOACHC4yE0OGq7eEZ7XqmVIE0AkCLsDhIgMDMjG9Jbxuq4EpRQCdSMqAi8anQPwiAwMyMb0lPJCtI5AF+p2uNj5NS/B4EqKyspLGp0CcIjJcZGJ6TT2BLNCvlZeXq7y8PNT4tDOWZ7i8Xq+efvppTZs2TcXFxRo8eLAKCwt1/vnna+XKlVYPB3C88GCA9gW9p4GpWgBdYHnAdcstt+jyyy/XxIkTtXnzZu3du1fvvvuufD6fzjrrLN1///1WDwlwtIin6chw9RoyXAC6wvKAKxAI6NRTT9WiRYuUl5cnSTrkkEO0bNkyZWVl6cc//rGqq6utHhbgWOHBAJmY3sPDCAC6wvKA69xzz9Xtt9/e7vUhQ4Zo3Lhx8nq9WrdundXDAhwrPDAgE9N7yBwC6ArLi+anTZvW4TafzydJGjx4sFXDARwvvG6LTEzvoTYOQFf0mbYQe/bs0ebNm1VaWqqJEyfaPRzAMchwJUZ4KwjaQgDoTJ9pC3HfffeppaVF9913n1wuV8x9PR5PxNdut1tutzuRwwOSFhmuxGggkAX6Ja/XK6/XG/r64JikI30iw7VmzRrddddduuOOOzRlypRO9y8pKVFBQUHoz+LFiy0YJZCcyHAlBotXA/3T4sWLI2KQkpKSuN5ne4brww8/1LRp0/SDH/wgajF9NFVVVRGNT8luAR2LeEqRwKDXsHg10D/NmzdPc+fODX3t8XjiCrpsDbg2btyor3/967ruuut09913x/2+/Px8Os0DcQoPBiju7j2R7TY4r0B/0d0yJtumFNevX68zzjhDs2fPjgi2tmzZou3bt9s1LMBxwgMDirt7T+RULecVQGy2BFyVlZWaMmWKbrnlFi1YsCBi24IFC/Twww/bMSzAkRoIDBIi4mEEauMAdMLyKcVVq1Zp6tSpGj58uBoaGtoFXO+9955Gjx5t9bAAx4qs4SIw6A2+loB8/kDE183+gNJT+8RzSAD6IMsDrrvvvlsej0cej0cLFy6Mus/FF19s7aAAhwoEzEENOslw9YZomcIGr18F2QRcAKKzPOBavny51YcE+q3G5siMVkOzX4GAUUpK7F53iC2YKcxIS5GM5PMHVO9rUUF2us0jA9BX8esY4GAHt4EwRmpqYVqxp4JPfua605TjTo14DQCiScqAq6ysTKWlpaqoqLB7KECfFizsznWnKbiAAy0Mei4YXGVnpCo748BEAfVxQP9SUVGh0tJSlZWVxbW/7Y1Pu6OyspI+XEAcghmuYBamztvSWn9Es+CeCNbF5WSkycgceI0MF9CvlJeXq7y8XB6PRwUFBZ3un5QBF4D4BAOD7Iw0GXMg4KIXV88Fz2G2O1XGRL4GANEQcAEOFj71JUmq9bKeYi8IPqWY604LBVycVwCxEHABDhY+9RVEcXfPBevgsjPaMlysUwkgFgIuwMHqw6a+gsjE9Fwww3Wghqv1NR5GABADARfgYGS4EqOuNbjKcbcVzVPDBSAWAi7AwYLTXKEaLpHh6g0N4ZnDUA0XAReAjhFwAQ7WEJaJCfXhIjDosfrwthAm8jUAiIbGp4CDhWe4gg06qTXqufCnP+k0D/RPND4FEBItw0WtUc9FtIVofY0O/kD/QuNTACHRa7gIuHoq1BbCnSbTOqfIeQUQCwEX4GDhTym2JrioNeoFoSWTwvtwkTkEEAMBF+BgEX24WiMu1vzrueB5zXFTNA8gPgRcgINFZrgORFwEBj3H4tUAuoqAC3CwiBquYIaLWqMeq4+yeDWBLIBYCLgABwt/SjElxRXxGrrHGBMKrsIXr673tsgYI1fwcVAACEPABThYQ1iGi8anvcPbEpA/cCDKys5IDbWFaAkY+fwBudNSO34zgH6LxqeAQxlj2mqN3Gmh9RTpF9Uz4UsjZWekKTs9rOUG5xboN2h8CkCS5PMH1BKWiQnPcDH11X3B+q3M9BSlprgkueROS5G3JaA6b4sG5mTYO0AAluhq49OkzHAB6Fx4tiU7oy3DZYzU1Bywa1hJrz6sy3xQ8O8sDA6gIwRcgEMFA4NgJiYrbOqLOq7uC3WZz2gLuLKD6ylyXgF0gIALcKjwXlGSlJLiCi3xQ61R94UvXB3UVh9HwAUgOgIuwKGCP/yzwgKDYFaGTEz3NUSZUsxx80ACgNgIuACHOjjDJUk5rVNfND/tvvCFq4NCmUPOK4AOEHABDhWxjmIrWkP0XEPYwtVBofNK0TyADhBwAQ4VK8NFrVH31cUqmue8AuhAUgZcND4FOhexjmKrbDIxPdZWw9V2XkNtIQi4gH6DxqcAJEWuoxhEDVfPRa/hIpAF+pukany6ceNGnXLKKXK5XNqyZYudQwEcJ2aGixqubgtOG0bWcDGlCCA2WwKupqYm3X777TrttNO0efNmO4YAOF74OopBOTxN12PBQDYnWlsIMlwAOmBLwDVnzhx98MEH2rBhg8aPH2/HEADHi9agM5t+UT0Ws90GGS4AHbClhmvevHkaNWqUHYcG+o2ogQEZrh6ri9JuIzhVW0fABaADtmS4CLaAxIvah4uprx5riDKlyOLVADqTlG0hAHQueoaLNf96KvT0Z0b7TvMsmQSgI0nZFsLj8UR87Xa75Xa7bRoN0DdFfUqRBp09Fu285oT6cJHhApzO6/XK6/WGvj44JulIUma4SkpKVFBQEPqzePFiu4cE9DlR+3BlMPXVU/VRzms2bSGAfmPx4sURMUhJSUlc70vKDFdVVVVE41OyW0B70ftwMfXVE8aYsLYQ7TvN1/taZIyRy+WyZXwAEm/evHmaO3du6GuPxxNX0JWUAVd+fj6d5oFONEbrw8XUV480NQdkzIG/R9RwtZ7XgJG8LQFlpqdGezsAB+huGVNSTikC6BwZrt4X3vYhKyyoyg77O60hAERDwAU4kD9g1NQckHRwg862Gi4TTNUgbqGWEBmpSklpmzZMSXGFglmyhwCiIeACHCi8sWlkg84Df/cHjLwtAcvHleyiLVwd1LaANRkuAO3ZEnCtXbtWxcXFKi4u1qpVqyRJZWVlKi4u1o9+9CM7hgQ4SvApxLQUlzJS2/6ZZ4dlu3iiruvqfe0Xrg7KoeUGgBhsKZo/8cQTtWPHDjsODfQL4esohj8xl5riUlZ6qhqb/Wrw+TXYrgEmqbbzGivDxZQigPaYUgQcKJjhihYYhDIxTH11WfC85kaZUsxlAWsAMSRlwFVWVqbS0lJVVFTYPRSgT4q2jmJQKBNDcXeXxXVeyXAB/UJFRYVKS0tVVlYW1/5J2YersrKSPlxADNHWUQwKPU1HhqvLggFXtPNKDRfQv5SXl6u8vFwej0cFBQWd7p+UGS4AsUXrwRUUbA1Bhqvr6kPNZKOcV55SBBADARfgQNHWUQwiw9V9Db6Oi+bp4g8gFgIuwIFiZrioNeq2toWro9VwHXiNTvMAoiHgAhwoVg1X25QigUFXxWoL0dbFn/MKoD0CLsCBYj1Nl0P7gm6L1RYiJ7ROJZlDAO0RcAEOFPspRaYUu6vO2/FUbTaZQwAxEHABDhQzw0XRfLeFFq+OmuGiaB5Ax5Iy4KLxKRBbzAwXbSG6rT7G05908Af6FxqfAujkKUUyXN3VEHPx6mDRPIEs0B/Q+BRA7D5cZLi6rc7b8RqVtIUAEAsBF+BAZLgSI3jOoi9eHazh4rwCaI+AC3CgUA1X1E7zB14jE9M1gYAJnddYi1c3NPsVCBhLxwag7yPgAhyoIUaGK5dao25paG47X7EWrzZGamzm3AKIRMAFOFCohivqU4qtT9OR4eqS4FRhikvKTG//rTMrPVUu14G/86QigIMRcAEOY4xpq+GK2oerLcNlDFNf8aoPa7XhCkZWYVwuF724AHSIgAtwGG9LQMESolgZrpaAkc8fsHJoSS1WM9kgnlQE0JGkDLhofAp0LHyqMCs9SnF32GtkYuIXPK/RgtggenEB/QeNT4F+LvQkXUaqUlLaT32lpabInZYib0tA9b4WDczJsHqISSnWk59BdJsH+g8anwL9XFsPLjIxvSlWb7OgbGq4AHSAgAtwmHpvW4arI9QadV1oSjFWhiuDJ0ABREfABThMrB5cQW1d0cnExCuuQDa4bBJTigAOQsAFOEx9jHUUg4JBA4FB/GIt6xOUm8FULYDoCLgAh4knw9VWw0XAFa9YC1cHBVtGMFUL4GAEXIDDhDfo7Egow8WUYtyCwWlOjD5cbY1PCbgARCLgAhymIY4GnW3d5gkM4hXPVG1OqIaLQBZApKQMuGh8CnQsrgyXmwxXV7U1Po01VctTikB/QeNToJ8jw5UY8fQ3C24jw5W8AgETtWEwcDAanwL9XHw1XAe21ZHhiltbp/lYgeyBbdRwJaffrNys4+58RX967wu7hwIHsi3g2rRpky699FIVFxdr6NChKisr05NPPmnXcADHiO8pxdSIfdG5uBqfUsOVtFa8/6V+vfITVTc060f/t0Gvb9pl95BsY4yRMcbuYTiOLQHX+vXrdeKJJ8rv92vTpk3auXOnysvLdc0112jBggV2DAno0xp9fj2xeove31bT6b5dKu7u5QxXIODcb9LxLZlEDVcy+vfuOt3yzAZJ0siBWWoJGN3w5Lt6Z8s+y8bQV/7tGGM05+n3dMpdr2n1v/faPRxHsTzgMsZo5syZkqQlS5ZowIABcrlcmjFjhq688kr9/Oc/13vvvWf1sIA+65/bqnX+b9/W//vTB/r279boy5rGmPvHk+EKbuutDFdNQ7O++z/v6Nifv6Ite+p75TP7mgZv51OK2dTGJZ16b4tmP/Gu6n1+nXjoIK2ce5rOHDdUTc0BXbekUpt2eBJ6fGOMlq3dqmN//opmPr5W++t9CT1eZ55b94X+9N52fVnTpGsfW6s/b9hu63icxPKA6+2339aGDRt03nnntSsyu+KKKxQIBHj6EI700Zce/e7tT/VeVXVc+7f4A7rv1c2a/sAqfbr7QBBT29Si/3j2/Zjp/nhquHJ6sbh70w6PLqz4m175cKdqGpu1YuOXPf7MviiY4Yp1XnMTlDlEYhhjNO+597V5V52G5rl1/7ePVWZ6qiq+fZyOHzVQnqYWXfPoWlXta0jI8XfVNmnW0nc077n3VdPYrNc/3q0L7v+bNn7ReSa7M92ZFtxX79OdL34oSRo1OFs+f0A3LVuvR//2WY/HAxsCrldffVWSdPzxx7fbFnztlVdesXRMQKLUe1v0dOVWXVzxd039zdu688WPdHHF33XNY2v17uf7O3zfZ3vqdelDq/WrVz5RS8Do/AnD9Mzsk5WRlqI3P9mt/3unqsP3Nvo6f0oxuK2nxd1/3rBdl1Ss0ud7G5SeeuDJrmSbhvAHOv/B1OIPqKk5ICm+JZMam/3y95EpomQUCBhLptiWrtqi5zdsV1qKSxVXHqeheZmSpKyMVD12bZmOLMrTrlqvrn70H9pT5+3VY7+0cYfO/a+39eqmXcpITdFNZx6uQwZla9v+Rn3jwVX64/pt3f7sTTs8Ove/3tZ59/1N26tjZ8TD3fnih9rf0KxxxXl6ec5kXXPyKEnSz1/4UL948cM+M+2ZrCxvC/HRRx9JkkaMGNFuW2FhodLT0/X555+rsbFRWVlZlo7t8731+n1lxz/IgK7YW+fVivd3hJZ5SUtx6bhDBurdrfv11ie79dYnu3Xq2CG68YzDlZGWoo3bPdq4rUbvf1GjT3bWqiVglJeZpp9fdLQuOma4XC6XfnTWEVr8l036+Qsf6WtjCzViQPt/I6EarjgyXOFr/hlj9NcPd+qTHbUakudWUb5bQ/MyNTTPrYLsdLnU9qh8wBj96pVP9PBbn0qSTh07RN8//XBd8cgavbNlv3wtAWWkxf/73C5Pk55au1XelkDc7+mOgDGqrm/Wrtom7fR4tavWq731XqWnpmhonltF+Qf+f4fmuUMLUUtSc9i44lkySZIWr/hI6V04B/2VMVJtU7N21R64Hrs8TdpdeyC4GZLr1tDgfZjvVn5mulxxdGwoGZitK04skSvGzuu27tedLx74eTTvvKNUNnpQxPaC7HT9z3dO1DceXKUtexv03f95R8u+e5Iy0zu+/vFoavbr/y3fqGfePRBQHTUsX7++bJLGFedr1tfG6Oan1+uNj3frh09v0IaqGt1+/lFKT43/Pnp+w3b95A//VGPzgX/blz+8Rsu+d1LU7xXh/v6vPXpu3RdyuaTF0ycoMz1VCy8cr2EFWfrPlzbpkbc/07921WncsORryTQ4J0OzTh1j9zCsD7iqq6slSTk5Oe22uVwuZWdnq6amRtXV1R0GXB5P5Jy62+2W2+3u8di+qG7Ug2/8u8efA4QbPThbl5UdokuPH6nCPLc+31uvB17/t55dt01vb96jtzfvifq+rx4+WHdfOiniG+WsU8fo5Q92aN3Wav3kD//UE985sd0PlbiWoDlozb9NOzz62Z8+0NrPul4kfMPph+nHZx8pl6RBORnaV+/T+19U6/hRgzp9b9AdL3yoF/5p31SkryWgbfsbtW1/7GxArjtN7hhBlDstRbnuNNV5W/Q7pmF6bIenSTs8TZK6PsU2fni+JpUM6HD7I299qpaA0XkTinXdV0dH3acoP1P/c92JuuSBVVq/tVq3/uGf+s3lx8QM5GJp9Pn13f95R3/71x65XNL1kw/TD88aK3fagX+PBdnpeuzaMv3Xyk9032v/0pJVW/Txjlo9dPXxKshKj/nZLf5AKDCSDnz/qNrXqK37GnT5w6u17LsnaeTA7KjvbWr267Y/vi9JuuakUTr2kIGSDvxMvuH0w1SU79atf/inXv94t17/eHe3/t/tNHZobq8GXF6vV15vW8bz4JikI0nZ+LSkpCTi6/nz5/fK043DCrJ03VcP7fHnAJKUnurSaUcU6qQxgyMaKY4anKP/vHSibjzzcD3wxr/07LtfKC8zTUePKNCEEQU6ekSBjh6RrxEDstp9Y09NcemX35ykqb95W3/71x49tXarrvzKqIh9gnVZcTXo9LZowfMf6Ik1n8sfMMpMT9G544vlaWrRrtom7fJ4tafOq2gzCQVZ6Vo8fYLOmzAs9NpXDh2kv2zcodX/3ht3wLWv3qe/frBTknTFiYcoq4cZhM4MyE5vy97lu1WY55a3ORD6/91V69VOT1NoCjHc5COGxPxh63K5dP+3j9Vbn0QPohFdrjtVhfmZKspza2h+pory3XLJFZaJPPDfuqbOp8Cf3/CF9tT5tL8hdvF5TWOzJOnco4fFvKZjCnP14JXH6ZrH1ur5Ddt1+NBc/WDK2K79D+rAL0Kzlr6jVf/eq5yMVD1yzQk65fAh7fZLSXFp7tlHasLIAfrh0+9p9ad7ddl/r9aSmSequCAz6mfvrfPqpmXrtap1Oj/4S9BOT5OueGSNPt/bcCDT9d2TVDKofdD129c26/O9DSrOz9SPzzmy3fbpx43UqME5+sv7X0b9XtDXFeb1PCETbvHixVq4cGGX32d5wDVgwABJUn19+yeZjDFqaGiI2C+aqqqqiE7zvZHdkqRDh+ToZxeU9spnAZ0pGZStxdMn6s6LJyjFpbh/ax5TmKtbzx3XWlfxkSaPLQx9E232B+Rrnf6KZ0qxJWC0ZNUWSdLUo4v102ml7aYeWvwBNTS3LwLPSk9tN9Vx8mGD9ZeNO7Tm03268cy4/nf0x/VfyOcP6OgR+Vo8fUJ8b0qAaD+IuuP0I4fq9COH9spn9XcdBRixrK/arz11vk6np4PbM+KYrjvl8CG646Kjddsf39evXvlEYwpzNG3i8LjH1OBr0XVLKrXm033KyUjV0utO1AmjY/9CclZpkZ6+/iTNeLxSm3bUavoDf9eS607UEUV5oX2amv1atnarHnjj39pd61V2Rqru/eYkTW39JWj4gCz9/nsn6YqH12hLa9D11He/EvFv/JOddfrvNw+UBiy4cLzyMqNn0o4fNVDHjxoY9/+zk82bN09z584Nfe3xeNolgqKxPOA66qijJElffNG+k+/u3bvV3NysUaNGxazfys/PZ2kfOEZqN5YRmXnKaL28cYfWbtmnC+7/m44pGaAJIwp0WGFuaJ+sThqfZqSlyNcS0JjCHC28cLxOHVsYdd+01BTlx1lDctKYwZKkdz7fJ2+LPzRV0hFjjP6vtW7yshM6/4YFdCY45evrJOAKbnenx3dvf/srh+hfu+r02N8/04/+b4NKBmZrUskAGWO0bX+jNn5Ro0/31GvkwCwdPaJAhw7OUUqKS/XeFs1cUqm1n+1TrjtNS68rizv7O354gZ674RRd+/hafbq7Xpc+uEq/u7ZME0YU6Km1W/XQm/8O1buNGZKj/776eI0NC8ikAzM3v//eyfr2I2v06Z56nXbPG1GPdXZpkc49ujiucfV33S1jsjzgmjJliu644w69++677bYFXzvrrLOsHhaQVFJSXLrnmxP1rf9erZ0er974eLfeCKutyEhNiVm0npaaovsuP0b7G5r1jeNGdqnAPZaxQ3M1JDdDe+p82lBVoxMPjf2DZcO2Gn28s1butBRdeEz7B2mArspoDfI7z3AdyNq6u1CQfvv5R2nL3nq9tmmXvrP0HR01LE/vf1Gj6obmdvvmZKRq/PAC1Xpb9NGXHuW507T0OyfquEO6liUqGZStZ2efou8srdS6rdW66tF/KD8zPfTU5IgBWfr+GYfp0uNHdvgLTnFBpn7/vZM0c0mlPtjevt5oSK5bCy8a36VxoessD7hOPfVUTZo0SStWrFBNTU1EL65ly5YpJSVF5eXlVg8LSDqjBufozVvO0IdferTxixq93/qE4+ZddZp8RPRsVbhzjx7W6T5d5XK59JUxg/XiP7/Umk/3dhpwPd2a3TpvwrBOi4KBeASnCOPNcHXll43UFJd+c/kxuvTB1fp4Z63e3nwg6ElPdenI4jwdXpirrfsa9OGXHtX7/Frb2qk+LzNNT3znKzomRhF/LANzMvTkrJN007L1WvnRTu2p82rkwCyVn3F43L8wDc3P1As3fS1UuxYux53WpSch0T2WB1wul0uPP/64Jk+erJkzZ+rxxx9Xfn6+li5dqieffFI//elPdcwxx1g9LCApZaan6rhDBkb81tziDyjNxm+eJ7UGXKv/vTdmcXGDryXUxfpbTCeilwSnCH0tsZvPhqYUO5n2PlheZrqWXneinlizRSMGZGvCiAIdUZwb8Tkt/oD+vbteG7+o0b921+nCScN1VA/bKWRlpOqhq47TE2s+V35mui48ZniXgySXy6UB2Rk9Gge6z5anFI899lhVVlbq9ttv1xFHHKFAIKBRo0Zp6dKluuqqq+wYEuAYdgZbknRyax3Xuq371dTs77Bv0Yv//FJ13haNHpytk8bE30ICiCU4RRh30Xw3ptOLCzJ1yznjOtyelpqiI4vzdGRxXof7dEdaaopm8iR90rKtLcS4ceP07LPP2nV4AAlyWGGOCvPc2l3r1XtV1aFC+oMFu+V/84TYDSqBrmjLcMVZNE9zWliEOw1Ar3K5XKEga82n0Zf5+deuOlVu2a8Ul3Tp8SOtHB4cLsOCDBfQHUl5p5WVlam0tJRFroE+KjhF2NG6is+0ZrfOHDdURfld77UEdMTdOoXt83cccBljQtvJcKG7KioqVFpaqrKysrj2T8pO85WVlfThAvqwYB3X+q3V7eq4mv0BPbvuwDpyFMujt4UyXFGa9QaFZ7/IcKG7ysvLVV5eLo/HE9FxoSPcaQB63aFDcjQ0zy2fP6B1W/dHbHv1o53aU+fTkFy3zhhHR3b0rmAAFSvDFb6NgAtW4U4D0OtcLpdOPqy1jqt1WtEYo2Vrt2ru/22QJH3j+BH0/kGvC04RxqrhCi+oj2dpH6A3cKcBSIiTQ4Xz+7Srtkmzlr6jec+9rwafX185dJC+f9rhNo8QTpQRR8AVXjDPE7KwSlLWcAHo+4JPKq6v2q9z/+tt7av3KSM1Rbecc6S+87VDldKNNSSBzgQbkMZqC0FLCNiBgAtAQowanK1hBZn6sqZJ++p9OmpYvn592SSNK+aBFyROfBmu1nUUCbhgIe42AAnhcrl04THDlZri0uzTDtPy8lMItpBwoaL5GEv7hNZRpH4LFiLDBSBh/uPccbp5ylhlZ/CtBtZwp3XeaT40pdjBslNAIiRleE/jUyA5uFwugi1YqktF82S40AM0PgUA9Ftdy3ARcKH7aHwKAOi34unDFSyaJ8MFK3G3AQAcI562EF4yXLABdxsAwDHaarg6X0uRDBesxN0GAHCMYBAVTw0X6yjCStxtAADHCE4Txly8OtRpnrYQsA4BFwDAMYIZrma/USBgou7jJcMFG3C3AQAcI7yZaUdZLtZShB2S8m6j8SkAIJrwQnhvc/SAK9QWgoALPUDjUwBAv5We6pLLJRkjef1+Sent9qFoHr2BxqcAgH7L5XJ1+qRicKqRonlYiYALAOAona2nGJxqpIYLVuJuAwA4Smfd5tsyXPwIhHW42wAAjtLZeooUzcMO3G0AAEcJBlwdZrhoCwEbcLcBAByls/UUaXwKO3C3AQAcJaOTDFfb4tU8pQjrJGXAReNTAEBHmFKEFWh8CgDo1zptC8GUInpBUjQ+bWho0C233KK0tDQtWLDAjiEAAByq07YQrbVdZLhgJcszXC+99JJuuOEGuVwu+f3RCxoBAOiuYKd5iubRl1gacK1evVqzZ89WRUWFdu/erZkzZ1p5eABAP+BOjz2l2FbDRdE8rGNpeD927Fh98MEHOv/88608LACgH2nLcFHDhb7D0gzXkCFDrDwcAKAf6qwtBE8pwg7cbQAARwkVzftZSxF9R1K2hfB4PBFfu91uud1um0YDAOhLQm0hmtsHXC3+gPwBE7Ef0BVer1derzf09cExSUe6HHAtWrRIPp8v7v1nzJih0aNHd/UwMZWUlER8PX/+fNpLAAAkhTU+jfIkfHjWi6J5dMfixYu1cOHCLr+vWwFXfX193PuffvrpvR5wVVVVRTQ+JbsFAAiKleEKf40MF7pj3rx5mjt3buhrj8fTLhEUTZcDrrq6uq6+pdfl5+fTaR4AEFVbhqt9wBV8LTXFpdQUl6XjgjN0t4yJ8B4A4Cix1lLkCUXYhTsOAOAosdZSDHafZzoRVuOOAwA4Sqy1FL1kuGATy9tCnHzyyfrss8/U2NgoSfrlL3+phx56SGlpadq2bZvVwwEAOExbhqv9U4p0mYddLA+4Vq9ebfUhAQD9SHw1XLSEgLUI8QEAjhK7hqs1w5XKjz9YKynvuLKyMpWWlqqiosLuoQAA+phgMBUrw8WUInqqoqJCpaWlKisri2v/pFzap7Kykj5cAICo3OkHpgujZbhoC4HeUl5ervLycnk8HhUUFHS6P3ccAMBRghku2kKgL+GOAwA4ijs9OKUYZS1FiuZhEwIuAICjxM5wMaUIe3DHAQAcJXwtRWNMxDaK5mEX7jgAgKMEpwuNkVoCBwVcfjJcsAd3HADAUcKzVwdPK3qbKZqHPbjjAACOEh5MHdyLy0uGCzZJyjuOxqcAgI6kpriUluKS1H49RW8zNVzoHTQ+BQD0e+60FLX4/O0yXG01XLSFQM/Q+BQA0O91tJ4iGS7YhTsOAOA4wYCqowwXi1fDatxxAADHCU4ZHpzhCnafD3ajB6zCHQcAcJy2KcWDiuZbyHDBHtxxAADHcXc0pRhc2iedonlYi4ALAOA4HRbNk+GCTbjjAACO03mGix9/sFZS3nE0PgUAxJLRQdF8sKbLTYYLPUTjUwBAvxecMuwow0UfLvQUjU8BAP1ecMrQd9BTiqEpRTrNw2IEXAAAxwlOGXZYNE+GCxbjjgMAOE5bhquDonkCLliMOw4A4DgZZLjQx3DHAQAcJ7SWor8t4DLGtK2lSMAFi3HHAQAcJ1gUHz6lGB58MaUIq3HHAQAcJ9paiuHTi2S4YLWkvONofAoAiMUdZWmf8GwXS/ugp2h8CgDo96KtpRheMO9yuWwZF5yjTzc+Xb9+vW688UYdccQRGjx4sPLz83XsscfqP//zP+X1eq0cCgDAwaLWcNESAjay7K5bt26djjvuOFVWVmr58uXau3evdu3apauvvlr/8R//oTPPPFM+n8+q4QAAHCx6hqt1HUUCLtjAsrsuEDhw0z/11FMqLS2VJGVmZmru3Lm69NJLtWrVKj322GNWDQcA4GChthBhRfOhdRSp34INLLvrhg8frkWLFumwww5rt+3UU0+VJK1atcqq4QAAHMyd1r7TfGhKMZ11FGE9SwOuefPmRd0WnEocPHiwVcMBADhYzKJ5MlywQZ+464KZrSuuuMLmkQAAnCB2hqtP/OhDP2N7W4iPP/5YL7zwgq655hqdeOKJcb3H4/FEfO12u+V2uxMxPABAEorWhytYNE+GCz3h9XojOiscHJN0pMsB16JFi7r0NOGMGTM0evToqNuampp0zTXX6Oijj+5SE9OSkpKIr+fPn68FCxbE/X4AgLNlpLZvC8HC1egNixcv1sKFC7v8vm4FXPX19XHvf/rpp0cNuFpaWvStb31LHo9Hb731lnJzc+P+zKqqqojGp2S3AADhgtOG4esn0ocLvWHevHmaO3du6GuPx9MuERRNlwOuurq6rr6lHZ/Pp8suu0yfffaZ3njjDRUWFnbp/fn5+XSaBwB0KDht6G1uv5YiGS70RHfLmCy/67xer6ZPn66tW7fqjTfeUFFRkSSptrZW77//vtXDAQA4UOwMF20hYD1LA67GxkZdcMEF2rdvn1577bWINhDvvvuuLrjgAiuHAwBwqGCGq9lvFAgYSWS4YC/LnlKsq6vTtGnTtGrVKv3gBz/Qr3/964jtW7ZssWooAACHC29u6vMHlJmSSg0XbGVZwLVy5Uq9+eabkqR777036j6jRo2yajgAAAcLb/3gbQ4oMz21rS0EARdsYFnAdfHFF8sYY9XhAAD9WHqqK/R3r98vKb1tLUUCLtiAuw4A4Dgul6tdt/lgAT1F87BDUgZcZWVlKi0t7VKzVABA/3LweoreZmq40HsqKipUWlqqsrKyuPa3fWmf7qisrKQPFwAgJndaqmrVEiXDRcCFnisvL1d5ebk8Ho8KCgo63Z+7DgDgSAevp0jRPOzEXQcAcKR2NVy0hYCNuOsAAI6UcVDAReNT2Im7DgDgSG1F8/7W/7YGXKk8pQjrEXABAByJKUX0Jdx1AABHatcWgilF2Ii7DgDgSMEGp20ZLn/r6/zog/WS8q6j8SkAoDPB9RTb1XARcKEX0PgUAAC1n1JkLUX0JhqfAgCgsKJ5P2spwn4EXAAARwpluJpZSxH2464DADhSqGi+XYaLH32wHncdAMCRwjNcLf6A/AET8TpgJe46AIAjtdVw+UPZrQOvU8MF6xFwAQAcKTzDFazfCn8dsBJ3HQDAkcKfUgxmuFJTXEpNcdk5LPRTSRlw0fgUANCZ8LUUWUcRvY3GpwAAKLLxabDbPNOJ6C00PgUAQJFrKXrJcMFm3HkAAEdqy3D5WUcRtuPOAwA4UnDx6vAaruBrgNW48wAAjuROb6vhaiuapwcX7EHABQBwpPAMF1OKsBt3HgDAkdzpB7JZXtpCoA/gzgMAOFIww0VbCPQFSXnn0fgUANCZYA2Xr8VPDRd6HY1PAQDQwRkuphTRu/p049N169bppz/9qU455RQdcsghKiws1GGHHaZrrrlGH3zwgZVDAQA4XMRaihTNw2aW3nm33Xab7rnnHn3/+9/Xp59+qt27d+uPf/yj3nnnHZ1wwgmqrKy0cjgAAAcLTh8aI9X7WlpfI+CCPSy/82bPnq2rrrpKaWkHZjMnTpyoe+65R01NTbrvvvusHg4AwKHCs1m1TS3tXgOsZGkN17333qshQ4a0e33UqFGSpJqaGiuHAwBwsMiAq1kSGS7Yx9KAa/z48VFfX7t2rSTp9NNPt3A0AAAnS01xKS3FpZaAIcMF29n6lGJNTY1eeOEF/fjHP9bll1+um266yc7hAAAcJiMtRS0+v+q8rQFXKm0hYA/bAq7Ro0dr69atSk9P1y233KKf/OQnSk9Pj+u9Ho8n4mu32y23252IYQIAkpg7LUUNPr88rRmuYG8uoLu8Xq+8Xm/o64Njko50OeBatGiRfD5f3PvPmDFDo0ePbvf6li1b1NjYqLVr12rOnDlasmSJnn76aX31q1/t9DNLSkoivp4/f74WLFgQ95gAAP1DcAoxWMMV7M0FdNfixYu1cOHCLr/PZYwxXXlDbm6u6uvr497/9ddf77Q2q6qqSuPGjdOAAQO0adMm5eXlRd0v2FysqqoqovEpGS4AQDST735dW/c1qDDPrd21Xv3ikqN15VdG2T0sJLFoGa6SkhLV1NTEbMre5QxXXV1d90YYQ0lJiSZNmqTVq1dr7dq1mjJlSsz98/Pz6TQPAOgUGS70tu4meSy786qrq7VgwQI1NzdH3Z6dnS1J2rt3r1VDAgA4XLANRFNz69I+6RTNwx6WBlwLFy7UO++8027b/v379e6778rlcsW9CCQAAJ05uA0EGS7YxfI7b+bMmfrb3/6mQODAbxsfffSRpk+frurqas2bN0+HHnqo1UMCADjUwQEWjU9hF8vaQpSUlGjFihV65plndP3112vPnj3y+XzKzMzUCSecoOeff14XXHCBVcMBAPQDB08hEnDBLpYFXKmpqZo6daqmTp1q1SEBAP3cwRkuOs3DLtx5AADHOrjRqTuNonnYIykDrrKyMpWWlqqiosLuoQAA+jA3GS4kSEVFhUpLS+N+2M/WtRS7q7Kykj5cAIBOtc9wEXChd5SXl6u8vDzUlL0z3HkAAMeihgt9BXceAMCx2vXhIuCCTbjzAACOdXCRPFOKsAt3HgDAschwoa/gzgMAONbBGS2W9oFduPMAAI4VntHKSEuRy+WycTTozwi4AACOFR5wHdyTC7BSUt59ND4FAMQjvGj+4J5cQE/Q+BQAgFYRU4pkuNCLaHwKAECr8KJ5dzrrKMI+BFwAAMciw4W+grsPAOBYkRkufuTBPtx9AADHcpPhQh/B3QcAcKyM1La6LbrMw07cfQAAxwqfRmQdRdiJuw8A4Fjh04hkuGCnpLz7aHwKAIhHZIaLthDoPTQ+BQCgFRkuJAqNTwEAaHXw4tWAXbj7AACOFbGWIgEXbMTdBwBwrPRUV+jvZLhgJ+4+AIBjuVyuUGaLonnYiYALAOBoGaGAix95sA93HwDA0YKZLQIu2Im7DwDgaMFAixou2Ckp7z4anwIA4hUMtFi8Gr2JxqcAAIQJFc2nE3Ch9yRV49N//OMfSktLk8vl6nxnAAC6oS3DxVOKsI9tAVdDQ4OuueYa+f1+u4YAAOgHSoflKzXFpbFFuXYPBf2YbVOKt956q4YNG6ampiZt3brVrmEAABxu0SUT9JNzx2lgTobdQ0E/ZkuGa+XKlXriiSe0ZMkSphMBAAmVkuIi2ILtLA+4qqurNXPmTN17770aPXq01YcHAACwnOUB14033qhJkyZp1qxZVh8aAADAFpbWcD377LN66aWXtHHjxh59jsfjifja7XbL7Xb36DMBAAA64/V65fV6Q18fHJN0pMsB16JFi+Tz+eLef8aMGRo9erR27typ2bNn64EHHlBxcXFXDxuhpKQk4uv58+drwYIFPfpMAACAzixevFgLFy7s8vtcxhjTlTfk5uaqvr4+7v1ff/11nX766brwwguVk5OjZcuWRWwfPXq0Pv/8c8UzjGBzsaqqqojGp2S4AACAFaJluEpKSlRTUxOzKXuXM1x1dXVdHlxNTY1ee+01ZWVltctu7d69W5JCr5955pl66qmnYn5efn4+neYBAIDlupvksaRovqCgQHV1ddq9e7d27NgR8Sc4PRj8urNgK9G8Xq8WLFgQEb3CXlyTvodr0vdwTfomrkvfY9c16fKUYm/rzpRiZ2m7nrDiGOgarknfwzXpe7gmfRPXpe/p7WsS7+exkqdNKioqHHEMK4+TaE46X065JpJzzhfXpH8ewypOOl9Oui4RjA02b95sioqKTFFRkUlJSTGSQl+/9tprHb6vpqbGSDI1NTUJG5sVxzDGmKOOOiqhn2/VMaw4jpOuiVXHcco1McYZ58uKY3BN+uYxnPT9yynfI3v7msT7ebaspXj44Ydrx44dXX6faZ12jLfnRXcEPzuRx5Akv9/viGNYcRwnXROrjuOUayI543xZcQyuSd88hpO+fznle2RvX5Pg55hOSqNsr+Hqim3btrXrwQUAAGC3qqoqjRw5ssPtSRVwBQIBbd++XXl5eSx6DQAAbGeMUW1trYYPH66UlI5L45Mq4AIAAEhGPKUIAACQYARcAAAACUbA1WrTpk269NJLVVxcrKFDh6qsrExPPvmk3cNyNK/Xq6efflrTpk1TcXGxBg8erMLCQp1//vlauXJl1Pc0NTVp/vz5Gjt2rIYOHapRo0Zpzpw5qqmpsXj0/ceNN94ol8ulGTNmRN3ONbGG3+/XAw88oJNPPlmHHHKIBgwYoMMOO0yXX365NmzYELEv18Qafr9fS5cu1cknn6zhw4erqKhIEydO1C9+8Yuoy+BxXXrfxo0bdcopp8jlcmnLli0d7tedc79ixQpNnjxZQ4cOVVFRkaZOnaq1a9d2f7C90oQiya1bt87k5eWZiy++2Ozfv98EAgHz+OOPm5SUFDN//ny7h+dYN910k5Fk5s2bZzwejzHGmM8//9x8/etfN5LMb3/724j9fT6fOeOMM8zQoUPN2rVrjTHGfPLJJ2bs2LFmwoQJlvQf6m9eeeUV43K5jCRz7bXXttvONbFGY2OjOeuss8zJJ59sNm7caIwxprm52fzyl780kszjjz8e2pdrYp1Zs2YZSeaOO+4wXq/XBAIB88ILL5isrCxz7LHHGq/XG9qX69K7GhsbzW233WYGDRpkhgwZYiSZzz77LOq+3Tn3jzzyiJFk7rzzTtPc3GwaGhrMDTfcYNLT081f//rXbo253wdcgUDATJo0yeTl5Znq6uqIbVdffbVJSUkx69evt2dwDldeXm5OPfXUdq/v3r3bZGVlGbfbbfbv3x96/d577zWSzGOPPRax/6uvvmokmR/+8IeJHnK/sn//fjNy5Ehz9dVXdxhwcU2scfPNN5vBgwdH/HsImj59uvnzn/8c+pprYo1t27YZSeaYY45pt23OnDlGklm2bFnoNa5L77r++uvNRRddZKqqqsxpp50WM+Dq6rnftm2bycrKMpMnT454vbm52YwZM8aMGDHCNDQ0dHnM/T7gevPNN40kc9lll7XbtmLFCiPJzJo1y4aROd+f//xn89JLL0XdduyxxxpJ5tVXXw29NmbMGJOammpqa2sj9g0EAqaoqMjk5eWZxsbGhI65P7nyyivNtGnTzOuvv95hwMU1SbydO3eatLQ0c/PNN8e1P9fEGmvWrDGSzLe+9a122yoqKowkc9ddd4Ve47r0ri1btoT+3lnA1dVzv3DhQiPJPPjgg+0+69ZbbzWSzP/+7/92ecz9vobr1VdflSQdf/zx7bYFX3vllVcsHVN/MW3aNJ1zzjlRt/l8PknS4MGDJUmfffaZPv30Ux155JHKzc2N2Nflcum4445TbW2t1qxZk9hB9xPPPvusXn75ZT3yyCMd7sM1scby5cvV0tKik046qdN9uSbWOeKII5SZmamPPvqo3bbgaxMmTJDEdUmEUaNGxbVfd859ouKCfh9wBf9hjBgxot22wsJCpaen6/PPP1djY6PVQ+u39uzZo82bN6u0tFQTJ06UFPs6hb++adMmawbpYDt37tTs2bP14IMPqri4uMP9uCbWePfddyVJBQUF+tnPfqbx48ersLBQY8eO1ezZs7V169bQvlwT6wwcOFC//e1vtWnTJt12223yeDzy+Xx65pln9Mgjj+iKK67QeeedJ4nrYqfunPtY7+nJter3AVd1dbUkKScnp902l8ul7OzsiP2QePfdd59aWlp03333hVYUiHWdwl/fv3+/JWN0slmzZunss8/WpZdeGnM/rok1tm/fLkm69tprtXXrVq1cuVLbt29XRUWFli9fruOOO04ff/yxJK6J1WbNmqU//OEP+v3vf6+CggLl5ubqu9/9rhYtWqSnnnoqtB/XxT7dOfex3tOTa9XvAy70LWvWrNFdd92lO+64Q1OmTLF7OP3Oo48+qnXr1un++++3eyhoFcyu5+bm6ne/+52GDRum9PR0nX322frVr36lvXv3as6cOfYOsh8yxuj666/XJZdcotmzZ2v//v2qra3VU089pXvuuUfnnXcev6gjQr8PuAYMGCBJqq+vb7fNGKOGhoaI/ZA4H374oaZNm6Yf/OAHuv322yO2xbpO4a8PHDgwoWN0si1btmju3Ll69NFH4zqPXBNrBH+jnjJlitLS0iK2XXjhhZKklStXqqmpiWtioSVLlujhhx/WVVddpVtvvVUDBgyQ2+3Weeedp9/85jf6y1/+EgqEuS726c65j/Wenlyrfh9wHXXUUZKkL774ot223bt3q7m5WaNGjVJWVpbVQ+tXNm7cqDPPPFPXXXedfvnLX7bbHus6hb8+bty4xA3S4VasWKFAIKAZM2aouLg49Gf69OmSpKeffjr02p/+9CeuiUVGjx4tSRoyZEi7bbm5ucrJyVFLS4v27dvHNbHQSy+9JElRM/HB1/74xz9K4vuXnbpz7mO9pyfXqt8HXMF/GMHC1HDB18466yxLx9TfrF+/XmeccYZmz56tu+++O/T6li1bQvUrhx56qMaMGaNPPvmkXQdnY4zWr1+vvLy8uJ7kQnTf//73VVtbqx07dkT8ee655yRJl112Wei1iy66iGtikcmTJ0uSduzY0W5bQ0OD6uvrlZaWpkGDBnFNLBQ8v8E603DB1+rq6uT3+7kuNurOuU9UXNDvA65TTz1VkyZN0ooVK9q1+F+2bJlSUlJUXl5u0+icr7KyUlOmTNEtt9yiBQsWRGxbsGCBHn744dDX5eXlamlp0TPPPBOx3+uvv64dO3Zo1qxZyszMtGLYaMU1Sbzzzz9fI0eO1CuvvBJqlxL0l7/8RZI0derU0Hnmmlgj+AP6zTffbLftrbfekiSdcMIJSk1NlcR1sVNXz/11112nrKwsLVu2LGL/lpYW/eEPf9CIESN0ySWXdH0gXe7c5UDr1q0zubm55pJLLjHV1dURS/v87Gc/s3t4jvX3v//d5Ofnm3Hjxpn58+e3+zNp0qSIpZV8Pp85/fTT2y3PcMQRR7A0RgLFanzKNbHGX//6V5ORkWGuuuoqs3fvXhMIBMyqVavMyJEjzbBhw8ynn34a2pdrYo39+/ebI4880qSmppqHHnrINDU1mUAgYN5++21zyCGHGLfbbd58883Q/lyXxOms8Wl3zv3DDz9sJJlf/OIXpqWlxTQ2NpobbrjBpKWlmZdffrlb4yTgavXRRx+Z6dOnm6FDh5ohQ4aY448/3jzxxBN2D8vRLrroIiMp5p+D17JsbGw0P/vZz8yYMWNMYWGhKSkpMTfffHO7ZZnQc3feeacpKioyAwcONJJMZmamKSoqMhMmTIjYj2tijXfeecdceOGFZtCgQWbAgAHm0EMPNTfddJPZsWNHu325Jtaorq42t912mxk/frzJy8szBQUFZuTIkebKK680GzZsaLc/16X3/OMf/zBFRUWmqKjIpKenG0lmyJAhpqioyMydO7fd/t059y+++KL52te+ZoYMGWIKCwvNOeecY9asWdPtMbuMMabreTEAAADEq9/XcAEAACQaARcAAECCEXABAAAkGAEXAABAghFwAQAAJBgBFwAAQIIRcAEAACQYARcAAECCEXABAAAkGAEXAABAghFwAQAAJBgBFwAAQIIRcAEAACTY/wepk56DPKdmMQAAAABJRU5ErkJggg==", + "text/plain": [ + "
" + ] + }, + "metadata": {}, + "output_type": "display_data" + } + ], + "source": [ + "plt.plot(g-data)" + ] + }, + { + "cell_type": "code", + "execution_count": null, + "metadata": {}, + "outputs": [], + "source": [] + } + ], + "metadata": { + "kernelspec": { + "display_name": "oblate", + "language": "python", + "name": "python3" + }, + "language_info": { + "codemirror_mode": { + "name": "ipython", + "version": 3 + }, + "file_extension": ".py", + "mimetype": "text/x-python", + "name": "python", + "nbconvert_exporter": "python", + "pygments_lexer": "ipython3", + "version": "3.12.7" + } + }, + "nbformat": 4, + "nbformat_minor": 2 +} diff --git a/fortran_implementation/times.txt b/fortran_implementation/times.txt new file mode 100644 index 0000000..5e6adfa --- /dev/null +++ b/fortran_implementation/times.txt @@ -0,0 +1,100 @@ +-1.0 +-0.9797979797979799 +-0.9595959595959596 +-0.9393939393939394 +-0.9191919191919191 +-0.898989898989899 +-0.8787878787878787 +-0.8585858585858586 +-0.8383838383838385 +-0.8181818181818181 +-0.797979797979798 +-0.7777777777777777 +-0.7575757575757576 +-0.7373737373737375 +-0.7171717171717171 +-0.696969696969697 +-0.6767676767676767 +-0.6565656565656566 +-0.6363636363636362 +-0.6161616161616161 +-0.595959595959596 +-0.5757575757575757 +-0.5555555555555556 +-0.5353535353535352 +-0.5151515151515151 +-0.49494949494949486 +-0.4747474747474747 +-0.45454545454545453 +-0.43434343434343425 +-0.41414141414141414 +-0.39393939393939387 +-0.3737373737373737 +-0.3535353535353534 +-0.33333333333333326 +-0.3131313131313131 +-0.2929292929292928 +-0.2727272727272727 +-0.25252525252525243 +-0.23232323232323226 +-0.2121212121212121 +-0.19191919191919182 +-0.17171717171717166 +-0.15151515151515144 +-0.13131313131313127 +-0.111111111111111 +-0.09090909090909083 +-0.07070707070707066 +-0.050505050505050386 +-0.030303030303030276 +-0.01010101010101 +0.010101010101010166 +0.030303030303030443 +0.05050505050505061 +0.07070707070707077 +0.09090909090909105 +0.11111111111111116 +0.13131313131313144 +0.1515151515151516 +0.17171717171717177 +0.19191919191919204 +0.2121212121212122 +0.23232323232323243 +0.2525252525252526 +0.2727272727272729 +0.29292929292929304 +0.3131313131313132 +0.3333333333333335 +0.35353535353535365 +0.37373737373737387 +0.39393939393939403 +0.4141414141414143 +0.4343434343434345 +0.45454545454545464 +0.4747474747474749 +0.49494949494949503 +0.5151515151515154 +0.5353535353535355 +0.5555555555555556 +0.5757575757575759 +0.595959595959596 +0.6161616161616164 +0.6363636363636365 +0.6565656565656568 +0.6767676767676769 +0.696969696969697 +0.7171717171717173 +0.7373737373737375 +0.7575757575757578 +0.7777777777777779 +0.7979797979797982 +0.8181818181818183 +0.8383838383838385 +0.8585858585858588 +0.8787878787878789 +0.8989898989898992 +0.9191919191919193 +0.9393939393939394 +0.9595959595959598 +0.9797979797979799 +1.0 diff --git a/squishyplanet/oblate_system.py b/squishyplanet/oblate_system.py index 4f3838a..fa149cd 100644 --- a/squishyplanet/oblate_system.py +++ b/squishyplanet/oblate_system.py @@ -652,16 +652,15 @@ def _illustrate_helper(self, times=None, true_anomalies=None, nsamples=50_000): raise ValueError("Provide either times or true anomalies but not both") if times is not None: - t_peri = self._state.get( - "t_peri", - t0_to_t_peri( - e=self._state["ecc"], - i=self._state["inc"], + t_peri = self._state.get("t_peri", None) + if t_peri is None: + t_peri = t0_to_t_peri( + e=self._state["e"], + i=self._state["i"], omega=self._state["omega"], period=self._state["period"], t0=self._state["t0"], - ), - ) + ) time_deltas = times - t_peri mean_anomalies = 2 * jnp.pi * time_deltas / self._state["period"] true_anomalies = kepler(mean_anomalies, self._state["e"])