Analysis

Category Package Started Completed Duration Log
FILE xls 2019-10-10 00:07:20 2019-10-10 00:11:51 271 seconds Show Log
2019-10-10 01:07:24,030 [root] INFO: Date set to: 10-10-19, time set to: 00:07:24, timeout set to: 200
2019-10-10 01:07:24,279 [root] DEBUG: Starting analyzer from: C:\ykjcugc
2019-10-10 01:07:24,279 [root] DEBUG: Storing results at: C:\jLeAZUIJLm
2019-10-10 01:07:24,279 [root] DEBUG: Pipe server name: \\.\PIPE\BsuWbP
2019-10-10 01:07:24,279 [root] DEBUG: No analysis package specified, trying to detect it automagically.
2019-10-10 01:07:24,296 [root] INFO: Automatically selected analysis package "xls"
2019-10-10 01:07:32,017 [root] DEBUG: Started auxiliary module Browser
2019-10-10 01:07:32,017 [root] DEBUG: Started auxiliary module Curtain
2019-10-10 01:07:32,017 [modules.auxiliary.digisig] DEBUG: Checking for a digitial signature.
2019-10-10 01:07:42,844 [modules.auxiliary.digisig] DEBUG: File format not recognized.
2019-10-10 01:07:42,844 [modules.auxiliary.digisig] INFO: Uploading signature results to aux/DigiSig.json
2019-10-10 01:07:42,844 [root] DEBUG: Started auxiliary module DigiSig
2019-10-10 01:07:42,844 [root] DEBUG: Started auxiliary module Disguise
2019-10-10 01:07:42,844 [root] DEBUG: Started auxiliary module Human
2019-10-10 01:07:42,844 [root] DEBUG: Started auxiliary module Screenshots
2019-10-10 01:07:42,859 [root] DEBUG: Started auxiliary module Sysmon
2019-10-10 01:07:42,859 [root] DEBUG: Started auxiliary module Usage
2019-10-10 01:07:42,859 [root] INFO: Analyzer: Package modules.packages.xls does not specify a DLL option
2019-10-10 01:07:42,859 [root] INFO: Analyzer: Package modules.packages.xls does not specify a DLL_64 option
2019-10-10 01:07:50,971 [lib.api.process] INFO: Successfully executed process from path "C:\Program Files (x86)\Microsoft Office\Office14\EXCEL.EXE" with arguments ""C:\Users\user\AppData\Local\Temp\tmpczia736j.xls" /e" with pid 1828
2019-10-10 01:07:50,971 [lib.api.process] INFO: 32-bit DLL to inject is C:\ykjcugc\dll\iMGmIbL.dll, loader C:\ykjcugc\bin\JIGldtK.exe
2019-10-10 01:07:51,190 [root] DEBUG: ReadConfig: Successfully loaded pipe name \\.\PIPE\BsuWbP.
2019-10-10 01:07:51,206 [root] DEBUG: Loader: Injecting process 1828 (thread 456) with C:\ykjcugc\dll\iMGmIbL.dll.
2019-10-10 01:07:51,206 [root] DEBUG: Process image base: 0x2FB80000
2019-10-10 01:07:51,206 [root] DEBUG: InjectDllViaIAT: IAT patching with dll name C:\ykjcugc\dll\iMGmIbL.dll.
2019-10-10 01:07:51,206 [root] DEBUG: InjectDllViaIAT: Found a free region from 0x30F51000 - 0x77380000
2019-10-10 01:07:51,206 [root] DEBUG: InjectDllViaIAT: Allocated 0x200 bytes for new import table at 0x30F60000.
2019-10-10 01:07:51,206 [root] DEBUG: InjectDllViaIAT: Successfully patched IAT.
2019-10-10 01:07:51,206 [root] DEBUG: Successfully injected DLL C:\ykjcugc\dll\iMGmIbL.dll.
2019-10-10 01:07:51,206 [lib.api.process] INFO: Injected into suspended 32-bit process with pid 1828
2019-10-10 01:07:53,217 [lib.api.process] INFO: Successfully resumed process with pid 1828
2019-10-10 01:07:53,217 [root] INFO: Added new process to list with pid: 1828
2019-10-10 01:07:57,227 [root] DEBUG: Terminate processes on terminate_event enabled.
2019-10-10 01:07:57,539 [root] DEBUG: RestoreHeaders: Restored original import table.
2019-10-10 01:07:57,539 [root] INFO: Disabling sleep skipping.
2019-10-10 01:07:57,539 [root] INFO: Disabling sleep skipping.
2019-10-10 01:07:57,539 [root] INFO: Disabling sleep skipping.
2019-10-10 01:07:57,539 [root] INFO: Disabling sleep skipping.
2019-10-10 01:07:57,539 [root] DEBUG: CAPE initialised: 32-bit base package loaded in process 1828 at 0x74af0000, image base 0x2fb80000, stack from 0x356000-0x360000
2019-10-10 01:07:57,539 [root] DEBUG: Commandline: C:\Users\user\AppData\Local\Temp\"C:\Program Files (x86)\Microsoft Office\Office14\EXCEL.EXE" "C:\Users\user\AppData\Local\Temp\tmpczia736j.xls" \e.
2019-10-10 01:07:57,539 [root] INFO: Monitor successfully loaded in process with pid 1828.
2019-10-10 01:07:57,976 [root] DEBUG: DLL unloaded from 0x74CB0000.
2019-10-10 01:07:59,598 [root] DEBUG: DLL loaded at 0x716D0000: C:\Program Files (x86)\Common Files\Microsoft Shared\office14\mso (0x11e4000 bytes).
2019-10-10 01:08:00,019 [root] DEBUG: DLL loaded at 0x74440000: C:\Windows\system32\msi (0x240000 bytes).
2019-10-10 01:08:00,285 [root] DEBUG: DLL loaded at 0x74CB0000: C:\Windows\system32\apphelp (0x4c000 bytes).
2019-10-10 01:08:28,006 [root] DEBUG: DLL loaded at 0x742A0000: C:\Windows\WinSxS\x86_microsoft.windows.common-controls_6595b64144ccf1df_6.0.7601.17514_none_41e6975e2bd6f2b2\Comctl32 (0x19e000 bytes).
2019-10-10 01:08:28,194 [root] DEBUG: DLL loaded at 0x73E90000: C:\Program Files (x86)\Common Files\Microsoft Shared\office14\Cultures\office.odf (0x40f000 bytes).
2019-10-10 01:08:29,052 [root] DEBUG: DLL loaded at 0x75670000: C:\Windows\syswow64\CLBCatQ (0x83000 bytes).
2019-10-10 01:08:29,082 [root] DEBUG: DLL loaded at 0x73E80000: C:\Windows\system32\msimtf (0xb000 bytes).
2019-10-10 01:08:29,082 [root] DEBUG: DLL loaded at 0x73E70000: C:\Windows\system32\VERSION (0x9000 bytes).
2019-10-10 01:08:29,239 [root] DEBUG: DLL loaded at 0x71580000: C:\Program Files (x86)\Common Files\Microsoft Shared\office14\riched20 (0x14f000 bytes).
2019-10-10 01:08:29,286 [root] DEBUG: DLL loaded at 0x6D050000: C:\Program Files (x86)\Common Files\Microsoft Shared\office14\MSORES (0x452a000 bytes).
2019-10-10 01:08:29,316 [root] DEBUG: DLL loaded at 0x6CDE0000: C:\Program Files (x86)\Common Files\Microsoft Shared\office14\1033\MSOINTL (0x262000 bytes).
2019-10-10 01:08:29,410 [root] DEBUG: DLL loaded at 0x6CC50000: C:\Windows\WinSxS\x86_microsoft.windows.gdiplus_6595b64144ccf1df_1.1.7601.17514_none_72d18a4386696c80\GdiPlus (0x190000 bytes).
2019-10-10 01:08:29,457 [root] DEBUG: DLL unloaded from 0x77050000.
2019-10-10 01:08:29,612 [root] INFO: Announced 32-bit process name:  pid: 119864063
2019-10-10 01:08:29,612 [lib.api.process] WARNING: The process with pid 119864063 is not alive, injection aborted
2019-10-10 01:08:29,612 [root] DEBUG: DLL loaded at 0x73E20000: C:\Windows\system32\mscoree (0x4a000 bytes).
2019-10-10 01:08:29,612 [root] DEBUG: set_caller_info: Adding region at 0x00260000 to caller regions list (advapi32::RegQueryInfoKeyW).
2019-10-10 01:08:29,612 [root] DEBUG: set_caller_info: Adding region at 0x00460000 to caller regions list (kernel32::FindFirstFileExW).
2019-10-10 01:08:29,612 [root] DEBUG: DLL loaded at 0x73DA0000: C:\Windows\Microsoft.NET\Framework\v4.0.30319\mscoreei (0x7b000 bytes).
2019-10-10 01:08:29,894 [root] DEBUG: DLL loaded at 0x73D80000: C:\Program Files (x86)\Common Files\Microsoft Shared\OfficeSoftwareProtectionPlatform\OSPPC (0x20000 bytes).
2019-10-10 01:08:30,174 [root] DEBUG: DLL loaded at 0x6CBD0000: C:\Windows\system32\UxTheme (0x80000 bytes).
2019-10-10 01:08:30,579 [root] DEBUG: DLL loaded at 0x73D60000: C:\Windows\system32\DwmApi (0x13000 bytes).
2019-10-10 01:08:30,611 [root] DEBUG: DLL unloaded from 0x75700000.
2019-10-10 01:08:30,611 [root] DEBUG: DLL loaded at 0x73D30000: C:\Windows\system32\POWRPROF (0x25000 bytes).
2019-10-10 01:08:30,642 [root] DEBUG: DLL loaded at 0x758B0000: C:\Windows\syswow64\SETUPAPI (0x19d000 bytes).
2019-10-10 01:08:30,642 [root] DEBUG: DLL loaded at 0x76A40000: C:\Windows\syswow64\CFGMGR32 (0x27000 bytes).
2019-10-10 01:08:30,642 [root] DEBUG: DLL loaded at 0x76770000: C:\Windows\syswow64\DEVOBJ (0x12000 bytes).
2019-10-10 01:08:30,642 [root] DEBUG: DLL unloaded from 0x73D30000.
2019-10-10 01:08:31,562 [root] DEBUG: DLL loaded at 0x74F80000: C:\Windows\system32\CRYPTSP (0x16000 bytes).
2019-10-10 01:08:31,562 [root] DEBUG: DLL loaded at 0x74F40000: C:\Windows\system32\rsaenh (0x3b000 bytes).
2019-10-10 01:08:31,578 [root] DEBUG: DLL loaded at 0x73D50000: C:\Windows\system32\RpcRtRemote (0xe000 bytes).
2019-10-10 01:08:32,280 [root] DEBUG: DLL loaded at 0x75B20000: C:\Windows\syswow64\SHELL32 (0xc4a000 bytes).
2019-10-10 01:08:32,296 [root] DEBUG: DLL unloaded from 0x2FB80000.
2019-10-10 01:08:32,312 [root] DEBUG: DLL loaded at 0x758B0000: C:\Windows\syswow64\SETUPAPI (0x19d000 bytes).
2019-10-10 01:08:32,312 [root] DEBUG: DLL loaded at 0x76A40000: C:\Windows\syswow64\CFGMGR32 (0x27000 bytes).
2019-10-10 01:08:32,312 [root] DEBUG: DLL loaded at 0x76770000: C:\Windows\syswow64\DEVOBJ (0x12000 bytes).
2019-10-10 01:08:32,328 [root] DEBUG: DLL loaded at 0x6CAD0000: C:\Windows\system32\propsys (0xf5000 bytes).
2019-10-10 01:08:32,328 [root] DEBUG: DLL unloaded from 0x75B20000.
2019-10-10 01:08:32,342 [root] DEBUG: DLL loaded at 0x74BB0000: C:\Windows\system32\ntmarta (0x21000 bytes).
2019-10-10 01:08:32,342 [root] DEBUG: DLL loaded at 0x75860000: C:\Windows\syswow64\WLDAP32 (0x45000 bytes).
2019-10-10 01:08:32,467 [root] DEBUG: DLL loaded at 0x73D40000: C:\Windows\system32\profapi (0xb000 bytes).
2019-10-10 01:08:32,499 [root] DEBUG: DLL loaded at 0x75530000: C:\Windows\SysWOW64\urlmon (0x136000 bytes).
2019-10-10 01:08:32,546 [root] DEBUG: DLL loaded at 0x75370000: C:\Windows\syswow64\WININET (0xf5000 bytes).
2019-10-10 01:08:32,562 [root] DEBUG: DLL loaded at 0x76BD0000: C:\Windows\syswow64\iertutil (0x1fb000 bytes).
2019-10-10 01:08:32,576 [root] DEBUG: DLL loaded at 0x76790000: C:\Windows\syswow64\CRYPT32 (0x11d000 bytes).
2019-10-10 01:08:32,576 [root] DEBUG: DLL loaded at 0x768B0000: C:\Windows\syswow64\MSASN1 (0xc000 bytes).
2019-10-10 01:08:32,842 [root] DEBUG: DLL loaded at 0x6CAB0000: C:\Windows\system32\MPR (0x12000 bytes).
2019-10-10 01:08:33,170 [root] DEBUG: DLL unloaded from 0x77050000.
2019-10-10 01:08:33,325 [root] DEBUG: DLL loaded at 0x6C770000: C:\Program Files (x86)\Microsoft Office\Office14\GKExcel (0x338000 bytes).
2019-10-10 01:08:34,885 [root] DEBUG: DLL unloaded from 0x6C770000.
2019-10-10 01:08:35,915 [root] DEBUG: DLL loaded at 0x6CA50000: C:\Windows\system32\SXS (0x5f000 bytes).
2019-10-10 01:08:35,961 [root] DEBUG: DLL loaded at 0x6C7C0000: C:\PROGRA~2\COMMON~1\MICROS~1\VBA\VBA7\VBE7 (0x28d000 bytes).
2019-10-10 01:08:36,025 [root] DEBUG: set_caller_info: Adding region at 0x01DA0000 to caller regions list (ntdll::memcpy).
2019-10-10 01:08:36,072 [root] DEBUG: DLL loaded at 0x65300000: C:\PROGRA~2\COMMON~1\MICROS~1\VBA\VBA7\1033\VBE7INTL (0x26000 bytes).
2019-10-10 01:08:36,072 [root] DEBUG: set_caller_info: Adding region at 0x06BD0000 to caller regions list (ntdll::memcpy).
2019-10-10 01:08:36,164 [root] DEBUG: set_caller_info: Adding region at 0x05D30000 to caller regions list (ntdll::LdrGetProcedureAddress).
2019-10-10 01:08:36,196 [root] DEBUG: set_caller_info: Adding region at 0x00010000 to caller regions list (advapi32::RegOpenKeyExW).
2019-10-10 01:08:36,196 [root] DEBUG: set_caller_info: Adding region at 0x00360000 to caller regions list (advapi32::RegCloseKey).
2019-10-10 01:08:36,243 [root] DEBUG: set_caller_info: Adding region at 0x05970000 to caller regions list (ntdll::memcpy).
2019-10-10 01:08:36,259 [root] DEBUG: set_caller_info: Adding region at 0x00630000 to caller regions list (ntdll::memcpy).
2019-10-10 01:08:36,336 [root] DEBUG: set_caller_info: Adding region at 0x00090000 to caller regions list (msvcrt::memcpy).
2019-10-10 01:08:36,336 [root] DEBUG: set_caller_info: Adding region at 0x00210000 to caller regions list (msvcrt::memcpy).
2019-10-10 01:08:36,336 [root] DEBUG: set_caller_info: Adding region at 0x00110000 to caller regions list (msvcrt::memcpy).
2019-10-10 01:08:36,336 [root] DEBUG: set_caller_info: Adding region at 0x074A0000 to caller regions list (ntdll::memcpy).
2019-10-10 01:08:36,351 [root] DEBUG: set_caller_info: Adding region at 0x05A20000 to caller regions list (ntdll::memcpy).
2019-10-10 01:08:36,398 [root] DEBUG: set_caller_info: Adding region at 0x05990000 to caller regions list (kernel32::GetLocalTime).
2019-10-10 01:08:36,414 [root] DEBUG: set_caller_info: Adding region at 0x075A0000 to caller regions list (kernel32::GetLocalTime).
2019-10-10 01:08:36,414 [root] DEBUG: set_caller_info: Adding region at 0x05A00000 to caller regions list (msvcrt::memcpy).
2019-10-10 01:08:36,446 [root] DEBUG: set_caller_info: Adding region at 0x077A0000 to caller regions list (ntdll::NtAllocateVirtualMemory).
2019-10-10 01:08:36,461 [root] DEBUG: set_caller_info: Adding region at 0x06BE0000 to caller regions list (kernel32::GetLocalTime).
2019-10-10 01:08:36,461 [root] DEBUG: set_caller_info: Adding region at 0x00610000 to caller regions list (msvcrt::memcpy).
2019-10-10 01:08:36,493 [root] DEBUG: DLL loaded at 0x6C690000: C:\Windows\SysWOW64\FM20 (0x12c000 bytes).
2019-10-10 01:08:36,493 [root] DEBUG: DLL loaded at 0x768C0000: C:\Windows\syswow64\COMDLG32 (0x7b000 bytes).
2019-10-10 01:08:36,493 [root] DEBUG: DLL loaded at 0x74BE0000: C:\Windows\WinSxS\x86_microsoft.windows.common-controls_6595b64144ccf1df_5.82.7601.17514_none_ec83dffa859149af\COMCTL32 (0x84000 bytes).
2019-10-10 01:08:36,523 [root] DEBUG: set_caller_info: Adding region at 0x001D0000 to caller regions list (ntdll::memcpy).
2019-10-10 01:08:36,867 [root] DEBUG: set_caller_info: Adding region at 0x03C50000 to caller regions list (ntdll::LdrGetProcedureAddress).
2019-10-10 01:08:36,914 [root] DEBUG: DLL loaded at 0x6C530000: C:\Windows\System32\msxml6 (0x158000 bytes).
2019-10-10 01:08:36,976 [root] DEBUG: set_caller_info: Adding region at 0x07D00000 to caller regions list (ntdll::LdrGetProcedureAddress).
2019-10-10 01:08:37,164 [root] DEBUG: DLL loaded at 0x6C470000: C:\Program Files (x86)\Common Files\Microsoft Shared\OFFICE14\MSPTLS (0xbc000 bytes).
2019-10-10 01:08:38,115 [root] DEBUG: DLL loaded at 0x6C440000: C:\Windows\System32\shdocvw (0x2e000 bytes).
2019-10-10 01:08:38,161 [root] INFO: Announced 64-bit process name: explorer.exe pid: 1708
2019-10-10 01:08:38,161 [lib.api.process] INFO: 64-bit DLL to inject is C:\ykjcugc\dll\qDDFbk.dll, loader C:\ykjcugc\bin\AcwcLhKT.exe
2019-10-10 01:08:38,161 [root] DEBUG: ReadConfig: Successfully loaded pipe name \\.\PIPE\BsuWbP.
2019-10-10 01:08:38,177 [root] DEBUG: Loader: Injecting process 1708 (thread 0) with C:\ykjcugc\dll\qDDFbk.dll.
2019-10-10 01:08:38,240 [root] DEBUG: InjectDll: No thread ID supplied, GetProcessInitialThreadId failed.
2019-10-10 01:08:38,256 [root] DEBUG: Terminate processes on terminate_event enabled.
2019-10-10 01:08:38,256 [root] INFO: Disabling sleep skipping.
2019-10-10 01:08:38,302 [root] WARNING: Unable to place hook on LockResource
2019-10-10 01:08:38,302 [root] WARNING: Unable to hook LockResource
2019-10-10 01:08:38,365 [root] DEBUG: CAPE initialised: 64-bit base package loaded in process 1708 at 0x000000006C360000, image base 0x00000000FFA80000, stack from 0x0000000004562000-0x0000000004570000
2019-10-10 01:08:38,365 [root] DEBUG: Commandline: C:\Windows\explorer.exe.
2019-10-10 01:08:38,365 [root] INFO: Added new process to list with pid: 1708
2019-10-10 01:08:38,365 [root] INFO: Monitor successfully loaded in process with pid 1708.
2019-10-10 01:08:38,365 [root] DEBUG: InjectDllViaThread: Successfully injected Dll into process via RtlCreateUserThread.
2019-10-10 01:08:38,365 [root] DEBUG: InjectDll: Successfully injected DLL via thread.
2019-10-10 01:08:38,365 [root] DEBUG: Successfully injected DLL C:\ykjcugc\dll\qDDFbk.dll.
2019-10-10 01:08:38,941 [root] INFO: Process with pid 1708 has terminated
2019-10-10 01:08:39,098 [root] DEBUG: set_caller_info: Adding region at 0x007C0000 to caller regions list (ntdll::memcpy).
2019-10-10 01:08:39,164 [root] DEBUG: DLL loaded at 0x75070000: C:\Windows\SysWOW64\fm20ENU (0x8000 bytes).
2019-10-10 01:08:39,224 [root] DEBUG: DLL loaded at 0x75050000: C:\Windows\system32\asycfilt (0x14000 bytes).
2019-10-10 01:08:39,255 [root] DEBUG: set_caller_info: Adding region at 0x07C00000 to caller regions list (ntdll::NtFindAtom).
2019-10-10 01:08:39,275 [root] DEBUG: DLL loaded at 0x75040000: C:\Windows\system32\msiltcfg (0x7000 bytes).
2019-10-10 01:08:39,276 [root] DEBUG: DLL unloaded from 0x74440000.
2019-10-10 01:08:39,397 [root] DEBUG: DLL unloaded from 0x77050000.
2019-10-10 01:08:39,407 [root] DEBUG: DLL loaded at 0x75030000: C:\Windows\SysWOW64\SFC (0x3000 bytes).
2019-10-10 01:08:39,417 [root] DEBUG: DLL loaded at 0x75020000: C:\Windows\system32\sfc_os (0xd000 bytes).
2019-10-10 01:08:39,496 [root] DEBUG: DLL loaded at 0x75010000: C:\Program Files (x86)\Microsoft Office\Office14\REFEDIT (0xb000 bytes).
2019-10-10 01:08:39,569 [modules.auxiliary.human] INFO: Found button "Close the program", clicking it
2019-10-10 01:08:39,756 [root] DEBUG: DLL unloaded from 0x6C690000.
2019-10-10 01:08:40,010 [root] DEBUG: set_caller_info: Adding region at 0x094F0000 to caller regions list (ntdll::NtAllocateVirtualMemory).
2019-10-10 01:08:40,207 [root] DEBUG: DLL loaded at 0x74FB0000: C:\Windows\system32\Winspool.DRV (0x51000 bytes).
2019-10-10 01:08:51,595 [root] DEBUG: DLL unloaded from 0x76A70000.
2019-10-10 01:11:15,085 [root] INFO: Analysis timeout hit (200 seconds), terminating analysis.
2019-10-10 01:11:15,085 [root] INFO: Created shutdown mutex.
2019-10-10 01:11:16,098 [lib.api.process] INFO: Successfully received reply to terminate_event, pid 1828
2019-10-10 01:11:16,098 [root] INFO: Terminate event set for process 1828.
2019-10-10 01:11:16,098 [root] DEBUG: Terminate Event: Skipping dump of process 1828
2019-10-10 01:11:16,098 [root] INFO: Terminating process 1828 before shutdown.
2019-10-10 01:11:16,098 [root] INFO: Waiting for process 1828 to exit.
2019-10-10 01:11:16,191 [root] DEBUG: Terminate Event: Shutdown complete for process 1828 but failed to inform analyzer.
2019-10-10 01:11:16,207 [root] DEBUG: DLL loaded at 0x74D70000: C:\Windows\system32\POWRPROF (0x25000 bytes).
2019-10-10 01:11:17,112 [root] INFO: Shutting down package.
2019-10-10 01:11:17,112 [root] INFO: Stopping auxiliary modules.
2019-10-10 01:11:17,112 [root] INFO: Finishing auxiliary modules.
2019-10-10 01:11:17,112 [root] INFO: Shutting down pipe server and dumping dropped files.
2019-10-10 01:11:17,112 [root] WARNING: File at path "C:\jLeAZUIJLm\debugger" does not exist, skip.
2019-10-10 01:11:17,112 [root] WARNING: Monitor injection attempted but failed for process 119864063.
2019-10-10 01:11:17,112 [root] INFO: Analysis completed.

MalScore

10.0

Malicious

Machine

Name Label Manager Started On Shutdown On
target-02 target-02 ESX 2019-10-10 00:07:21 2019-10-10 00:11:49

File Details

File Name tmpczia736j
File Size 4817408 bytes
File Type Composite Document File V2 Document, Little Endian, Os: Windows, Version 6.1, Code page: 1252, Title: Xnumbers Ver 6.0.5.6A 11Dec2013, Subject: Multi Precision Floating Point Calculus, Author: Leonardo Volpi, Comments: Multi-Precision Floating Point Calculus, Last Saved By: Steve Beyers, Revision Number: 4, Name of Creating Application: Microsoft Excel, Total Editing Time: 01:00, Create Time/Date: Wed Nov 7 14:02:09 2007, Last Saved Time/Date: Thu Dec 12 00:55:10 2013, Number of Pages: -4105, Number of Words: 0, Number of Characters: 0, Security: 0
MD5 d2619a522bcfef768d44e423f2ba57b5
SHA1 ff763637fced3a141450a6542bb705df32ee75ba
SHA256 b7c3a27aacc0d107fda29a5e8ebf06641dc5c2ac062e50c16e5ad1decaf6996c
SHA512 c85bd8ea1d736b746d27673c30ffc2ac0def2134db9d317f61156175c2e2176ac2b724ae01005840ae6463507629c12f59f59208b2de66fc8cb09c4b5da9f31a
CRC32 F3EB2FBE
Ssdeep 49152:VYsQPUDM28gqJUwYhWn6ONsvrSHkfhAWFw:u4M28gqmw8iQAAw
TrID
  • 40.6% (.MSP) Windows Installer Patch (44509/10/5)
  • 29.6% (.XLS) Microsoft Excel sheet (32500/1/3)
  • 22.3% (.XLS) Microsoft Excel sheet (alternate) (24500/1/2)
  • 7.3% (.) Generic OLE2 / Multistream Compound File (8000/1)
ClamAV None matched
Yara
  • shellcode_patterns - Matched shellcode byte patterns
CAPE Yara None matched
Resubmit sample

Signatures

Yara rule detections observed from a process memory dump/dropped files/CAPE
Hit: PID 0 trigged the Yara rule 'shellcode_patterns'
Dynamic (imported) function loading detected
DynamicLoader: OLEAUT32.dll/
DynamicLoader: OLEAUT32.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: kernel32.dll/GetNativeSystemInfo
DynamicLoader: kernel32.dll/GetSystemWow64DirectoryW
DynamicLoader: ADVAPI32.dll/CheckTokenMembership
DynamicLoader: kernel32.dll/GetSystemWow64DirectoryW
DynamicLoader: kernel32.dll/GetFileAttributesExW
DynamicLoader: kernel32.dll/HeapSetInformation
DynamicLoader: GKExcel.dll/FValidateExcelFile
DynamicLoader: GKExcel.dll/HrInitHost
DynamicLoader: kernel32.dll/SwitchToThread
DynamicLoader: kernel32.dll/TryEnterCriticalSection
DynamicLoader: kernel32.dll/SetCriticalSectionSpinCount
DynamicLoader: kernel32.dll/GetTickCount64
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: SHELL32.DLL/SHIsFileAvailableOffline
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: Comctl32.dll/RegisterClassNameW
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: VERSION.dll/GetFileVersionInfoA
DynamicLoader: VERSION.dll/GetFileVersionInfoSizeA
DynamicLoader: VERSION.dll/VerQueryValueA
DynamicLoader: VERSION.dll/GetFileVersionInfoW
DynamicLoader: VERSION.dll/GetFileVersionInfoSizeW
DynamicLoader: VERSION.dll/VerQueryValueW
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: SXS.DLL/SxsOleAut32MapReferenceClsidToConfiguredClsid
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: kernel32.dll/FlsAlloc
DynamicLoader: kernel32.dll/FlsGetValue
DynamicLoader: kernel32.dll/FlsSetValue
DynamicLoader: kernel32.dll/FlsFree
DynamicLoader: kernel32.dll/IsProcessorFeaturePresent
DynamicLoader: VBE7.DLL/DllVbeInit
DynamicLoader: mso.dll/_MsoInitGimme@12
DynamicLoader: mso.dll/_MsoFGimmeFeatureEx@8
DynamicLoader: mso.dll/_MsoFGimmeComponentEx@24
DynamicLoader: mso.dll/_MsoFGimmeComponentEx@20
DynamicLoader: mso.dll/_MsoFGimmeFileEx@24
DynamicLoader: mso.dll/_MsoFGimmeFileEx@20
DynamicLoader: mso.dll/_MsoSetLVProperty@8
DynamicLoader: mso.dll/_MsoVBADigSigCallDlg@20
DynamicLoader: mso.dll/_MsoVbaInitSecurity@4
DynamicLoader: mso.dll/_MsoFIEPolicyAndVersion@8
DynamicLoader: mso.dll/_MsoFUseIEFeature@8
DynamicLoader: mso.dll/_MsoFAnsiCodePageSupportsLCID@8
DynamicLoader: mso.dll/_MsoFInitOffice@20
DynamicLoader: mso.dll/_MsoUninitOffice@4
DynamicLoader: mso.dll/_MsoFGetFontSettings@20
DynamicLoader: mso.dll/_MsoRgchToRgwch@16
DynamicLoader: mso.dll/_MsoHrSimpleQueryInterface@16
DynamicLoader: mso.dll/_MsoHrSimpleQueryInterface2@20
DynamicLoader: mso.dll/_MsoFCreateControl@36
DynamicLoader: mso.dll/_MsoFLongLoad@8
DynamicLoader: mso.dll/_MsoFLongSave@8
DynamicLoader: mso.dll/_MsoFGetTooltips@0
DynamicLoader: mso.dll/_MsoFSetTooltips@4
DynamicLoader: mso.dll/_MsoFLoadToolbarSet@24
DynamicLoader: mso.dll/_MsoFCreateToolbarSet@28
DynamicLoader: mso.dll/_MsoInitShrGlobal@4
DynamicLoader: mso.dll/_MsoHpalOffice@0
DynamicLoader: mso.dll/_MsoFWndProcNeeded@4
DynamicLoader: mso.dll/_MsoFWndProc@24
DynamicLoader: mso.dll/_MsoFCreateITFCHwnd@20
DynamicLoader: mso.dll/_MsoDestroyITFC@4
DynamicLoader: mso.dll/_MsoFPitbsFromHwndAndMsg@12
DynamicLoader: mso.dll/_MsoFGetComponentManager@4
DynamicLoader: mso.dll/_MsoMultiByteToWideChar@24
DynamicLoader: mso.dll/_MsoWideCharToMultiByte@32
DynamicLoader: mso.dll/_MsoHrRegisterAll@0
DynamicLoader: mso.dll/_MsoFSetComponentManager@4
DynamicLoader: mso.dll/_MsoFCreateStdComponentManager@20
DynamicLoader: mso.dll/_MsoFHandledMessageNeeded@4
DynamicLoader: mso.dll/_MsoPeekMessage@8
DynamicLoader: mso.dll/_MsoGetWWWCmdInfo@20
DynamicLoader: mso.dll/_MsoFExecWWWHelp@8
DynamicLoader: mso.dll/_MsoFCreateIPref@28
DynamicLoader: mso.dll/_MsoDestroyIPref@4
DynamicLoader: mso.dll/_MsoChsFromLid@4
DynamicLoader: mso.dll/_MsoCpgFromChs@4
DynamicLoader: mso.dll/_MsoSetLocale@4
DynamicLoader: mso.dll/_MsoFSetHMsoinstOfSdm@4
DynamicLoader: mso.dll/_MsoVBADigSig2CallDlgEx@28
DynamicLoader: mso.dll/_MsoVbaInitSecurityEx@4
DynamicLoader: OLEAUT32.dll/SysFreeString
DynamicLoader: OLEAUT32.dll/LoadTypeLib
DynamicLoader: OLEAUT32.dll/RegisterTypeLib
DynamicLoader: OLEAUT32.dll/QueryPathOfRegTypeLib
DynamicLoader: OLEAUT32.dll/UnRegisterTypeLib
DynamicLoader: OLEAUT32.dll/OleTranslateColor
DynamicLoader: OLEAUT32.dll/OleCreateFontIndirect
DynamicLoader: OLEAUT32.dll/OleCreatePictureIndirect
DynamicLoader: OLEAUT32.dll/OleLoadPicture
DynamicLoader: OLEAUT32.dll/OleCreatePropertyFrameIndirect
DynamicLoader: OLEAUT32.dll/OleCreatePropertyFrame
DynamicLoader: OLEAUT32.dll/OleIconToCursor
DynamicLoader: OLEAUT32.dll/LoadTypeLibEx
DynamicLoader: OLEAUT32.dll/OleLoadPictureEx
DynamicLoader: USER32.dll/GetSystemMetrics
DynamicLoader: USER32.dll/MonitorFromWindow
DynamicLoader: USER32.dll/MonitorFromRect
DynamicLoader: USER32.dll/MonitorFromPoint
DynamicLoader: USER32.dll/EnumDisplayMonitors
DynamicLoader: USER32.dll/GetMonitorInfoA
DynamicLoader: USER32.dll/EnumDisplayDevicesA
DynamicLoader: OLEAUT32.dll/DispCallFunc
DynamicLoader: OLEAUT32.dll/LoadTypeLibEx
DynamicLoader: OLEAUT32.dll/UnRegisterTypeLib
DynamicLoader: OLEAUT32.dll/CreateTypeLib2
DynamicLoader: OLEAUT32.dll/VarDateFromUdate
DynamicLoader: OLEAUT32.dll/VarUdateFromDate
DynamicLoader: OLEAUT32.dll/GetAltMonthNames
DynamicLoader: OLEAUT32.dll/VarNumFromParseNum
DynamicLoader: OLEAUT32.dll/VarParseNumFromStr
DynamicLoader: OLEAUT32.dll/VarDecFromR4
DynamicLoader: OLEAUT32.dll/VarDecFromR8
DynamicLoader: OLEAUT32.dll/VarDecFromDate
DynamicLoader: OLEAUT32.dll/VarDecFromI4
DynamicLoader: OLEAUT32.dll/VarDecFromCy
DynamicLoader: OLEAUT32.dll/VarR4FromDec
DynamicLoader: OLEAUT32.dll/GetRecordInfoFromTypeInfo
DynamicLoader: OLEAUT32.dll/GetRecordInfoFromGuids
DynamicLoader: OLEAUT32.dll/SafeArrayGetRecordInfo
DynamicLoader: OLEAUT32.dll/SafeArraySetRecordInfo
DynamicLoader: OLEAUT32.dll/SafeArrayGetIID
DynamicLoader: OLEAUT32.dll/SafeArraySetIID
DynamicLoader: OLEAUT32.dll/SafeArrayCopyData
DynamicLoader: OLEAUT32.dll/SafeArrayAllocDescriptorEx
DynamicLoader: OLEAUT32.dll/SafeArrayCreateEx
DynamicLoader: OLEAUT32.dll/VarFormat
DynamicLoader: OLEAUT32.dll/VarFormatDateTime
DynamicLoader: OLEAUT32.dll/VarFormatNumber
DynamicLoader: OLEAUT32.dll/VarFormatPercent
DynamicLoader: OLEAUT32.dll/VarFormatCurrency
DynamicLoader: OLEAUT32.dll/VarWeekdayName
DynamicLoader: OLEAUT32.dll/VarMonthName
DynamicLoader: OLEAUT32.dll/VarAdd
DynamicLoader: OLEAUT32.dll/VarAnd
DynamicLoader: OLEAUT32.dll/VarCat
DynamicLoader: OLEAUT32.dll/VarDiv
DynamicLoader: OLEAUT32.dll/VarEqv
DynamicLoader: OLEAUT32.dll/VarIdiv
DynamicLoader: OLEAUT32.dll/VarImp
DynamicLoader: OLEAUT32.dll/VarMod
DynamicLoader: OLEAUT32.dll/VarMul
DynamicLoader: OLEAUT32.dll/VarOr
DynamicLoader: OLEAUT32.dll/VarPow
DynamicLoader: OLEAUT32.dll/VarSub
DynamicLoader: OLEAUT32.dll/VarXor
DynamicLoader: OLEAUT32.dll/VarAbs
DynamicLoader: OLEAUT32.dll/VarFix
DynamicLoader: OLEAUT32.dll/VarInt
DynamicLoader: OLEAUT32.dll/VarNeg
DynamicLoader: OLEAUT32.dll/VarNot
DynamicLoader: OLEAUT32.dll/VarRound
DynamicLoader: OLEAUT32.dll/VarCmp
DynamicLoader: OLEAUT32.dll/VarDecAdd
DynamicLoader: OLEAUT32.dll/VarDecCmp
DynamicLoader: OLEAUT32.dll/VarBstrCat
DynamicLoader: OLEAUT32.dll/VarCyMulI4
DynamicLoader: OLEAUT32.dll/VarBstrCmp
DynamicLoader: ole32.dll/CoCreateInstanceEx
DynamicLoader: ole32.dll/CLSIDFromProgIDEx
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/_MsoMultiByteToWideChar@24
DynamicLoader: SXS.DLL/SxsOleAut32RedirectTypeLibrary
DynamicLoader: ADVAPI32.dll/RegOpenKeyW
DynamicLoader: ADVAPI32.dll/RegEnumKeyW
DynamicLoader: ADVAPI32.dll/RegQueryValueW
DynamicLoader: SXS.DLL/SxsOleAut32MapConfiguredClsidToReferenceClsid
DynamicLoader: mso.dll/
DynamicLoader: kernel32.dll/NlsGetCacheUpdateCount
DynamicLoader: USER32.dll/NotifyWinEvent
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: GdiPlus.dll/GdipRecordMetafile
DynamicLoader: mso.dll/
DynamicLoader: GdiPlus.dll/GdipGetImageGraphicsContext
DynamicLoader: mso.dll/
DynamicLoader: GdiPlus.dll/GdipCreatePen1
DynamicLoader: mso.dll/
DynamicLoader: GdiPlus.dll/GdipSetPenColor
DynamicLoader: mso.dll/
DynamicLoader: GdiPlus.dll/GdipDrawLine
DynamicLoader: mso.dll/
DynamicLoader: GdiPlus.dll/GdipDeletePen
DynamicLoader: mso.dll/
DynamicLoader: GdiPlus.dll/GdipDeleteGraphics
DynamicLoader: mso.dll/
DynamicLoader: GdiPlus.dll/GdipDisposeImage
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: OLEAUT32.dll/
DynamicLoader: OLEAUT32.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: riched20.dll/CreateTextBoxLayout
DynamicLoader: riched20.dll/MathBuildUp
DynamicLoader: riched20.dll/MathBuildDown
DynamicLoader: riched20.dll/MathTranslate
DynamicLoader: riched20.dll/CreateMathXmlHandler
DynamicLoader: riched20.dll/ProcessMathMenuID
DynamicLoader: riched20.dll/GetMathContextMenuItems
DynamicLoader: riched20.dll/WriteMathPrSax
DynamicLoader: mso.dll/_MsoGetHmodPTLServices@0
DynamicLoader: kernel32.dll/HeapSetInformation
DynamicLoader: MSPTLS.DLL/
DynamicLoader: MSPTLS.DLL/
DynamicLoader: MSPTLS.DLL/
DynamicLoader: MSPTLS.DLL/
DynamicLoader: MSPTLS.DLL/
DynamicLoader: MSPTLS.DLL/
DynamicLoader: MSPTLS.DLL/
DynamicLoader: MSPTLS.DLL/
DynamicLoader: MSPTLS.DLL/
DynamicLoader: mso.dll/
DynamicLoader: MSPTLS.DLL/
DynamicLoader: MSPTLS.DLL/
DynamicLoader: MSPTLS.DLL/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: MSPTLS.DLL/
DynamicLoader: MSPTLS.DLL/
DynamicLoader: MSPTLS.DLL/
DynamicLoader: MSPTLS.DLL/
DynamicLoader: MSPTLS.DLL/
DynamicLoader: MSPTLS.DLL/
DynamicLoader: MSPTLS.DLL/
DynamicLoader: MSPTLS.DLL/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: GDI32.dll/GdiTransparentBlt
DynamicLoader: GDI32.dll/GdiAlphaBlend
DynamicLoader: GDI32.dll/GdiGradientFill
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: GdiPlus.dll/GdipCreateLineBrush
DynamicLoader: mso.dll/
DynamicLoader: GdiPlus.dll/GdipSetLinePresetBlend
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: GdiPlus.dll/GdipCreateSolidFill
DynamicLoader: mso.dll/
DynamicLoader: GdiPlus.dll/GdipSetSolidFillColor
DynamicLoader: mso.dll/
DynamicLoader: GdiPlus.dll/GdipCreatePath
DynamicLoader: mso.dll/
DynamicLoader: GdiPlus.dll/GdipAddPathBezier
DynamicLoader: mso.dll/
DynamicLoader: GdiPlus.dll/GdipClosePathFigure
DynamicLoader: mso.dll/
DynamicLoader: GdiPlus.dll/GdipAddPathPath
DynamicLoader: mso.dll/
DynamicLoader: GdiPlus.dll/GdipCreateFromHDC
DynamicLoader: mso.dll/
DynamicLoader: GdiPlus.dll/GdipSetPageUnit
DynamicLoader: mso.dll/
DynamicLoader: GdiPlus.dll/GdipGetVisibleClipBoundsI
DynamicLoader: mso.dll/
DynamicLoader: GdiPlus.dll/GdipCreateMatrix
DynamicLoader: mso.dll/
DynamicLoader: GdiPlus.dll/GdipSetMatrixElements
DynamicLoader: mso.dll/
DynamicLoader: GdiPlus.dll/GdipSetSmoothingMode
DynamicLoader: mso.dll/
DynamicLoader: GdiPlus.dll/GdipSetTextRenderingHint
DynamicLoader: mso.dll/
DynamicLoader: GdiPlus.dll/GdipSetInterpolationMode
DynamicLoader: mso.dll/
DynamicLoader: GdiPlus.dll/GdipSetPixelOffsetMode
DynamicLoader: mso.dll/
DynamicLoader: GdiPlus.dll/GdipSetWorldTransform
DynamicLoader: mso.dll/
DynamicLoader: GdiPlus.dll/GdipFillPath
DynamicLoader: mso.dll/
DynamicLoader: GdiPlus.dll/GdipResetWorldTransform
DynamicLoader: mso.dll/
DynamicLoader: GdiPlus.dll/GdipDeleteMatrix
DynamicLoader: mso.dll/
DynamicLoader: GdiPlus.dll/GdipDeletePath
DynamicLoader: mso.dll/
DynamicLoader: GdiPlus.dll/GdipDeleteBrush
DynamicLoader: mso.dll/
DynamicLoader: GdiPlus.dll/GdipGetLineTransform
DynamicLoader: mso.dll/
DynamicLoader: GdiPlus.dll/GdipGetMatrixElements
DynamicLoader: mso.dll/
DynamicLoader: GdiPlus.dll/GdipSetLineTransform
DynamicLoader: mso.dll/
DynamicLoader: GdiPlus.dll/GdipGetPointCount
DynamicLoader: mso.dll/
DynamicLoader: GdiPlus.dll/GdipGetPathTypes
DynamicLoader: mso.dll/
DynamicLoader: GdiPlus.dll/GdipGetPathPoints
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: OLEAUT32.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: ole32.dll/PropVariantClear
DynamicLoader: OLEAUT32.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: OLEAUT32.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: ADVAPI32.dll/RegQueryValueW
DynamicLoader: apphelp.dll/ApphelpCheckShellObject
DynamicLoader: OLEAUT32.dll/RegisterTypeLibForUser
DynamicLoader: mso.dll/
DynamicLoader: ole32.dll/CoCreateInstance
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: COMCTL32.dll/ImageList_Destroy
DynamicLoader: COMCTL32.dll/ImageList_GetIconSize
DynamicLoader: COMCTL32.dll/InitCommonControls
DynamicLoader: COMCTL32.dll/ImageList_LoadImageA
DynamicLoader: COMCTL32.dll/ImageList_SetOverlayImage
DynamicLoader: COMCTL32.dll/ImageList_AddMasked
DynamicLoader: COMCTL32.dll/ImageList_GetImageInfo
DynamicLoader: COMCTL32.dll/ImageList_Draw
DynamicLoader: COMCTL32.dll/ImageList_DrawEx
DynamicLoader: COMCTL32.dll/PropertySheetA
DynamicLoader: COMCTL32.dll/DestroyPropertySheetPage
DynamicLoader: COMCTL32.dll/CreatePropertySheetPageA
DynamicLoader: COMCTL32.dll/RegisterClassNameW
DynamicLoader: mso.dll/
DynamicLoader: COMCTL32.dll/RegisterClassNameW
DynamicLoader: asycfilt.dll/FilterCreateInstance
DynamicLoader: riched20.dll/CreateTextServices
DynamicLoader: VBE7.DLL/
DynamicLoader: VBE7.DLL/
DynamicLoader: VBE7.DLL/
DynamicLoader: VBE7.DLL/
DynamicLoader: VBE7.DLL/
DynamicLoader: VBE7.DLL/
DynamicLoader: VBE7.DLL/
DynamicLoader: mso.dll/
DynamicLoader: VBE7.DLL/
DynamicLoader: mso.dll/
DynamicLoader: OLEAUT32.dll/
DynamicLoader: OLEAUT32.dll/
DynamicLoader: mso.dll/
DynamicLoader: Winspool.DRV/GetPrinterW
DynamicLoader: Winspool.DRV/GetPrinterA
DynamicLoader: Winspool.DRV/DeviceCapabilitiesW
DynamicLoader: Winspool.DRV/DeviceCapabilitiesA
DynamicLoader: Winspool.DRV/OpenPrinterW
DynamicLoader: Winspool.DRV/OpenPrinterA
DynamicLoader: Winspool.DRV/DocumentPropertiesW
DynamicLoader: Winspool.DRV/DocumentPropertiesA
DynamicLoader: Winspool.DRV/EnumPrintersA
DynamicLoader: Winspool.DRV/EnumJobsA
DynamicLoader: Winspool.DRV/GetPrinterDriverA
DynamicLoader: Winspool.DRV/ClosePrinter
DynamicLoader: Winspool.DRV/EnumPrintersW
DynamicLoader: Winspool.DRV/EnumJobsW
DynamicLoader: Winspool.DRV/GetPrinterDriverW
DynamicLoader: Winspool.DRV/AddPrinterDriverA
DynamicLoader: Winspool.DRV/AddPrinterDriverW
DynamicLoader: Winspool.DRV/GetPrinterDriverDirectoryA
DynamicLoader: Winspool.DRV/GetPrinterDriverDirectoryW
DynamicLoader: Winspool.DRV/DeletePrinter
DynamicLoader: Winspool.DRV/AddPrinterA
DynamicLoader: Winspool.DRV/AddPrinterW
DynamicLoader: Winspool.DRV/AddPrinterConnectionW
DynamicLoader: Winspool.DRV/GetDefaultPrinterW
DynamicLoader: Winspool.DRV/StartDocPrinterW
DynamicLoader: Winspool.DRV/EndDocPrinter
DynamicLoader: Winspool.DRV/StartPagePrinter
DynamicLoader: Winspool.DRV/EndPagePrinter
DynamicLoader: Winspool.DRV/WritePrinter
DynamicLoader: Winspool.DRV/IsValidDevmodeW
DynamicLoader: sechost.dll/ConvertSidToStringSidW
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: RPCRT4.dll/NdrClientCall2
DynamicLoader: RPCRT4.dll/RpcStringBindingComposeW
DynamicLoader: RPCRT4.dll/RpcBindingFromStringBindingW
DynamicLoader: RPCRT4.dll/RpcBindingSetAuthInfoExW
DynamicLoader: RPCRT4.dll/RpcStringFreeW
DynamicLoader: RPCRT4.dll/RpcBindingFree
DynamicLoader: VBE7.DLL/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: VBE7.DLL/
DynamicLoader: VBE7.DLL/
DynamicLoader: kernel32.dll/GetUserDefaultLCID
DynamicLoader: kernel32.dll/GetLocaleInfoA
DynamicLoader: kernel32.dll/SetLocaleInfoA
DynamicLoader: OLEAUT32.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: mso.dll/
DynamicLoader: VBE7.DLL/
DynamicLoader: OLEAUT32.dll/
DynamicLoader: VBE7.DLL/
DynamicLoader: VBE7.DLL/
DynamicLoader: VBE7.DLL/
DynamicLoader: VBE7.DLL/
DynamicLoader: mso.dll/
The office file contains 78 macros
The office file contains a macro with auto execution
Workbook_Open: Runs when the Excel Workbook is opened
Workbook_Open: Runs when the Excel Workbook is opened
Workbook_Open: Runs when the Excel Workbook is opened
Workbook_Open: Runs when the Excel Workbook is opened
The office file contains anomalous features
creation_anomaly: The file appears to have an edit time yet has no creation time or last saved time. This can be a sign of an automated document creation kit.
The office file contains a macro with potential indicators of compromise
Executable file name: Application.VBE.MainWindow.Visible = False
IPv4 address: Public Const xNver$ = 6.0.5.6
Executable file name: Application.VBE.MainWindow.Visible = False
Executable file name: With Application.VBE.CommandBars.FindControl(id:=578)
Executable file name: With Application.VBE.CommandBars.FindControl(id:=106)
Executable file name: HypGeom0 = +inf 'return ctx.inf
Executable file name: HypGeom0 = +inf 'return ctx.hyp2f1(a,b,c,1-ctx.eps*2) * ctx.inf
Executable file name: PythonwPath = Replace(PythonwPath, \Python.exe, \Pythonw.exe)
Executable file name: Cmd = ProgName.EXE -v -s -l >
Executable file name: PythonwPath = wsObj.RegRead(HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\Python.exe\)
Executable file name: scmd = TASKKILL.EXE /PID TaskId
Executable file name: PythonwPath = PythonwPath\Pythonw.exe
Executable file name: Cmd = ProgName.EXE -v -s -l -d >
Executable file name: Full_FBat = Path_Work\JobName.BAT
Executable file name: JobDate = FileDateTime(Path_Work\JobName.BAT)
Executable file name: Msg = This macro needs to know where Program_Name.exe is installedvbCr Do you want to search for the installation folder?
Executable file name: PathExe = PathWork\Program_Name.EXE
Executable file name: Declare PtrSafe Function SHGetPathFromIDList Lib Shell32.DLL (ByVal idl As LongPtr, ByVal Path$) As LongPtr
Executable file name: Declare Function GetFileVersionInfoSize Lib version.dll Alias GetFileVersionInfoSizeA (ByVal lptstrFilename$, lpdwHandle&) As Long
Executable file name: Declare PtrSafe Function GetFileVersionInfo Lib version.dll Alias GetFileVersionInfoA (ByVal lptstrFilename$, ByVal dwHandle As LongPtr, ByVal dwLen&, lpData As Any) As Long
Executable file name: Declare PtrSafe Function SHGetSpecialFolderLocation Lib Shell32.DLL (ByVal hwndOwner As LongPtr, ByVal Folder As LongPtr, idl As LongPtr) As LongPtr
Executable file name: Declare Function SHBrowseForFolder Lib Shell32.DLL (bi As BROWSEINFO) As Long
Executable file name: Declare PtrSafe Function SHBrowseForFolder Lib Shell32.DLL (bi As BROWSEINFO) As LongPtr
Executable file name: Declare Function SHGetPathFromIDList Lib Shell32.DLL (ByVal idl&, ByVal Path$) As Long
Executable file name: Declare Function GetFileVersionInfo Lib version.dll Alias GetFileVersionInfoA (ByVal lptstrFilename$, ByVal dwHandle&, ByVal dwLen&, lpData As Any) As Long
Executable file name: Declare Function VerQueryValue Lib version.dll Alias VerQueryValueA (pBlock As Any, ByVal lpSubBlock$, lpBuffer As Any, nVerSize&) As Long
Executable file name: Declare Function SHGetSpecialFolderLocation Lib Shell32.DLL (ByVal hwndOwner&, ByVal Folder&, idl&) As Long
Executable file name: Declare PtrSafe Function GetFileVersionInfoSize Lib version.dll Alias GetFileVersionInfoSizeA (ByVal lptstrFilename$, lpdwHandle As LongPtr) As Long
Executable file name: Declare PtrSafe Function VerQueryValue Lib version.dll Alias VerQueryValueA (pBlock As Any, ByVal lpSubBlock$, lpBuffer As Any, nVerSize&) As Long
Executable file name: Function GetDllVersion(Optional sDLLFile$ = shell32.dll, Optional FullVerID) As Single
The office file contains a macro with suspicious strings
Open: May open a file
write: May write to a file (if combined with Open)
StrReverse: May attempt to obfuscate specific strings (use option --deobf to deobfuscate)
binary: May read or write a binary file (if combined with Open)
Chr: May attempt to obfuscate specific strings (use option --deobf to deobfuscate)
Run: May run an executable file or a system command
Windows: May enumerate application windows (if combined with Shell.Application object)
command: May run PowerShell commands
sample: May detect Anubis Sandbox
output: May write to a file (if combined with Open)
system: May run an executable file or a system command on a Mac (if combined with libc.dylib)
System: May run an executable file or a system command on a Mac (if combined with libc.dylib)
Xor: May attempt to obfuscate specific strings (use option --deobf to deobfuscate)
Output: May write to a file (if combined with Open)
CreateObject: May create an OLE object
Kill: May delete a file
MkDir: May create a directory
VBProject: May attempt to modify the VBA code (self-modification)
VBComponents: May attempt to modify the VBA code (self-modification)
CodeModule: May attempt to modify the VBA code (self-modification)
Write: May write to a file (if combined with Open)
SendKeys: May control another application by simulating user keystrokes
Shell: May run an executable file or a system command
vbNormalFocus: May run an executable file or a system command
put: May write to a file (if combined with Open)
xor: May attempt to obfuscate specific strings (use option --deobf to deobfuscate)
open: May open a file
OUTPUT: May write to a file (if combined with Open)
run: May run an executable file or a system command
kill: May delete a file
vbHide: May run an executable file or a system command
vbMinimizedNoFocus: May run an executable file or a system command
WScript_Shell: May run an executable file or a system command
RegRead: May read registry keys
Binary: May read or write a binary file (if combined with Open)
Put: May write to a file (if combined with Open)
Print #: May write to a file (if combined with Open)
lib: May run code from a DLL
RtlMoveMemory: May inject code into another process
Lib: May run code from a DLL
Creates a slightly modified copy of itself
file: C:\Users\user\AppData\Local\Temp\tmpczia736j.xls
percent_match: 96

Screenshots


Hosts

No hosts contacted.

DNS

No domains contacted.


Summary

SummaryInformation Metadata

Creating Application Microsoft Excel
Author Leonardo Volpi
Last Saved By Steve Beyers
Creation Time None
Last Saved Time None
Total Edit Time 60
Document Title Xnumbers Ver 6.0.5.6A 11Dec2013
Document Subject Multi Precision Floating Point Calculus
Amount of Pages 4294963191
Amount of Words 0
Amount of Characters 0

DocumentSummaryInformation Metadata

Company Foxes team
Document Version None
Digital Signature None
Language None
Notes None

File Analysis (Signatures)

HexStrings
1801439850948194 \x18\x01C\x98P\x94\x81\x94
33192986538118 3\x19)\x86S\x81\x18
1112536929253600197479470517 \x11\x12Si)%6\x00\x19tyG\x05\x17
94065645841247 \x94\x06VE\x84\x12G
5185546875 Q\x85Thu
88657757172444 \x88ewW\x17$D
43442889367734 CD(\x896w4
27849559692719 '\x84\x95Yi'\x19
76537446320519 vStF2\x05\x19
36945220079234 6\x94R \x07\x924
17976931348623157081452742373E \x17\x97i14\x86#\x15p\x81E'B7>
0000000000000000 \x00\x00\x00\x00\x00\x00\x00\x00
99999999999999999999 \x99\x99\x99\x99\x99\x99\x99\x99\x99\x99
10000000000000000000 \x10\x00\x00\x00\x00\x00\x00\x00\x00\x00
33219280948873622E 3!\x92\x80\x94\x88sb.
922337203685477580 \x92#7 6\x85Gu\x80
2147483648 !GH6H
9007199254740993 \x90\x07\x19\x92Tt \x93
7922816251426433759354395033 y"\x81bQBd3u\x93T9P3
9007199254740992 \x90\x07\x19\x92Tt \x92
1027565649 \x10'VVI
5527939700884757 U'\x93\x97\x00\x88GW
8944394323791464 \x89D9C#y\x14d
3096059884796511297941903769 0\x96\x05\x98\x84ye\x11)yA\x907i
5009530124805838871898515046 P S\x01$\x80X8\x87\x18\x98QPF
3602879701896405 6\x02\x87\x97\x01\x89d\x05
899912937531 \x89\x99\x12\x93u1
00000000000000 \x00\x00\x00\x00\x00\x00\x00
402373705728 @#spW(
1927360000264409887000019273699927369999926492736999992649992644098873 \x19'6\x00\x00&D \x88p\x00\x01\x92si\x99'6\x99\x99\x92d\x92si\x99\x99&I\x99&D \x88s
1111344555266364736016 \x11\x114EU&cds`\x16
00000000 \x00\x00\x00\x00
1E2147483647 \x1e!GH6G
8000000F \x80\x00\x00\x0f
1e2147483647 \x1e!GH6G
61720117268627 ar\x01\x17&\x86'
5508838915234365952E U\x08\x83\x89\x15#Ce\x95.
2147483648 !GH6H
00000001 \x00\x00\x00\x01
0000000001 \x00\x00\x00\x00\x01
24703282292062329687 $p2\x82) b2\x96\x87
24703282292062329688 $p2\x82) b2\x96\x88
17976931348623158079E289 \x17\x97i14\x86#\x15\x80y\xe2\x89
922337203685477580 \x92#7 6\x85Gu\x80
24703282292062327209 $p2\x82) b2r
24703282292062327210 $p2\x82) b2r\x10
17976931348623158077E289 \x17\x97i14\x86#\x15\x80w\xe2\x89
9223372036854775807E \x92#7 6\x85Gu\x80~
7922816251426433759354395033 y"\x81bQBd3u\x93T9P3
62831853071795865E b\x83\x18S\x07\x17\x95\x86^
2302585092994046 #\x02XP\x92\x99@F
2718281828459045 '\x18(\x18(E\x90E
1772453850905516 \x17rE8P\x90U\x16
223606797749979E "6\x06ywI\x97\x9e
6931471805599453 i1G\x18\x05Y\x94S
301029995663981E 0\x10)\x99Vc\x98\x1e
5772156649015329 Wr\x15fI\x01S)
1000000000000000178214299238 \x10\x00\x00\x00\x00\x00\x00\x00\x17\x82\x14)\x928
100000000000000004488571267807591678554931 \x10\x00\x00\x00\x00\x00\x00\x00\x04H\x85q&x\x07Y\x16xUI1
100000000000000011744051 \x10\x00\x00\x00\x00\x00\x00\x00\x11t@Q
1000000000000000089690419062898688 \x10\x00\x00\x00\x00\x00\x00\x00\x08\x96\x90A\x90b\x89\x86\x88
100000000000000015310110181627527168 \x10\x00\x00\x00\x00\x00\x00\x00\x151\x01\x10\x18\x16'Rqh
7133786258 q3xbX
2147483647 !GH6G
1C3B4210 \x1c;B\x10
00AA006B1A69 \x00\xaa\x00k\x1ai
79228162514264337593543950335E y"\x81bQBd3u\x93T9P3^
94065645841247 \x94\x06VE\x84\x12G
2147483648 !GH6H
234540567E #E@V~
12345600 \x124V\x00
234551436E #EQCn
00023456 \x00\x024V
2147483649 !GH6I
2147483646 !GH6F
11209268933315 \x11 \x92h\x933\x15
5352903665 SR\x906e
71644376471666 qdCvG\x16f
4831436058626442432403564453125E H1C`XbdBC$\x03VDS\x12^
1000000000 \x10\x00\x00\x00\x00
00000000000000 \x00\x00\x00\x00\x00\x00\x00
457526158344057598639561800698 Eu&\x15\x83D\x05u\x98c\x95a\x80\x06\x98
00000001 \x00\x00\x00\x01
35502805388781 5P(\x058\x87\x81
25881940379280 %\x88\x19@7\x92\x80
73205080756888 s P\x80uh\x88
56418958354775 VA\x89X5Gu
63661977236758 cf\x19w#gX
11215209960937 \x11!R \x96 7
57250142097473 W%\x01B ts
07404200127348 \x07@B\x00\x12sH
017140269247 \x01q@&\x92G
0905109223 \x05\x10\x92#
42625678 BbVx
42593921 BY9!
3646840080 6F\x84\x00\x80
383353466139 83SFa9
48540146868529 HT\x01F\x86\x85)
0732421875 \x072B\x18u
22710800170898 "q\x08\x00\x17\x08\x98
72772750258446 rw'P%\x84F
380529699556 8\x05)i\x95V
335896122021 3X\x96\x12 !
7554742932 uTt)2
30401628 0@\x16(
50069589 P\x06\x95\x89
3836255180 86%Q\x80
364901081884 6I\x01\x08\x18\x84
42189715702841 B\x18\x97\x15p(A
82724463156691 \x82rDc\x15f\x91
14419555664062 \x14A\x95Uf@b
67659258842468 ge\x92X\x84$h
88391426810995 \x889\x14&\x81 \x95
597891876536 Yx\x91\x87e6
2722944808 '"\x94H\x08
27264617 '&F\x17
71881769 q\x88\x17i
45027860 E\x02x`
3833857520 83\x85u
401183859913 @\x11\x83\x85\x99\x13
50605685033147 P`V\x85\x031G
1025390625 \x10%9\x06%
27757644653320 'uvDe3
993531733751 \x9951s7Q
248827311268 $\x88'1\x12h
8440767050 \x84@vpP
3759122366 7Y\x12#f
87670706 \x87g\x07\x06
53104110 S\x10A\x10
4043620325 @Cb\x03%
382701134659 8'\x01\x13FY
44064814178522 D\x06H\x14\x17\x85"
0650913512227E \x06P\x915\x12"~
11215209960938 \x11!R \x96 8
727727502584 rw'P%\x84
074042001273 \x07@B\x00\x12s
0171402692 \x01q@&\x92
3358961220 3X\x96\x12
0905109224 \x05\x10\x92$
14419555664063 \x14A\x95Uf@c
277576446533 'uvDe3
883914268109 \x889\x14&\x81
248827311269 $\x88'1\x12i
5978918765 Yx\x91\x87e
2722944809 '"\x94H
0986328125 \x862\x81%
775970458984 wYpE\x89\x84
6170616149 apaaI
1522710323 \x15"q\x03#
45606175 E`au
12312234 \x121"4
14159265358979 \x14\x15\x92e5\x89y
572364942924700087071E W#d\x94)$p\x00\x87\x07\x1e
91893853320467274178 \x91\x898S2\x04g'Ax
00000000000000 \x00\x00\x00\x00\x00\x00\x00
000110011001 \x00\x01\x10\x01\x10\x01
9876543210 \x98vT2\x10
38833486 8\x834\x86
91172642 \x91\x17&B
13796848 \x13yhH
13985526 \x13\x98U&
95476786 \x95Gg\x86
43125206 C\x12R\x06
14097247 \x14 rG
9007199254740846 \x90\x07\x19\x92Tt\x08F
9007199254740881 \x90\x07\x19\x92Tt\x08\x81
64060949687467 d\x06 Ihtg
8000000F \x80\x00\x00\x0f
8000000F \x80\x00\x00\x0f
2147483647 !GH6G
1e2147483647 \x1e!GH6G
8000000F \x80\x00\x00\x0f
8000000F \x80\x00\x00\x0f
5927777777 Y'www
0123456789 \x01#Eg\x89
49447638215177619098293374826E IDv8!Qwa\x90\x98)3t\x82n
2147483648 !GH6H
00000000000000 \x00\x00\x00\x00\x00\x00\x00
0000000001 \x00\x00\x00\x00\x01
93885782848497 \x93\x88W\x82\x84\x84\x97
56843418860808014E V\x844\x18\x86\x08\x08\x01N
00065536 \x00\x06U6
20041216 \x04\x12\x16
20041213 \x04\x12\x13
20061018 \x06\x10\x18
99999999 \x99\x99\x99\x99
11111111111111 \x11\x11\x11\x11\x11\x11\x11
00000000000000 \x00\x00\x00\x00\x00\x00\x00
0000000001 \x00\x00\x00\x00\x01
000080FF \x00\x00\x80\xff
8000000F \x80\x00\x00\x0f
10000000000000000000 \x10\x00\x00\x00\x00\x00\x00\x00\x00\x00
99999999999999999999 \x99\x99\x99\x99\x99\x99\x99\x99\x99\x99
17976931348623158077 \x17\x97i14\x86#\x15\x80w
10000000000000 \x10\x00\x00\x00\x00\x00\x00
00000000000000 \x00\x00\x00\x00\x00\x00\x00
99999999999999 \x99\x99\x99\x99\x99\x99\x99
470328229206232720 G\x03("\x92\x06#'
940656458412465441111E \x94\x06VE\x84\x12FTA\x11\x1e
0002E157 \x00\x02\xe1W
000000000046 \x00\x00\x00\x00\x00F
000000000000 \x00\x00\x00\x00\x00\x00
0732421875 \x072B\x18u
11215209960938 \x11!R \x96 8
22710800170898 "q\x08\x00\x17\x08\x98
57250142097473 W%\x01B ts
727727502584 rw'P%\x84
074042001273 \x07@B\x00\x12s
380529699556 8\x05)i\x95V
0171402692 \x01q@&\x92
3358961220 3X\x96\x12
0905109224 \x05\x10\x92$
31415926516056060791 1AY&Q`V\x06\x07\x91
198418714791870343106E \x19\x84\x18qG\x91\x87\x03C\x10n
114423774522196636802E \x11D#wE"\x19f6\x80.
2147483647 !GH6G
1E2147483647 \x1e!GH6G
26860916 &\x86 \x16
304888344611713860501504000000 0H\x884F\x11q8`P\x15\x04\x00\x00\x00
47147418364135 G\x14t\x186A5
45122165699273 E\x12!ei\x92s
2537379133562625794765760937 %77\x913V&%yGev 7
4714400748520531002654720000 G\x14@\x07HR\x051\x00&Tr\x00\x00
18074521707188 \x18\x07E!pq\x88
49734886141340 IsH\x86\x14\x13@
51867824 Q\x86x$
51867806 Q\x86x\x06
26860917 &\x86 \x17
51867804 Q\x86x\x04
1088886945041835216076800000 \x10\x88\x88iE\x04\x185!`v\x80\x00\x00
92255639097744 \x92%V9 wD
624812030075 bH\x12\x03\x00u
88349480198236 \x884\x94\x80\x19\x826
397494592165 9t\x94Y!e
14948084684693 \x14\x94\x80\x84hF\x93
71908156293343 q\x90\x81V)3C
832337436511 \x83#7Ce\x11
401716235925 @\x17\x16#Y%
929359408244 \x92\x93Y@\x82D
47421875 GB\x18u
457526158344057598639561800698 Eu&\x15\x83D\x05u\x98c\x95a\x80\x06\x98
143017330587612748164976118169912708542837192341 \x140\x173\x05\x87a'H\x16Iv\x11\x81i\x91'\x08T(7\x19#A
11111111111111 \x11\x11\x11\x11\x11\x11\x11
31716666666666 1qfffff
9401398665684614578056035563 \x94\x019\x86ehF\x14W\x80V\x03Uc
0000000000000000000000000001 \x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01
327425318218349405394001 2t%1\x82\x184\x94\x059@\x01
109513058593405520435868 \x10\x95\x13\x05\x85\x93@U CXh
284456267516980216448194 (DV&u\x16\x98\x02\x16D\x81\x94
671953105079608175927677 g\x19S\x10Py`\x81u\x92vw
969200647740628428141723 \x96\x92\x00dw@b\x84(\x14\x17#
11339240859966797737827E \x113\x92@\x85\x99fyw7\x82~
944640693713082259763084 \x94F@i7\x13\x08"Yv0\x84
457302667503064470069336 Es\x02fu\x03\x06Dp\x06\x936
109086191797694925970267 \x10\x90\x86\x19\x17\x97iI%\x97\x02g
953904313837529685073071 \x959\x04187R\x96\x85\x070q
113430578242943001348947 \x1140W\x82B\x940\x014\x89G
277837184577452805958463 'x7\x18EwE(\x05\x95\x84c
342258549787061848187183 4"XT\x97\x87\x06\x18H\x18q\x83
686833535700041828875818 hh3SW\x00\x04\x18(\x87X\x18
107248188327547965542864 \x10rH\x18\x83'TyeT(d
122272737586158059174256 \x12"rsu\x86\x15\x80Y\x17BV
104516646924818707276116 \x10E\x16di$\x81\x87\x07'a\x16
583214739727083355022737 X2\x14s\x97'\x083U\x02'7
190780862767505916848384 \x19\x07\x80\x86'gPY\x16\x84\x83\x84
49479226224509 IG\x92&"E
99697128517883 \x99iq(Qx\x83
44059121565016 D\x05\x91!VP\x16
42727271254691 Brrq%F\x91
952959549455 \x95)YT\x94U
7064553305709E pdU3\x05p\x9e
56398626105291 V9\x86&\x10R\x91
840452769022 \x84\x04Rv\x90"
24307679348956 $0vy4\x89V
75811540562427 u\x81\x15@V$'
563042726564 V0Bred
37692692527592 7i&\x92Ru\x92
93910425921035 \x93\x91\x04%\x92\x105
086708361734 \x08g\x086\x174
IOCs
Executable file name Application.VBE.MainWindow.Visible = False
IPv4 address Public Const xNver$ = 6.0.5.6
Executable file name Application.VBE.MainWindow.Visible = False
Executable file name With Application.VBE.CommandBars.FindControl(id:=578)
Executable file name With Application.VBE.CommandBars.FindControl(id:=106)
Executable file name HypGeom0 = +inf 'return ctx.inf
Executable file name HypGeom0 = +inf 'return ctx.hyp2f1(a,b,c,1-ctx.eps*2) * ctx.inf
Executable file name PythonwPath = Replace(PythonwPath, \Python.exe, \Pythonw.exe)
Executable file name Cmd = ProgName.EXE -v -s -l >
Executable file name PythonwPath = wsObj.RegRead(HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\Python.exe\)
Executable file name scmd = TASKKILL.EXE /PID TaskId
Executable file name PythonwPath = PythonwPath\Pythonw.exe
Executable file name Cmd = ProgName.EXE -v -s -l -d >
Executable file name Full_FBat = Path_Work\JobName.BAT
Executable file name JobDate = FileDateTime(Path_Work\JobName.BAT)
Executable file name Msg = This macro needs to know where Program_Name.exe is installedvbCr Do you want to search for the installation folder?
Executable file name PathExe = PathWork\Program_Name.EXE
Executable file name Declare PtrSafe Function SHGetPathFromIDList Lib Shell32.DLL (ByVal idl As LongPtr, ByVal Path$) As LongPtr
Executable file name Declare Function GetFileVersionInfoSize Lib version.dll Alias GetFileVersionInfoSizeA (ByVal lptstrFilename$, lpdwHandle&) As Long
Executable file name Declare PtrSafe Function GetFileVersionInfo Lib version.dll Alias GetFileVersionInfoA (ByVal lptstrFilename$, ByVal dwHandle As LongPtr, ByVal dwLen&, lpData As Any) As Long
Executable file name Declare PtrSafe Function SHGetSpecialFolderLocation Lib Shell32.DLL (ByVal hwndOwner As LongPtr, ByVal Folder As LongPtr, idl As LongPtr) As LongPtr
Executable file name Declare Function SHBrowseForFolder Lib Shell32.DLL (bi As BROWSEINFO) As Long
Executable file name Declare PtrSafe Function SHBrowseForFolder Lib Shell32.DLL (bi As BROWSEINFO) As LongPtr
Executable file name Declare Function SHGetPathFromIDList Lib Shell32.DLL (ByVal idl&, ByVal Path$) As Long
Executable file name Declare Function GetFileVersionInfo Lib version.dll Alias GetFileVersionInfoA (ByVal lptstrFilename$, ByVal dwHandle&, ByVal dwLen&, lpData As Any) As Long
Executable file name Declare Function VerQueryValue Lib version.dll Alias VerQueryValueA (pBlock As Any, ByVal lpSubBlock$, lpBuffer As Any, nVerSize&) As Long
Executable file name Declare Function SHGetSpecialFolderLocation Lib Shell32.DLL (ByVal hwndOwner&, ByVal Folder&, idl&) As Long
Executable file name Declare PtrSafe Function GetFileVersionInfoSize Lib version.dll Alias GetFileVersionInfoSizeA (ByVal lptstrFilename$, lpdwHandle As LongPtr) As Long
Executable file name Declare PtrSafe Function VerQueryValue Lib version.dll Alias VerQueryValueA (pBlock As Any, ByVal lpSubBlock$, lpBuffer As Any, nVerSize&) As Long
Executable file name Function GetDllVersion(Optional sDLLFile$ = shell32.dll, Optional FullVerID) As Single
Suspicious
Open May open a file
write May write to a file (if combined with Open)
StrReverse May attempt to obfuscate specific strings (use option --deobf to deobfuscate)
binary May read or write a binary file (if combined with Open)
Chr May attempt to obfuscate specific strings (use option --deobf to deobfuscate)
Run May run an executable file or a system command
Windows May enumerate application windows (if combined with Shell.Application object)
command May run PowerShell commands
binary May read or write a binary file (if combined with Open)
sample May detect Anubis Sandbox
output May write to a file (if combined with Open)
system May run an executable file or a system command on a Mac (if combined with libc.dylib)
output May write to a file (if combined with Open)
system May run an executable file or a system command on a Mac (if combined with libc.dylib)
output May write to a file (if combined with Open)
System May run an executable file or a system command on a Mac (if combined with libc.dylib)
output May write to a file (if combined with Open)
Xor May attempt to obfuscate specific strings (use option --deobf to deobfuscate)
Output May write to a file (if combined with Open)
Chr May attempt to obfuscate specific strings (use option --deobf to deobfuscate)
Xor May attempt to obfuscate specific strings (use option --deobf to deobfuscate)
Run May run an executable file or a system command
CreateObject May create an OLE object
output May write to a file (if combined with Open)
Kill May delete a file
MkDir May create a directory
VBProject May attempt to modify the VBA code (self-modification)
VBComponents May attempt to modify the VBA code (self-modification)
CodeModule May attempt to modify the VBA code (self-modification)
Write May write to a file (if combined with Open)
VBProject May attempt to modify the VBA code (self-modification)
Open May open a file
Run May run an executable file or a system command
Write May write to a file (if combined with Open)
SendKeys May control another application by simulating user keystrokes
Shell May run an executable file or a system command
vbNormalFocus May run an executable file or a system command
put May write to a file (if combined with Open)
output May write to a file (if combined with Open)
Output May write to a file (if combined with Open)
xor May attempt to obfuscate specific strings (use option --deobf to deobfuscate)
open May open a file
Chr May attempt to obfuscate specific strings (use option --deobf to deobfuscate)
Chr May attempt to obfuscate specific strings (use option --deobf to deobfuscate)
Output May write to a file (if combined with Open)
system May run an executable file or a system command on a Mac (if combined with libc.dylib)
put May write to a file (if combined with Open)
output May write to a file (if combined with Open)
System May run an executable file or a system command on a Mac (if combined with libc.dylib)
binary May read or write a binary file (if combined with Open)
output May write to a file (if combined with Open)
system May run an executable file or a system command on a Mac (if combined with libc.dylib)
output May write to a file (if combined with Open)
write May write to a file (if combined with Open)
write May write to a file (if combined with Open)
OUTPUT May write to a file (if combined with Open)
system May run an executable file or a system command on a Mac (if combined with libc.dylib)
OUTPUT May write to a file (if combined with Open)
output May write to a file (if combined with Open)
System May run an executable file or a system command on a Mac (if combined with libc.dylib)
output May write to a file (if combined with Open)
Kill May delete a file
Open May open a file
Write May write to a file (if combined with Open)
Output May write to a file (if combined with Open)
Run May run an executable file or a system command
output May write to a file (if combined with Open)
output May write to a file (if combined with Open)
Output May write to a file (if combined with Open)
output May write to a file (if combined with Open)
output May write to a file (if combined with Open)
open May open a file
run May run an executable file or a system command
write May write to a file (if combined with Open)
Chr May attempt to obfuscate specific strings (use option --deobf to deobfuscate)
open May open a file
put May write to a file (if combined with Open)
open May open a file
system May run an executable file or a system command on a Mac (if combined with libc.dylib)
output May write to a file (if combined with Open)
system May run an executable file or a system command on a Mac (if combined with libc.dylib)
output May write to a file (if combined with Open)
Run May run an executable file or a system command
output May write to a file (if combined with Open)
system May run an executable file or a system command on a Mac (if combined with libc.dylib)
run May run an executable file or a system command
xor May attempt to obfuscate specific strings (use option --deobf to deobfuscate)
open May open a file
kill May delete a file
Run May run an executable file or a system command
binary May read or write a binary file (if combined with Open)
Kill May delete a file
open May open a file
Shell May run an executable file or a system command
vbHide May run an executable file or a system command
vbMinimizedNoFocus May run an executable file or a system command
WScript_Shell May run an executable file or a system command
Windows May enumerate application windows (if combined with Shell.Application object)
RegRead May read registry keys
Binary May read or write a binary file (if combined with Open)
CreateObject May create an OLE object
Write May write to a file (if combined with Open)
Put May write to a file (if combined with Open)
Output May write to a file (if combined with Open)
Print # May write to a file (if combined with Open)
system May run an executable file or a system command on a Mac (if combined with libc.dylib)
lib May run code from a DLL
Chr May attempt to obfuscate specific strings (use option --deobf to deobfuscate)
Windows May enumerate application windows (if combined with Shell.Application object)
RtlMoveMemory May inject code into another process
system May run an executable file or a system command on a Mac (if combined with libc.dylib)
Lib May run code from a DLL
write May write to a file (if combined with Open)
system May run an executable file or a system command on a Mac (if combined with libc.dylib)
Chr May attempt to obfuscate specific strings (use option --deobf to deobfuscate)
output May write to a file (if combined with Open)
Chr May attempt to obfuscate specific strings (use option --deobf to deobfuscate)
VBProject May attempt to modify the VBA code (self-modification)
output May write to a file (if combined with Open)
System May run an executable file or a system command on a Mac (if combined with libc.dylib)
AutoExec
Workbook_Open Runs when the Excel Workbook is opened
Workbook_Open Runs when the Excel Workbook is opened
Workbook_Open Runs when the Excel Workbook is opened
Workbook_Open Runs when the Excel Workbook is opened

Extracted Macros

VBA Filename clsMathParserCx.cls Extracted Macro
'********************************************************************************
'* CLASS: clsMathParserCx  Complex version for Xnumbers   v.3.2.8  2.11.2006    *
'*                                                        Leonardo Volpi        *
'*                                                        Arnaud de Grammont    *
'*                                                                              *
'*  Complex Math-Physical Expression Evaluation and Storage                     *
'*  It uses the Complexes routine v.1.5   by Arnaud de Grammont                 *
'********************************************************************************
Option Explicit

#Const DEBUG_MODE = 0


' CONSTANTS

Const HiOPER     As Long = 100
Const HiVT       As Long = 100
Const HiET       As Long = 100
Const HiARG      As Long = 6
Const PileFunk   As Long = 100

Const ERROR_RAISE = 1           'Arnaud d. G. 6-12-02

'********************************************************************************
'* Complex functions module                            by Arnaud de Grammont    *
'* v. 1.5, 13-01-2003                                                           *
'********************************************************************************

 Const OffsetFunc = 0&
 Const OffsetOper = 100&
 Const OffsetNVar = 200&

 'Const Pi_ = 3.14159265358979
' Const SeparateurComplexe = ","  automatically detected 18.3.06 VL
 Const ElementChaine = "'"

 Const symARGUMENT = -1&     'An Argument
 Const symAbs = 0& + OffsetFunc         '"abs", "|.|"
 Const symAtn = 1& + OffsetFunc         '"atn"
 Const symCos = 2& + OffsetFunc          '"cos"
 Const symSin = 3& + OffsetFunc          '"sin"
 Const symExp = 4& + OffsetFunc          '"exp"
 Const symFix = 5& + OffsetFunc          '"fix"
 Const symInt = 6& + OffsetFunc          '"int"
 Const symLn = 7& + OffsetFunc           '"ln"
 Const symLog = 8& + OffsetFunc          '"log"
 Const symRnd = 9& + OffsetFunc          '"rnd"
 Const symSgn = 10& + OffsetFunc         '"sgn"
 Const symSqr = 11& + OffsetFunc         '"sqr"
 Const symTan = 12& + OffsetFunc         '"tan"
 Const symAcos = 13& + OffsetFunc        '"acos"
 Const symAsin = 14& + OffsetFunc        '"asin"
 Const symCosh = 15& + OffsetFunc        '"cosh"
 Const symSinh = 16& + OffsetFunc        '"sinh"
 Const symTanh = 17& + OffsetFunc        '"tanh"
 Const symAcosh = 18& + OffsetFunc       '"acosh"
 Const symAsinh = 19& + OffsetFunc       '"asinh"
 Const symAtanh = 20& + OffsetFunc       '"atanh"
 Const symReel = 21& + OffsetFunc        'partie r\xe9elle "Re"
 Const symImag = 22& + OffsetFunc        'partie imaginaire "Im"
 Const symErfC = 23& + OffsetFunc        '"erfc"
 Const symConj = 24& + OffsetFunc        '"conj"
 Const symSQ = 25& + OffsetFunc          ' x^2 "SQ"
 Const symFact = 26& + OffsetFunc        '"fact", "!"
 Const symErf = 27& + OffsetFunc         '"erf"
 Const symGamma = 28& + OffsetFunc       '"gamma"
 Const symGammaln = 29& + OffsetFunc     '"gammaln"
 Const symDigamma = 30& + OffsetFunc     '"digamma"
 Const symZeta = 31& + OffsetFunc        '"zeta"
 Const symEi = 32& + OffsetFunc          '"ei"
 Const symInv = 33& + OffsetFunc         '1/x "Inv"
 Const symAlog = 34& + OffsetFunc        '10^x "Alog"
 Const symNeg = 35& + OffsetFunc         '-x "Neg"
 Const symArg = 36& + OffsetFunc         'argument de x "Arg"
 Const symNot = 37& + OffsetFunc         '"not"
 Const symPlus = 0& + OffsetOper        '"+"
 Const symMinus = 1& + OffsetOper       '"-"
 Const symMul = 2& + OffsetOper         '"*"
 Const symDiv = 3& + OffsetOper         '"/"
 Const symModulo = 4& + OffsetOper      '"&" 'modulo, added MR 20-06-02
 Const symDivInt = 5& + OffsetOper      '"\" 'integer division, added MR 20-06-02
 Const symPov = 6& + OffsetOper         '"^"
 Const symMod = 7& + OffsetOper         '"mod"
 Const symComb = 8& + OffsetOper        '"comb"
 Const symMin = 9& + OffsetOper         '"min"
 Const symMax = 10& + OffsetOper        '"max"
 Const symMcd = 11& + OffsetOper        '"mcd"
 Const symMcm = 12& + OffsetOper        '"mcm"
 Const symBeta = 13& + OffsetOper       '"beta"
 Const symR2C = 14& + OffsetOper        '"( , )" COMPLEXE
 Const symXroot = 15& + OffsetOper      'racine x i\xe8me "Xroot"
 Const symGT = 16& + OffsetOper         '">"
 Const symGE = 17& + OffsetOper         '">="
 Const symLT = 18& + OffsetOper         '"<"
 Const symLE = 19& + OffsetOper         '"<="
 Const symEQ = 20& + OffsetOper         '"="
 Const symNE = 21& + OffsetOper         '"<>"
 Const symAnd = 22& + OffsetOper        '"and"
 Const symOr = 23& + OffsetOper         '"or"
 Const symXor = 24& + OffsetOper        '"xor"
 Const symInteg = 0& + OffsetNVar       'Romberg integral (4 variables)
 Const symSerie = 1& + OffsetNVar       'Series (6 variables)



' TYPE DECLARATIONS

Private Type complexe
    reel As Double
    imag As Double
End Type

Private Type T_VTREC           'Variable Table Record
  idx              As Long
  Name             As String
  Value            As complexe
End Type

Private Type T_ETREC           'Expression Table record
  Fun              As String
  FunTok           As Long
  Arg(1 To HiARG)  As T_VTREC
  ArgTop           As Long
  ArgOf            As Long
  ArgIdx           As Long
  Value            As complexe
  PosInExpr        As Long
  PriLvl           As Long
  PriIdx           As Long
  NVarId           As Long
End Type

Private Type T_Funk
  FunName           As String
  NbArg             As Long
  NbFoundArg        As Long
  idFunc            As Long
  lastparenthesis   As Boolean
End Type

' LOCALS
Const InfRslt$ = "Infinite Result"
Const OvrFlo$ = "Overflow"
Dim Expr            As String
Dim ExprOK          As Boolean  'expression OK
'Dim ExprNoOK        As Boolean  'expr OK, no variables
'Dim Expr1OK         As Boolean  'expr OK, exact 1 var
Dim VT()            As T_VTREC
Dim ET()            As T_ETREC
Dim PF()            As T_Funk
Dim VTtop           As Long
Dim ETtop           As Long
Dim ErrMsg          As String   'error message  11-11-02 VL
Dim LastImag        As Double   ' AdG
Dim Funk(1 To HiARG) As String
Dim AngleOption As String
Dim ErrorMsg As String
Dim un As complexe

Private Sub initFunkString()
    Funk(1) = " abs atn cos exp fix int ln log rnd sgn sin sqr sqrt tan acos asin psi atan " & _
            "cosh sinh tanh acosh asinh atanh fact not erf gamma gammaln digamma zeta ei erfc " & _
            "arg re im conj neg sq alog inv "
    Funk(2) = " root comb max min mcm mcd mod and or xor r2c beta " & ArgSep & " "
    Funk(3) = vbNullString
    Funk(4) = " integral "
    Funk(5) = vbNullString
    Funk(6) = " serie "
    un.reel = 1
End Sub


' LOCAL FUNCTIONS

'Private Sub Class_Initialize()
'End Sub
'
'Private Sub Class_terminate()
'End Sub


' PUBLIC FUCTIONS


' store expression as array of records; check syntax
Public Function StoreExpression(strExpr) As Boolean
  Expr = FixDblSym(dCStr_(strExpr))
  ExprOK = Parse(Expr)
'  ExprNoOK = ExprOK And (VTtop = 0)
'  Expr1OK = ExprOK And (VTtop = 1)
  StoreExpression = ExprOK
End Function
'Strip all spaces and fix negative signs following math symbols for numbers only
Private Function FixDblSym(Se$) As String
Dim i%, s$, c$, lsE%
lsE = Len(Se)
FindNxt:
  i = i + 1
  c = Mid$(Se, i, 1)
  If c = " " Then GoTo ChkNxt
  If c = "-" Then
    Select Case Right$(s, 1)
      Case "-", "+", "*", "/", "^", "\", "<", ">", "="
       s = s & "(-"
FndEoN: i = i + 1
       c = Mid$(Se, i, 1)
       If c = " " Then GoTo FndEoN
       If IsNumeric(c) Then
        s = s & c: GoTo FndEoN
       ElseIf c = DecSep Then
        s = s & c: GoTo FndEoN
       ElseIf UCase$(c) = "E" Then
        i = i + 1
        s = s & c & Mid$(Se, i, 1): GoTo FndEoN
       End If
       If Right$(s, 2) = "(-" Then
        Mid$(s, Len(s) - 1, 2) = "-" & c: GoTo ChkNxt
       Else
        s = s & ")" & c: GoTo ChkNxt
       End If
    End Select
  ElseIf c = "*" Then 'also switch "**" to "^"
    If Mid$(Se, i + 1, 1) = "*" Then i = i + 1: c = "^"
  End If
  s = s & c
ChkNxt: If i < lsE Then GoTo FindNxt
FixDblSym = s
End Function

' get the expression
Public Property Get Expression() As String
  Expression = Expr
End Property

' get the top of the var array (=N-1 bacause starts on 0)
Public Property Get VarTop() As Long
  VarTop = VTtop
End Property

' get name of a variable. VL
Public Property Get VarName(ByVal Index&) As String
  If Index <= VTtop Then
    VarName = VT(Index).Name
  End If
End Property

' get value assigned to a variable
Public Property Get VarValue(ByVal Index&) As Double
  If Index <= VTtop Then
    VarValue = VT(Index).Value.reel
  End If
End Property

Public Property Get VarValueImag(ByVal Index&) As Double ' AdG
  If Index <= VTtop Then
    VarValueImag = VT(Index).Value.imag
  End If
End Property

' assign a value to a certain variable
Public Property Let VarValue(ByVal Index&, ByVal VarVal#)
  If Index <= VTtop Then
    VT(Index).Value.reel = VarVal
    VT(Index).Value.imag = 0
  End If
End Property
Public Property Let VarValueImag(ByVal Index&, ByVal VarVal#) ' AdG
  If Index <= VTtop Then
    VT(Index).Value.imag = VarVal
  End If
End Property

' assign values to all vars
Public Sub SetVars(VarVals#())
  If UBound(VarVals) = VTtop Then
    SubstVars VarVals
  End If
End Sub
Public Sub SetVarsImag(VarVals#()) ' AdG
  If UBound(VarVals) = VTtop Then
    SubstVarsImag VarVals
  End If
End Sub

Public Property Get ErrorDescription() As String
  ErrorDescription = ErrMsg
End Property

' assign vars and evaluate expression
Public Function Eval(VarVals#()) As Double
Dim ExprVal As complexe

ErrMsg = vbNullString         'Arnaud d. G. 6-12-02

If Not ExprOK Then GoTo Error_Handler
SubstVars VarVals
If Not Eval_(ExprVal) Then GoTo Error_Handler
Eval = ExprVal.reel
LastImag = ExprVal.imag
Exit Function
'
Error_Handler:
    If ERROR_RAISE = 1 Then Err.Raise 1001, "MathParser", ErrMsg
End Function
' assign vars Complex vars and evaluation : return real part
Public Function EvalComplexe(VarVals#(), VarValsImag#()) As Double ' AdG
Dim ExprVal As complexe

ErrMsg = vbNullString         'Arnaud d. G. 6-12-02

If Not ExprOK Then GoTo Error_Handler
SubstVars VarVals
SubstVarsImag VarValsImag

If Not Eval_(ExprVal) Then GoTo Error_Handler
EvalComplexe = ExprVal.reel
LastImag = ExprVal.imag

Exit Function
'
Error_Handler:
    If ERROR_RAISE = 1 Then Err.Raise 1001, "MathParser", ErrMsg
End Function
' return complex part for last result
Public Function ImagComplexe#()
    ImagComplexe = LastImag
End Function

#If CBool(VBA6 + VBA7) Then
' evaluate an expression with exactly 1 cplx var occuring only once
Public Function Eval1(x As Cplx) As Cplx
Dim ExprVal As complexe: ErrMsg = vbNullString
ET(1).Arg(1).Value.reel = x.r: ET(1).Arg(1).Value.imag = x.i
If Not Eval_(ExprVal) Then GoTo Error_Handler
Eval1.r = ExprVal.reel: Eval1.i = ExprVal.imag
#Else
Public Function Eval1(r, i) As Double
Dim ExprVal As complexe: ErrMsg = vbNullString
ET(1).Arg(1).Value.reel = r: ET(1).Arg(1).Value.imag = i
If Not Eval_(ExprVal) Then GoTo Error_Handler
Eval1 = ExprVal.reel: LastImag = ExprVal.imag
#End If
Exit Function

Error_Handler:
    If ERROR_RAISE = 1 Then Err.Raise 1001, "MathParser", ErrMsg
End Function

' evaluate an expression with no vars to substitute
Public Function Eval0#()
Dim ExprVal As complexe

ErrMsg = vbNullString         'Arnaud d. G. 6-12-02

If Not Eval_(ExprVal) Then GoTo Error_Handler
Eval0 = ExprVal.reel
LastImag = ExprVal.imag
Exit Function
'
Error_Handler:
    If ERROR_RAISE = 1 Then Err.Raise 1001, "MathParser", ErrMsg
End Function

' Math Parser Routine
'         rev 30-08-02 Leonardo Volpi;  rev 20-10-02 L.Dos
Private Function Parse(strExpr$) As Boolean
  Dim lExpr          As String
  Dim char           As String * 1
  Dim SubExpr        As String
  Dim lenExpr        As Long
  Dim FunName        As String
  Dim GetNextArg     As Boolean
  Dim SaveArg        As String
  Dim Npart          As Long
  Dim Nabs           As Long
  Dim idx            As Long
  Dim RetVal         As Double
  Dim arrPriLvl()    As Long
  Dim srtLo          As Long      'vars for sort algoritme
  Dim srtHi          As Long
  Dim tmp            As Long
  Dim Flag_exchanged As Boolean
  Dim i              As Long
  Dim j              As Long
  Dim j1             As Long
  Dim j2             As Long
  Dim LogicSymb      As String
  '*********************************************************************************
  Dim NbArg As Integer
  Dim NVarId As Long
  Dim FctNV As Boolean
  Dim idFun As Long
  Dim indexfun As Long
  Dim chaine As Boolean
  Dim funknbVar As Integer
  NVarId = 0
  idFun = 0
  indexfun = 0
  chaine = False
  ReDim PF(PileFunk)
  initFunkString
  '*********************************************************************************
    
  ReDim ET(HiET)
  ReDim VT(HiVT)
  ETtop = 0
  VTtop = 0
  ErrMsg = vbNullString   'VL
  lExpr = strExpr
  '***** abs |.| function counter
  i = NabsCount(lExpr)
  Nabs = i / 2
  If 2 * Nabs <> i Then
    ErrMsg = "abs symbols |.| mismatch"  'VL
    GoTo ErrHandler
  End If
  '***** begin parse process
  lenExpr = Len(lExpr)
  For i = 1 To lenExpr
   char = Mid$(lExpr, i, 1)
   '*********************************************************************************
   '*                                                                               *
   If chaine = True Then
        If char = ElementChaine Then chaine = False
        SubExpr = SubExpr & Mid$(lExpr, i, 1)
   Else
   '*                                                                               *
   '*********************************************************************************
    Select Case char
      '*********************************************************************************
      '*                                                                               *
      Case ElementChaine
            chaine = True
            SubExpr = SubExpr & Mid$(lExpr, i, 1)
      '*                                                                               *
      '*********************************************************************************
'      Case " "                                    '***** skip spaces
      Case "(", "[", "{"                          '***** open parentheses
        Npart = Npart + 1                         'inc # open parentheses
        If Len(SubExpr) <> 0 Then                     'eval preceding text
          If InList(SubExpr, Funk(1)) Then          'monovariable function
            ETtop = ETtop + 1                     '   store in ET
            With ET(ETtop)
              .PosInExpr = i                      'position in expr
              .Fun = SubExpr                      'function name
              .FunTok = GetFunTok(SubExpr)        'function Token (enum)
              .PriLvl = Npart * 10                'priority level=open parenth*10
              .ArgTop = 1                         'ntal Args=1
            End With
        '*********************************************************************************
        '*                                                                               *
            NbArg = 1
          Else
            NbArg = 0
            For funknbVar = 2 To HiARG
                If InList(SubExpr, Funk(funknbVar)) Then
                    NbArg = funknbVar
                End If
            Next
            If NbArg = 0 Then
              ErrMsg = "Function <" & SubExpr & "> unknown at pos " & str$(i)
              GoTo ErrHandler
            End If
          End If
          
          If NbArg > 1 Then
            FunName = SubExpr
          End If
          indexfun = indexfun + 1
          idFun = idFun + 1
          PF(indexfun).FunName = SubExpr
          PF(indexfun).NbArg = NbArg
          PF(indexfun).NbFoundArg = NbArg
          PF(indexfun).idFunc = idFun
          If NbArg > 2 Then
            FctNV = True
            NVarId = indexfun
          Else
            FctNV = False
          End If
          SubExpr = vbNullString                            'start parsing for new subexpr
          PF(indexfun).lastparenthesis = False
        Else
          indexfun = indexfun + 1
          PF(indexfun).lastparenthesis = True
        End If
        '*                                                                               *
        '*********************************************************************************
      Case ")", "]", "}"                          '***** open parentheses
        Npart = Npart - 1                         'dec # open parentheses
        If Npart < 0 Then                         'want to close to many brackets
          ErrMsg = "Too many closing brackets at pos " & str$(i)
          GoTo ErrHandler
        End If
        '*********************************************************************************
        '*                                                                               *
        If PF(indexfun).lastparenthesis = False Then
            If PF(indexfun).NbArg > 2 Then
                FctNV = True
            Else
                FctNV = False
            End If
            FunName = PF(indexfun).FunName
            NbArg = PF(indexfun).NbFoundArg
        End If
        indexfun = indexfun - 1
        '*                                                                               *
        '*********************************************************************************
      Case "+", "-"                               '*****
        'check the exponential sign (preceding was eg 1.23E of 1.23E-2)
        If CheckExpo(SubExpr) Then                'fix bug 18-1-03  thanks to Michael Ruder
          SubExpr = SubExpr + char
        Else
          ETtop = ETtop + 1                       'store in ET
          With ET(ETtop)
            .PosInExpr = i
            .Fun = char
            .FunTok = GetFunTok(char)
            .PriLvl = 2 + Npart * 10
            .ArgTop = 2                           'two arguments
          End With
          If Len(SubExpr) = 0 Then                    'if nothing precedes: implicit 0
            SubExpr = vbStr0
          End If
          GetNextArg = True                       'get second argument
        End If
      Case "*", "/", "%", "\"                     '*****
        ETtop = ETtop + 1
        With ET(ETtop)
          .PosInExpr = i
          .Fun = char
          .FunTok = GetFunTok(char)
          .PriLvl = 3 + Npart * 10
          .ArgTop = 2                             'two arguments
        End With
        GetNextArg = True
      Case "^"
        ETtop = ETtop + 1
        With ET(ETtop)
          .PosInExpr = i
          .Fun = "^"
          .FunTok = GetFunTok(char)
          .PriLvl = 4 + Npart * 10
          .ArgTop = 2                             'two arguments
        End With
        GetNextArg = True
      Case "!"
        ETtop = ETtop + 1
        With ET(ETtop)
          .PosInExpr = i
          .Fun = "!"
          .FunTok = GetFunTok(char)
          .PriLvl = 8 + Npart * 10
          .ArgTop = 1                             'one argument
        End With
        GetNextArg = True
        SaveArg = SubExpr
'      Case SeparateurComplexe
'        ETtop = ETtop + 1
'        With ET(ETtop)
'          .PosInExpr = i
'          .Fun = SeparateurComplexe
'          .FunTok = GetFunTok(char)
'          .PriLvl = 1 + Npart * 10 'change. VL 5-12-01
'          .ArgTop = 2                             'two arguments
'        End With
'        GetNextArg = True
'        SaveArg = SubExpr
      Case ArgSep                                    'comes from bivariate function f(x;y)
        If Len(FunName) = 0 Then
'          ErrMsg = "syntax error at pos:" & str$(i)
'          GoTo ErrHandler
'        End If
            ETtop = ETtop + 1
            With ET(ETtop)
              .PosInExpr = i
              .Fun = ArgSep
              .FunTok = GetFunTok(char)
              .PriLvl = 1 + Npart * 10 'change. VL 5-12-01
              .ArgTop = 2                             'two arguments
            End With
            GetNextArg = True
            SaveArg = SubExpr
        Else
            ETtop = ETtop + 1
            With ET(ETtop)
              .PosInExpr = i
              .Fun = FunName                          'previous stored
              .FunTok = GetFunTok(FunName)
              .PriLvl = Npart * 10
              .ArgTop = 2                             'two arguments
            End With
            GetNextArg = True
            '*                                                                               *
            If NbArg = 2 Then
                FunName = vbNullString                              'reset function
                If FctNV Then
                    ET(ETtop).NVarId = PF(indexfun).idFunc
                Else
                    ET(ETtop).NVarId = 0
                End If
            Else
                NbArg = NbArg - 1
                PF(indexfun).NbFoundArg = NbArg
                ET(ETtop).NVarId = PF(indexfun).idFunc
            End If
        End If
        '*                                                                               *
      Case "|"                                    '***** absolute symbol |.|
        If Len(SubExpr) = 0 Then
          Npart = Npart + 1                       'increment brackets PriLvl
          ETtop = ETtop + 1
          With ET(ETtop)
            .PosInExpr = i
            .Fun = "abs"                          'symbols |.| is similar to  abs(.)
            .FunTok = GetFunTok("abs")
            .PriLvl = Npart * 10
            .ArgTop = 1                           'one argument
          End With
        Else
          Npart = Npart - 1
          If Npart < 0 Then                       'too many closing brackets
            ErrMsg = "syntax error at pos:" & str$(i)
            GoTo ErrHandler
          End If
        End If
      Case "=", "<", ">"                          'Logical operators
        If Len(LogicSymb) = 0 Then
            ETtop = ETtop + 1
            GetNextArg = True
        End If
        LogicSymb = LogicSymb + char
        With ET(ETtop)
          .PosInExpr = i
          .Fun = LogicSymb                        'logic symbol
          .FunTok = GetFunTok(LogicSymb)
          .PriLvl = 1 + Npart * 10
          .ArgTop = 2                             'two argument
        End With
      Case "x", "y", "z", "X", "Y", "Z"           ''monomial coeff.
        If IsNumeric(Right$(SubExpr, 1)) Then
            ETtop = ETtop + 1                     'Ex: 7x  is converted into product 7*x
            With ET(ETtop)
              .PosInExpr = i
              .Fun = "*"
              .FunTok = GetFunTok("*")
              .PriLvl = 3 + Npart * 10
              .ArgTop = 2                             'two argument
            End With
            GetNextArg = True
            i = i - 1  'one step back
        Else
            SubExpr = SubExpr + char
        End If
      Case Else                                   '***** continue parsing
        SubExpr = SubExpr & char
    End Select
   End If
    
    If GetNextArg Then                            'search for next argument
      If Len(SubExpr) = 0 Then                        'no next argument found
        ErrMsg = "missing argument"
        GoTo ErrHandler
      End If
      
      If IsPureImmaginary(SubExpr, RetVal) Then     'check if argument is pure immaginary
        ET(ETtop).Arg(1).Value.reel = 0
        ET(ETtop).Arg(1).Value.imag = RetVal
      ElseIf convEGU(SubExpr, RetVal) Then            'check if argument is Eng Units
        ET(ETtop).Arg(1).Value.reel = RetVal
        ET(ETtop).Arg(1).Value.imag = 0
'      ElseIf LCase$(SubExpr) = "pi" Then           'check if argument is PI
      ElseIf convSymbConst(SubExpr, RetVal) Then      'check if argument is a symbolic constant #
        If Len(ErrMsg) <> 0 Then GoTo ErrHandler
        
        ET(ETtop).Arg(1).Value.reel = RetVal
        ET(ETtop).Arg(1).Value.imag = 0
      ElseIf IsNumeric_(SubExpr) Then              'check if argument is number
        ET(ETtop).Arg(1).Value.reel = SubExpr
        ET(ETtop).Arg(1).Value.imag = 0
      Else                                        'check if variable
'        If Not IsLetter(Left$(SubExpr, 1)) Then
        If IsNumeric(Left$(SubExpr, 1)) Then
          ErrMsg = "variable name must start with a letter: " & SubExpr
          GoTo ErrHandler
        End If
        If Not CaseSen Then SubExpr = LCase$(SubExpr)
        StoreVar SubExpr, False
        If VTtop > HiVT Then
          ErrMsg = "too many Vars"
          GoTo ErrHandler
        End If
      End If
      SubExpr = vbNullString
      GetNextArg = False
      If ET(ETtop).Fun = "!" Then                 'restore the previous argument for "!" operator
        SubExpr = SaveArg
      End If
    Else
      LogicSymb = vbNullString
    End If
  Next
#If DEBUG_MODE = 1 Or DEBUG_MODE = 10 Then
ET_Dump 1
#End If
  If Npart > 0 Then                               'parentheses
    ErrMsg = "Not enough closing brackets"
    GoTo ErrHandler
  End If
  If ETtop < 1 Then                               'no operation detected
    ETtop = 1
    With ET(ETtop)
      .PosInExpr = 1
      .Fun = "+"
      .FunTok = GetFunTok("+")
      .PriLvl = 1
      .ArgTop = 2
    End With
  End If
  For i = 1 To ETtop                              'init 2e argument
    ET(i).Arg(ET(i).ArgTop) = ET(i + 1).Arg(1)
  Next
#If DEBUG_MODE = 2 Or DEBUG_MODE = 10 Then
ET_Dump 2
#End If
  If Len(SubExpr) <> 0 Then                           'catch last argument or Vars
    If IsPureImmaginary(SubExpr, RetVal) Then     'check if argument is pure immaginary
      ET(ETtop).Arg(ET(ETtop).ArgTop).Value.reel = 0    'AdG 10/12/2002
      ET(ETtop).Arg(ET(ETtop).ArgTop).Value.imag = RetVal
    ElseIf convEGU(SubExpr, RetVal) Then              'check if argument is Eng Units
      ET(ETtop).Arg(ET(ETtop).ArgTop).Value.reel = RetVal
      ET(ETtop).Arg(ET(ETtop).ArgTop).Value.imag = 0    'AdG 10/12/2002
'      ElseIf LCase$(SubExpr) = "pi" Then           'check if argument is PI
    ElseIf convSymbConst(SubExpr, RetVal) Then      'check if argument is a symbolic constant #
      If Len(ErrMsg) <> 0 Then GoTo ErrHandler
        
      ET(ETtop).Arg(ET(ETtop).ArgTop).Value.reel = RetVal
      ET(ETtop).Arg(ET(ETtop).ArgTop).Value.imag = 0
    ElseIf IsNumeric_(SubExpr) Then                'check if argument is number
      ET(ETtop).Arg(ET(ETtop).ArgTop).Value.reel = SubExpr
      ET(ETtop).Arg(ET(ETtop).ArgTop).Value.imag = 0
    Else
'        If Not IsLetter(Left$(SubExpr, 1)) Then
      If IsNumeric(Left$(SubExpr, 1)) Then
        ErrMsg = "variable name must start with a letter: " & SubExpr
        GoTo ErrHandler
      End If
      If Not CaseSen Then SubExpr = LCase$(SubExpr)
      StoreVar SubExpr, True
      If VTtop > HiVT Then
        ErrMsg = "too many Vars"
        GoTo ErrHandler
      End If
    End If
  Else
    'bug 7.10.03 last argument missing 3+ or Sin() ...  thanks to Rodigro Farinha
    ErrMsg = "missing argument"
    GoTo ErrHandler
  End If
  
  If ETtop > 0 Then
    ReDim Preserve ET(0 To ETtop)
  Else
    ReDim Preserve ET(0 To 0)
  End If
  If VTtop > 0 Then
    ReDim Preserve VT(0 To VTtop)
  Else
    ReDim Preserve VT(0 To 0)
  End If
#If DEBUG_MODE = 3 Or DEBUG_MODE = 10 Then
ET_Dump 3
#End If
  ReDim arrPriLvl(0 To ETtop)                     'create array with priority levels
  For i = 1 To ETtop                              'and copy then from main array
    arrPriLvl(i) = ET(i).PriLvl
  Next
  For i = 1 To ETtop                              'fill sort order default 0 to ETtop
    ET(i).PriIdx = i
  Next
  srtLo = 1                                       '***** start sort algorithm
  srtHi = ETtop - 1
  Do
    Flag_exchanged = False
    For i = srtLo To srtHi Step 2
      j = i + 1
      If arrPriLvl(i) < arrPriLvl(j) Then
        tmp = arrPriLvl(j)
        arrPriLvl(j) = arrPriLvl(i)
        arrPriLvl(i) = tmp
        tmp = ET(j).PriIdx
        ET(j).PriIdx = ET(i).PriIdx
        ET(i).PriIdx = tmp
        Flag_exchanged = True
      End If
    Next
    If srtLo = 1 Then
      srtLo = 2
    Else
      srtLo = 1
    End If
  Loop Until (srtLo = 1) And Not Flag_exchanged
  #If DEBUG_MODE = 4 Or DEBUG_MODE = 10 Then
  ET_Dump 4
  #End If
  For i = 1 To ETtop                              'build relations
    j = ET(i).PriIdx
    j1 = j - 1
    Do While j1 >= 0
      If ET(j1).ArgOf = 0 Then
        Exit Do
      End If
      j1 = j1 - 1
    Loop
    j2 = j + 1
    Do While j2 <= ETtop
      If ET(j2).ArgOf = 0 Then
        Exit Do
      End If
      j2 = j2 + 1
    Loop
    If j1 < 1 And j2 <= ETtop Then            '
      ET(j).ArgOf = j2
      ET(j).ArgIdx = 1
    ElseIf j1 > 0 And j2 > ETtop Then        '
      ET(j).ArgOf = j1
      ET(j).ArgIdx = ET(j1).ArgTop
    ElseIf j1 > 0 And j2 <= ETtop Then       '
      If ET(j1).PriLvl >= ET(j2).PriLvl Then  'take that one with the upper PriLvl
        ET(j).ArgOf = j1
        ET(j).ArgIdx = ET(j1).ArgTop
      Else                                        '
        ET(j).ArgOf = j2
        ET(j).ArgIdx = 1
      End If
    Else
      Exit For
    End If
  Next
#If DEBUG_MODE = 5 Or DEBUG_MODE = 10 Then
ET_Dump 5
#End If
  For i = 1 To ETtop                              'eliminate dependent arguments
    j = ET(i).ArgOf
    If j > 0 Then
      With ET(j).Arg(ET(i).ArgIdx)
       .idx = 0
       .Name = vbNullString
      End With
    End If
  Next
#If DEBUG_MODE = 6 Or DEBUG_MODE = 10 Then
ET_Dump 6
#End If
'*********************************************************************
'*                                                                   *
'* Gestion des fonctions \xe0 plus de 2 variables
Dim fctId As Integer
Dim k As Integer
Dim VarID As Integer
Dim VarFound As Boolean

 For i = 1 To ETtop
    fctId = ET(i).NVarId
    If fctId > 0 Then
        VarID = 3 'traitement de la 3\xe8me variable
        ' recherche dans lignes suivantes de la m\xeame fonction
        For j = i + 1 To ETtop
            If ET(j).NVarId = fctId Then
                VarFound = False
                For k = 1 To ETtop
                    If ET(k).ArgOf = j And ET(k).NVarId <> fctId And ET(k).NVarId <> -1 Then
                        'la variable est le r\xe9sultat d'une autre ligne
                        VarFound = True
                        ET(k).ArgOf = i
                        ET(k).ArgIdx = VarID
                    End If
                Next
                If VarFound = False Then
                    ' la variable est une constante ou une variable
                    ET(i).Arg(VarID).idx = ET(j).Arg(2).idx
                    ET(i).Arg(VarID).Name = ET(j).Arg(2).Name
                    ET(i).Arg(VarID).Value = ET(j).Arg(2).Value
                End If
                ET(j).NVarId = -1
                ET(i).ArgOf = ET(j).ArgOf
                ET(i).ArgIdx = ET(j).ArgIdx
                ET(i).ArgTop = VarID
                VarID = VarID + 1
            End If
        Next
    End If
 Next
 #If DEBUG_MODE = 7 Or DEBUG_MODE = 10 Then
 ET_Dump 7
 #End If
 ' supression des lignes inutiles
 j = 1
 For i = 1 To ETtop
    ET(j) = ET(i)
    For k = 1 To ETtop
        If ET(k).ArgOf = i Then
            ET(k).ArgOf = j
        End If
    Next
    If ET(i).NVarId <> -1 Then j = j + 1
 Next
 ETtop = j - 1
 
 #If DEBUG_MODE = 8 Or DEBUG_MODE = 10 Then
 ET_Dump 8
 #End If
' trie des priorit\xe9s
  ReDim arrPriLvl(0 To ETtop)                     'create array with priority levels
  For i = 1 To ETtop                              'and copy then from main array
    arrPriLvl(i) = ET(i).PriLvl
  Next
  For i = 1 To ETtop                              'fill sort order default 0 to ETtop
    ET(i).PriIdx = i
  Next
  srtLo = 1                                       '***** start sort algorithm
  srtHi = ETtop - 1
  Do
    Flag_exchanged = False
    For i = srtLo To srtHi Step 2
      j = i + 1
      If arrPriLvl(i) < arrPriLvl(j) Then
        tmp = arrPriLvl(j)
        arrPriLvl(j) = arrPriLvl(i)
        arrPriLvl(i) = tmp
        tmp = ET(j).PriIdx
        ET(j).PriIdx = ET(i).PriIdx
        ET(i).PriIdx = tmp
        Flag_exchanged = True
      End If
    Next
    If srtLo = 1 Then
      srtLo = 2
    Else
      srtLo = 1
    End If
  Loop Until (srtLo = 1) And Not Flag_exchanged
  #If DEBUG_MODE = 9 Or DEBUG_MODE = 10 Then
  ET_Dump 9
  #End If
'*                                                                   *
'*********************************************************************
  Parse = True
  Exit Function
ErrHandler:
  ETtop = ETtop
  Parse = False
End Function

' translate a symbolic Constant to its double value
Private Function convSymbConst(strSource$, RetVal) As Boolean
  Const CostToken$ = "#"
  ErrMsg = vbNullString
  If Right$(strSource, 1) <> CostToken Then
    If LCase$(strSource) <> "pi" Then Exit Function
    RetVal = Pi_ 'check if string is "pi" only for compatibility with previous release.
  Else
    Select Case LCase$(Left$(strSource, Len(strSource) - 1))
      Case "pi":  RetVal = Pi_                    'pi-greek
      Case "pi2": RetVal = Pi2_                   'pi-greek/2
      Case "pix2": RetVal = TPi_                  '2*pi-greek
      Case "pi3": RetVal = Pi_ / 3                'pi-greek/3
      Case "pi4": RetVal = Pi4_                   'pi-greek/4
      Case "eu":  RetVal = dEu_                   'Euler-Mascheroni
      Case "e":   RetVal = dE_                    'Euler-Napier
      Case "ln2": RetVal = dLn2_                  'Natural Log 2
      Case "ln10": RetVal = dLn10_                'Natural Log 10
      Case "rad5": RetVal = dRad5_                'Square Root of 5
      Case Else
          ErrMsg = "Constant unknown: " & Left$(strSource, Len(strSource) - 1)
    End Select
  End If
  convSymbConst = True
End Function

Private Function CheckExpo(SubExpr$) As Boolean
Dim s_1$, s_2$, ls As Long
'detect if SubExpr is the mantissa of an expo format number 1.2E+01 , 4E-12, 1.0E-6
    CheckExpo = False
    ls = Len(SubExpr)
    If ls < 2 Then Exit Function
    s_1 = Right$(SubExpr, 1)
    s_2 = Left$(SubExpr, ls - 1)
    If UCase$(s_1) = "E" Then If IsNumeric_(s_2) Then CheckExpo = True
End Function

'[modified 10/02 by Thomas Zeutschler]
Private Function Eval_(EvalValue As complexe) As Boolean
  Dim a(1 To HiARG) As complexe
  Dim s(1 To HiARG) As String
  Dim ris   As complexe
  Dim j     As Long
  Dim k     As Long
  Dim pos   As Long
  Dim l     As Integer
  Dim m     As Long
  Dim n     As Long
  Dim idx   As Integer
  
  On Error GoTo ErrHandler  '<<< comment for debug  VL 30-8-02
  setAngleOption ("Rad")
  For j = 1 To ETtop    'Evaluation procedure begins
    k = ET(j).PriIdx
    With ET(k)
      For l = 1 To HiARG
        a(l) = .Arg(l).Value
        s(l) = .Arg(l).Name
      Next
      initErrorMsg
      
      Select Case .FunTok
            'Operation
            Case OffsetOper To OffsetOper + 99
                For idx = 1 To 2
                    If Len(s(idx)) <> 0 Then
                        If Left$(s(idx), 1) = ElementChaine Then
                            ErrMsg = "Invalid Arg " & CStr(idx) & " in function <" & CStr(.FunTok) & ">"
                            GoTo ErrHandler
                        End If
                    End If
                Next
                ris = ComplexOperation(a(1), a(2), .FunTok)
            'Functions
            Case OffsetFunc To OffsetFunc + 99
                If Len(s(1)) <> 0 Then
                    If Left$(s(1), 1) = ElementChaine Then
                        ErrMsg = "Invalid Arg 1 in function <" & CStr(.FunTok) & ">"
                        GoTo ErrHandler
                    End If
                End If
                ris = ComplexFunction(a(1), .FunTok)
            'Functions N variables
            Case OffsetNVar To OffsetNVar + 99
                ris = ComplexFunctionNVar(a(), s(), .FunTok)
            Case Else
                ErrMsg = "Function <" & CStr(.FunTok) & "> missing?"  'VL
                GoTo ErrHandler
      End Select
      If Len(getErrorMsg) <> 0 Then
        ErrMsg = getErrorMsg
        GoTo ErrHandler
      End If
      .Value = ris
      m = .ArgOf
      n = .ArgIdx
      If m = 0 Or n = 0 Then Exit For
      ET(m).Arg(n).Value = ris
    End With
  Next
  If Len(getErrorMsg) <> 0 Then
     ErrMsg = getErrorMsg
     GoTo ErrHandler                        'Arnaud d. G. 6-12-02
  End If
  EvalValue = ET(k).Value
  Eval_ = True
  Exit Function
ErrHandler:
  'ErrMsg = "Evaluation error"  'VL         'Arnaud d. G. 6-12-02
  EvalValue.reel = 0
  EvalValue.imag = 0
  Eval_ = False
End Function

' Assignes a value to symbolic Vars
Private Sub SubstVars(VarValue#())
  Dim i  As Long
  Dim j  As Long
  Dim id As Long
    
  For i = 1 To ETtop
    For j = 1 To HiARG
      id = ET(i).Arg(j).idx
      If id <> 0 Then
        ET(i).Arg(j).Value.reel = VarValue(id)
        ET(i).Arg(j).Value.imag = 0
      End If
    Next
  Next
End Sub
Private Sub SubstVarsImag(VarValue#())
  Dim i  As Long
  Dim j  As Long
  Dim id As Long
    
  For i = 1 To ETtop
    For j = 1 To HiARG
      id = ET(i).Arg(j).idx
      If id <> 0 Then
        ET(i).Arg(j).Value.imag = VarValue(id)
      End If
    Next
  Next
End Sub

' search if var already exists in table, if not add it
Private Sub StoreVar(SubExpr$, ByVal LastArg As Boolean)
  Dim VTIdx  As Long
  Dim ArgIdx As Long
  Dim Found  As Boolean
    
  Found = False
  If Not CaseSen Then SubExpr = LCase$(SubExpr)
  For VTIdx = 1 To VTtop
    If VT(VTIdx).Name = SubExpr Then
      Found = True
      Exit For
    End If
  Next
  If Not Found Then
    VTtop = VTtop + 1     'new variable
    If VTtop > HiVT Then  'to many Vars
      Exit Sub
    End If
    VT(VTtop).Name = SubExpr
  End If
  If LastArg Then
    ArgIdx = ET(ETtop).ArgTop
  Else
    ArgIdx = 1
  End If
  With ET(ETtop).Arg(ArgIdx)
    .Name = SubExpr
    .idx = VTIdx
  End With
End Sub


' translate egu to multiplication factor
'  accepts a string contains a measure like "2ms" ,"234.12Mhz", "0.1uF" , 12Km , etc
'  [relaxed parsing: allow space between number and unit and allow numbers without units]
Private Function convEGU(strSource$, RetVal#) As Boolean
  Dim EguStr   As String
  Dim EguStart As Long
  Dim EguLen   As Long
  Dim EguMult  As String
  Dim EguCoeff As Double
  Dim EguFact  As Long
  Dim EguSym   As String
  Dim EguBase  As Double
    
  EguStr = strSource      'trim niet nodig; alle spaties zijn weg
  EguLen = Len(EguStr)
  For EguStart = 1 To EguLen
    If IsLetter(Mid$(EguStr, EguStart, 1)) Then Exit For
  Next
  If EguStart = 1 Then
'    Debug.Print "missing coefficient"
    convEGU = False
    Exit Function
  ElseIf EguStart > EguLen Then
'    Debug.Print "missing unit of measure"
    convEGU = False
    Exit Function
  End If
  EguCoeff = Left$(EguStr, EguStart - 1)   'get number
  EguStr = Mid$(EguStr, EguStart)          'extract literal substring
  EguLen = Len(EguStr)
  If EguLen > 1 Then                      'extract multiply factor
    EguMult = Left$(EguStr, 1)
    Select Case EguMult
      Case "p":  EguFact = -12
      Case "n":  EguFact = -9
      Case "u":  EguFact = -6
      Case "m":  EguFact = -3
      Case "c":  EguFact = -2
      Case "d":  EguFact = -1
      Case "D":  EguFact = 1
      Case "H":  EguFact = 2
      Case "K":  EguFact = 3
      Case "M":  EguFact = 6
      Case "G":  EguFact = 9
      Case "T":  EguFact = 12
      Case Else: EguFact = 0
    End Select
  Else
    EguFact = 0
  End If
  If EguFact <> 0 Then       'extract um symbol
    EguSym = Mid$(EguStr, 2)
  End If
  Select Case EguSym         'check if um exists and compute numeric value
    Case "s":   EguBase = 1                 'second
    Case "Hz":  EguBase = 1                 'frequency
    Case "m":   EguBase = 1                 'meter
    Case "g":   EguBase = 0.001             'gramme
    Case "rad", "Rad", "RAD": EguBase = 1   'radiant  '18-10-02 VL
    Case "S":   EguBase = 1                 'siemens
    Case "V":   EguBase = 1                 'volt
    Case "A":   EguBase = 1                 'ampere
    Case "W":   EguBase = 1                 'watt
    Case "F":   EguBase = 1                 'farad
    Case "bar": EguBase = 1                 'bar
    Case "Pa":  EguBase = 1                 'pascal
    Case "Nm":  EguBase = 1                 'newtonmeter
    Case "Ohm", "ohm": EguBase = 1          'ohm     '18-10-02 VL
    Case Else
      ErrMsg = "unknown unit of measure: " & EguSym
      convEGU = False
      Exit Function
  End Select
  RetVal = EguCoeff * EguBase * 10 ^ EguFact   'finally compute the numeric value
  convEGU = True
End Function

'check if it is a number
Private Function IsNumeric_(a$) As Boolean
  Dim x#
  On Error GoTo EH
  x = a 'assign "a" to a double
  IsNumeric_ = True
EH:
End Function

'check if it is a letter
Private Function IsLetter(ByVal char$) As Boolean
  Dim code As Integer
    
  code = Asc(char)
  'IsLetter = (65 <= code And code <= 90) Or (97 <= code And code <= 122)
  '*********************************************************************************
  IsLetter = (65 <= code And code <= 90) Or (97 <= code And code <= 122) Or char = ElementChaine
  '*********************************************************************************
End Function

'check for an expression to occur in a list
Private Function InList(strElem$, strList$) As Boolean
  InList = InStr(strList, LCase$(" " & strElem & " "))
End Function

' count number of abs sybol sets in formula
Private Function NabsCount(s$) As Long
  Dim n As Long
  Dim p As Long

  n = 0
  p = InStr(s, "|")
  Do While p > 0
    p = p + 1
    n = n + 1
    p = InStr(p, s, "|")
  Loop
  NabsCount = n
End Function

' check if a string may be a pure immaginary number.
Private Function IsPureImmaginary(strSource$, RetVal#) As Boolean
Dim Temp As String
    If Right$(strSource, 1) <> "i" Then If Right$(strSource, 1) <> "j" Then Exit Function
    Temp = (Left$(strSource, Len(strSource) - 1))
    If Temp = "-" Then Temp = vbStrN1
    If Temp = "+" Or Len(Temp) = 0 Then Temp = "+1"
    If IsNumeric_(Temp) Then     'may be a complex-immaginary number Es  2i or 1.33j
        RetVal = Temp       'fix bug 14.9.06
        IsPureImmaginary = True
    End If
End Function


' dump table to immediate window
#If DEBUG_MODE > 0 Then
Sub ET_Dump(Level)
  Dim i As Long
    
  Debug.Print String$(80, "-")
  Debug.Print "Dump Level " & CStr(Level)
  Debug.Print "Id", "Fun", "ArgTop", "NVarId" _
              ; "A0 Idx", "Arg0 Name", "Arg0 Value r", "Arg0 Value i" _
              ; "A1 Idx", "Arg1 Name", "Arg1 Value r", "Arg1 Value i" _
              ; "A2 Idx", "Arg2 Name", "Arg2 Value r", "Arg2 Value i" _
              ; "A3 Idx", "Arg3 Name", "Arg3 Value r", "Arg3 Value i" _
              ; "ArgOf", "ArgIdx", "Value", "PriLvl", "PosInExpr", "PriIdx"
  For i = 1 To ETtop
    With ET(i)
      Debug.Print i, .Fun, .ArgTop, .NVarId, _
            .Arg(1).idx, .Arg(1).Name, .Arg(1).Value.reel, .Arg(1).Value.imag, _
            .Arg(2).idx, .Arg(2).Name, .Arg(2).Value.reel, .Arg(2).Value.imag, _
            .Arg(3).idx, .Arg(3).Name, .Arg(3).Value.reel, .Arg(3).Value.imag, _
            .Arg(4).idx, .Arg(4).Name, .Arg(4).Value.reel, .Arg(4).Value.imag, _
            .ArgOf, .ArgIdx, .Value.reel, .PriLvl, .PosInExpr, .PriIdx
    End With
  Next
End Sub

#End If

Private Function getAngleOption() As String
    getAngleOption = AngleOption
End Function

Private Sub setAngleOption(Value$)
    AngleOption = Value
End Sub

Private Function getErrorMsg() As String
    getErrorMsg = ErrorMsg
End Function

Private Function setErrorMsg(error$)
    ErrorMsg = Error
End Function

Private Sub initErrorMsg()
    ErrorMsg = vbNullString
End Sub

Private Function GetFunTok(FunTok$) As Long
  Select Case LCase$(FunTok)
    Case "+"
        GetFunTok = symPlus
    Case "-"
        GetFunTok = symMinus
    Case "*"
        GetFunTok = symMul
    Case "/"
        GetFunTok = symDiv
    Case "%"
        GetFunTok = symModulo
    Case "\"
        GetFunTok = symDivInt
    Case "^"
        GetFunTok = symPov
    Case "abs"
        GetFunTok = symAbs
    Case "atn", "atan"
        GetFunTok = symAtn
    Case "cos"
        GetFunTok = symCos
    Case "sin"
        GetFunTok = symSin
    Case "exp"
        GetFunTok = symExp
    Case "fix"
        GetFunTok = symFix
    Case "int"
        GetFunTok = symInt
    Case "ln"
        GetFunTok = symLn
    Case "log"
        GetFunTok = symLog
    Case "rnd"
        GetFunTok = symRnd
    Case "sgn"
        GetFunTok = symSgn
    Case "sqr", "sqrt"
        GetFunTok = symSqr
    Case "tan"
        GetFunTok = symTan
    Case "acos"
        GetFunTok = symAcos
    Case "asin"
        GetFunTok = symAsin
    Case "cosh"
        GetFunTok = symCosh
    Case "sinh"
        GetFunTok = symSinh
    Case "tanh"
        GetFunTok = symTanh
    Case "acosh"
        GetFunTok = symAcosh
    Case "asinh"
        GetFunTok = symAsinh
    Case "atanh"
        GetFunTok = symAtanh
    Case "mod"
        GetFunTok = symMod
    Case "fact", "!"
        GetFunTok = symFact
    Case "comb"
        GetFunTok = symComb
    Case "min"
        GetFunTok = symMin
    Case "max"
        GetFunTok = symMax
    Case "mcd"
        GetFunTok = symMcd
    Case "mcm"
        GetFunTok = symMcm
    Case ">"
        GetFunTok = symGT
    Case ">=", "=>"
        GetFunTok = symGE
    Case "<"
        GetFunTok = symLT
    Case "<=", "=<"
        GetFunTok = symLE
    Case "="
        GetFunTok = symEQ
    Case "<>"
        GetFunTok = symNE
    Case "and"
        GetFunTok = symAnd
    Case "or"
        GetFunTok = symOr
    Case "not"
        GetFunTok = symNot
    Case "xor"
        GetFunTok = symXor
    Case "erf"
        GetFunTok = symErf
    Case "gamma"
        GetFunTok = symGamma
    Case "gammaln"
        GetFunTok = symGammaln
    Case "digamma", "psi"
        GetFunTok = symDigamma
    Case "beta"
        GetFunTok = symBeta
    Case "zeta"
        GetFunTok = symZeta
    Case "ei"
        GetFunTok = symEi
    Case ArgSep
        GetFunTok = symR2C
    Case "inv"
        GetFunTok = symInv
    Case "root"
        GetFunTok = symXroot
    Case "alog"
        GetFunTok = symAlog
    Case "neg"
        GetFunTok = symNeg
    Case "arg"
        GetFunTok = symArg
    Case "r2c"
        GetFunTok = symR2C
    Case "re"
        GetFunTok = symReel
    Case "im"
        GetFunTok = symImag
    Case "erfc"
        GetFunTok = symErfC
    Case "conj"
        GetFunTok = symConj
    Case "sq"
        GetFunTok = symSQ
    Case "integral"
        GetFunTok = symInteg
    Case "serie"
        GetFunTok = symSerie
    Case Else
        GetFunTok = symARGUMENT
    End Select
End Function

Private Function EnRad(rad#) As Double
    If AngleOption = "Deg" Then
        EnRad = rad * Pi_180
    Else
        EnRad = rad
    End If
End Function

Private Function EnDeg(rad#) As Double
    If AngleOption = "Deg" Then
        EnDeg = rad / Pi_180
    Else
        EnDeg = rad
    End If
End Function

Private Function ComplexOperation(a As complexe, b As complexe, Name&) As complexe
    Dim res As complexe
    Select Case Name
            Case symPlus
                res = Plus(a, b)
            Case symMinus
                res = moins(a, b)
            Case symMul
                res = fois(a, b)
            Case symDiv
                res = divis(a, b)
            Case symDivInt
                res = divis_entiere(a, b)
            Case symModulo, symMod
                res = MODULO(a, b)
            Case symPov
                res = expos(a, b)
            Case symXroot
                res = invexposant(a, b)
            Case symMin
                res = minimum(a, b)
            Case symMax
                res = maximum(a, b)
            Case symComb
                res = combinatoire(a, b)
            Case symMcm
                res = PPCM(a, b)
            Case symMcd
                res = PGCD(a, b)
            Case symBeta
                res = betaC(a, b)
            Case symR2C
                res = r2c(a, b)
            Case symEQ  '=
                If a.reel = b.reel And a.imag = b.imag Then
                    res.reel = 1
                Else
                    res.reel = 0
                End If
            Case symNE  '<>
                If a.reel <> b.reel Or a.imag <> b.imag Then
                    res.reel = 1
                Else
                    res.reel = 0
                End If
            Case symGT  '>
                If a.imag = 0 And b.imag = 0 Then
                    If a.reel > b.reel Then
                        res.reel = 1
                    Else
                        res.reel = 0
                    End If
                Else
                    ErrorMsg = "Bad Argument Type"
                End If
            Case symLT  '<
                If a.imag = 0 And b.imag = 0 Then
                    If a.reel < b.reel Then
                        res.reel = 1
                    Else
                        res.reel = 0
                    End If
                Else
                    ErrorMsg = "Bad Argument Type"
                End If
            Case symGE  '>=
                If a.imag = 0 And b.imag = 0 Then
                    If a.reel >= b.reel Then
                        res.reel = 1
                    Else
                        res.reel = 0
                    End If
                Else
                    ErrorMsg = "Bad Argument Type"
                End If
            Case symLE  '<=
                If a.imag = 0 And b.imag = 0 Then
                    If a.reel <= b.reel Then
                        res.reel = 1
                    Else
                        res.reel = 0
                    End If
                Else
                    ErrorMsg = "Bad Argument Type"
                End If
            Case symAnd 'And
                If a.imag = 0 And b.imag = 0 Then
                    If a.reel <> 0 And b.reel <> 0 Then
                        res.reel = 1
                    Else
                        res.reel = 0
                    End If
                Else
                    ErrorMsg = "Bad Argument Type"
                End If
            Case symOr 'Or
                If a.imag = 0 And b.imag = 0 Then
                    If a.reel <> 0 Or b.reel <> 0 Then
                        res.reel = 1
                    Else
                        res.reel = 0
                    End If
                Else
                    ErrorMsg = "Bad Argument Type"
                End If
            Case symXor 'Xor
                If a.imag = 0 And b.imag = 0 Then
                    If (a.reel = 0 And b.reel <> 0) Or (a.reel <> 0 And b.reel = 0) Then
                        res.reel = 1
                    Else
                        res.reel = 0
                    End If
                Else
                    ErrorMsg = "Bad Argument Type"
                End If
            Case Else
                ErrorMsg = "Function <" & Name & "> missing?"
            End Select
        ComplexOperation = res
End Function

Private Function ComplexFunction(x As complexe, Name&) As complexe
    Dim y As complexe
            Select Case Name
                Case symSin
                    If x.imag = 0 Then x.reel = EnRad(x.reel)
                    y = sinus(x)
                Case symCos
                    If x.imag = 0 Then x.reel = EnRad(x.reel)
                    y = cosinus(x)
                Case symTan
                    If x.imag = 0 Then x.reel = EnRad(x.reel)
                    y = tangente(x)
                Case symAsin
                    y = asinus(x)
                    If y.imag = 0 Then y.reel = EnDeg(y.reel)
                Case symAcos
                    y = acosinus(x)
                    If y.imag = 0 Then y.reel = EnDeg(y.reel)
                Case symAtn
                    y = atangente(x)
                    If y.imag = 0 Then y.reel = EnDeg(y.reel)
                Case symSinh
                    y = Sh(x)
                Case symCosh
                    y = ch(x)
                Case symTanh
                    y = th(x)
                Case symAsinh
                    y = ash(x)
                Case symAcosh
                    y = ach(x)
                Case symAtanh
                    y = ath(x)
                Case symAbs
                    y = absol(x)
                Case symArg
                    y = argum(x)
                    If y.imag = 0 Then y.reel = EnDeg(y.reel)
                Case symSQ
                    y = fois(x, x)
                Case symSqr
                    y = Racine(x)
                Case symInv
                    y = Inv(x)
                Case symLn
                    y = Ln(x)
                Case symExp
                    y = e(x)
                Case symLog
                    y = Log10(x)
                Case symAlog
                    y = exp10(x)
                Case symFact
                    y = factorielle(x)
                Case symSgn
                    y = signe(x)
                Case symGamma
                    y = GammaC(x)
                Case symGammaln
                    y = GammaLnC(x)
                Case symDigamma
                    sDiGamma y.reel, y.imag, x.reel, x.imag
                Case symEi
                    y = fctExpIntegral(x)
                Case symErf
                    y = fctErf(x)
                Case symErfC
                    y = ErfC(x)
                Case symZeta
                    y = fctZeta(x)
                Case symImag
                    y = Im(x)
                Case symReel
                    y = Re(x)
                Case symConj
                    y = Conj(x)
                Case symNeg
                    y = opp(x)
                Case symFix
                    y = fctFIX(x)
                Case symInt
                    y = fctINT(x)
                Case symRnd
                    y = fctRND(x)
                Case symNot
                    y = NotFunction(x)
                Case Else
                    ErrorMsg = "Function <" & Name & "> missing?"
        End Select
        ComplexFunction = y
End Function

Private Function NotFunction(a As complexe) As complexe
    If a.imag = 0 Then
        If a.reel = 0 Then NotFunction.reel = 1
    Else
        ErrorMsg = "Bad Argument Type"
    End If
End Function

Private Function r2c(a As complexe, b As complexe) As complexe
    If a.imag = 0 And b.imag = 0 Then
        r2c.reel = a.reel
        r2c.imag = b.reel
    Else
        ErrorMsg = "Bad Argument Type"
    End If
End Function

Private Function Ln(x As complexe) As complexe
        If x.reel = 0 And x.imag = 0 Then
                ErrorMsg = InfRslt
                Ln = x
        ElseIf x.imag = 0 And x.reel > 0 Then
                Ln.reel = Log(x.reel)
        Else
                Ln.reel = Log(absol(x).reel)
                Ln.imag = argum(x).reel
        End If
End Function

 Private Function Log10(x As complexe) As complexe
    Dim ln10 As complexe
    If x.reel = 0 And x.imag = 0 Then
        ErrorMsg = InfRslt
        Log10 = x
    ElseIf x.imag = 0 And x.reel > 0 Then
        Log10.reel = Log(x.reel) / dLn10_
    Else
        ln10.reel = dLn10_
        Log10 = divis(Ln(x), ln10)
    End If
End Function

Private Function exp10(x As complexe) As complexe
    Dim ln10 As complexe
    If x.imag = 0 Then
        exp10.reel = 10 ^ x.reel
    Else
        ln10.reel = dLn10_
        exp10 = e(fois(x, ln10))
    End If
End Function

Private Function Racine(x As complexe) As complexe
    If x.reel = 0 Then If x.imag = 0 Then Exit Function
    If x.imag = 0 Then If x.reel > 0 Then Racine.reel = Sqr(x.reel): Exit Function
    Racine = e(divisb(Ln(x), 2))
End Function

Private Function Inv(x As complexe) As complexe
  If x.imag = 0 Then
    If x.reel = 0 Then
      Inv = x
      ErrorMsg = InfRslt
    Else
      Inv.reel = 1 / x.reel
    End If
  Else
    Inv = divis(un, x)
  End If
End Function

Private Function signe(x As complexe) As complexe
    If x.reel = 0 Then If x.imag = 0 Then Exit Function
    If x.imag = 0 Then
        If x.reel > 0 Then signe.reel = 1 Else signe.reel = -1
    Else
        signe.reel = x.reel / absol(x).reel
        signe.imag = x.imag / absol(x).reel
    End If
End Function

Private Function Re(x As complexe) As complexe
    Re.reel = x.reel
End Function

Private Function Im(x As complexe) As complexe
    Im.reel = x.imag
End Function

Private Function Conj(x As complexe) As complexe
    Conj.reel = x.reel
    Conj.imag = -x.imag
End Function

Private Function absol(x As complexe) As complexe
On Error GoTo Error_Msg
Dim a#, b#
a = Abs(x.reel)
b = Abs(x.imag)
If b = 0 Then
    absol.reel = a
ElseIf a = 0 Then
    absol.reel = b
ElseIf a > b Then
    absol.reel = a * Sqr(1 + (b / a) ^ 2)
Else
    absol.reel = b * Sqr(1 + (a / b) ^ 2)
'    absol.reel = Sqr(x.reel * x.reel + x.imag * x.imag)
End If
Exit Function
Error_Msg:
    Select Case Err
        Case 6: ErrorMsg = OvrFlo
            absol = x
    End Select
    Resume Next
End Function

Private Function argum(x As complexe) As complexe
On Error GoTo Error_Msg
    If x.reel = 0 Then
        If x.imag < 0 Then
            argum.reel = -Pi2_
        ElseIf x.imag > 0 Then
            argum.reel = Pi2_
        End If
    ElseIf x.reel > 0 Then
        argum.reel = Atn(x.imag / x.reel)
    Else
        If x.imag < 0 Then
            argum.reel = Atn(x.imag / x.reel) - Pi_
        ElseIf x.imag > 0 Then
            argum.reel = Atn(x.imag / x.reel) + Pi_
        Else
            argum.reel = Pi_
        End If
    End If
Exit Function
Error_Msg:
    Select Case Err
        Case 6: ErrorMsg = OvrFlo
            argum = x
    End Select
    Resume Next
End Function

Private Function e(x As complexe) As complexe
On Error GoTo Error_Msg
e.reel = Exp(x.reel)
If x.imag = 0 Then Exit Function
e.imag = e.reel * Sin(x.imag)
e.reel = e.reel * Cos(x.imag)
Exit Function
Error_Msg:
    Select Case Err
        Case 6: ErrorMsg = OvrFlo
            e = x
    End Select
    Resume Next
End Function

Private Function Plus(a As complexe, b As complexe) As complexe
On Error GoTo Error_Msg
    Plus.reel = a.reel + b.reel
    Plus.imag = a.imag + b.imag
Exit Function
Error_Msg:
    Select Case Err
        Case 6: ErrorMsg = OvrFlo
            Plus = a
    End Select
    Resume Next
End Function

Private Function moins(a As complexe, b As complexe) As complexe
On Error GoTo Error_Msg
    moins.reel = a.reel - b.reel
    moins.imag = a.imag - b.imag
Exit Function
Error_Msg:
    Select Case Err
        Case 6: ErrorMsg = OvrFlo
            moins = a
    End Select
    Resume Next
End Function

Private Function fois(a As complexe, b As complexe) As complexe
On Error GoTo Error_Msg
If b.imag <> 0 Then
  fois.reel = a.reel * b.reel - a.imag * b.imag
  fois.imag = a.reel * b.imag + a.imag * b.reel: Exit Function
Else
  fois.reel = a.reel * b.reel
  fois.imag = a.imag * b.reel: Exit Function
End If
Exit Function
Error_Msg:
    Select Case Err
        Case 6: ErrorMsg = OvrFlo
        fois = a
    End Select
    Resume Next
End Function

Private Function divisb(a As complexe, b) As complexe
divisb.reel = a.reel / b
divisb.imag = a.imag / b
End Function

Private Function divis(a As complexe, b As complexe) As complexe
Dim Den#
On Error GoTo Error_Msg
If Abs(b.reel) >= Abs(b.imag) Then
  divis.imag = b.imag / b.reel
  Den = b.reel + divis.imag * b.imag
  divis.reel = (a.reel + divis.imag * a.imag) / Den
  divis.imag = (a.imag - divis.imag * a.reel) / Den
Else
  divis.imag = b.reel / b.imag
  Den = b.imag + divis.imag * b.reel
  divis.reel = (a.reel * divis.imag + a.imag) / Den
  divis.imag = (a.imag * divis.imag - a.reel) / Den
End If
'If b.reel = 0 Then If b.imag = 0 Then ErrorMsg = InfRslt: divis = b: Exit Function
'If a.imag = 0 Then If b.imag = 0 Then divis.reel = a.reel / b.reel: Exit Function
'divis.imag = b.reel * b.reel + b.imag * b.imag
'divis.reel = (a.reel * b.reel + a.imag * b.imag) / divis.imag
'divis.imag = (a.imag * b.reel - a.reel * b.imag) / divis.imag
Exit Function
Error_Msg:
    Select Case Err
        Case 6: ErrorMsg = OvrFlo
            divis = b
    End Select
    Resume Next
End Function

Private Function expos(a As complexe, b As complexe) As complexe
On Error GoTo Error_Msg
        If b.reel = 0 And b.imag = 0 Then
                expos = un
        ElseIf a.reel = 0 And a.imag = 0 Then
                expos = a
        Else
          If a.imag = 0 Then If b.imag = 0 Then expos.reel = a.reel ^ b.reel: Exit Function
          expos = e(fois(b, Ln(a)))
        End If
Exit Function
Error_Msg:
    Select Case Err
        Case 6: ErrorMsg = OvrFlo
            expos = a
    End Select
    Resume Next
End Function

Private Function invexposant(a As complexe, b As complexe) As complexe
On Error GoTo Error_Msg
        If a.reel = 0 And a.imag = 0 Then
                invexposant = a
        Else
                If b.reel = 0 And b.imag = 0 = 0 Then
                        ErrorMsg = "Undefined Result"
                        invexposant = b
                Else
                    If a.imag = 0 And b.imag = 0 Then
                        invexposant.reel = a.reel ^ (1 / b.reel)
                    Else
                        invexposant = e(fois(divis(un, b), Ln(a)))
                    End If
                End If
        End If
Exit Function
Error_Msg:
    Select Case Err
        Case 6: ErrorMsg = OvrFlo
            invexposant = a
    End Select
    Resume Next
End Function

Private Function sinus(x As complexe) As complexe
If x.imag = 0 Then
  sinus.reel = Sin(x.reel)
Else
  sinus.imag = 2
  sinus = divis(moins(e(RevNeg_(x)), e(NegRev_(x))), sinus)
End If
End Function

Private Function asinus(x As complexe) As complexe
  asinus = NegRev_(Ln(Plus(Racine(moins(un, fois(x, x))), RevNeg_(x))))
End Function

Private Function cosinus(x As complexe) As complexe
  If x.imag = 0 Then
      cosinus.reel = Cos(x.reel)
  Else
      cosinus = divisb(Plus(e(RevNeg_(x)), e(NegRev_(x))), 2)
  End If
End Function

Private Function acosinus(x As complexe) As complexe
Dim pi2 As complexe
  pi2.reel = Pi2_
  acosinus = Plus(RevNeg_(Ln(Plus(Racine(moins(un, fois(x, x))), RevNeg_(x)))), pi2)
End Function

Private Function tangente(x As complexe) As complexe
  If x.imag = 0 Then
    tangente.reel = Tan(x.reel)
  Else
    Dim eInv As complexe
    tangente = e(RevNeg_(x)): eInv = divis(un, tangente)
    tangente = divis(moins(tangente, eInv), RevNeg_(Plus(tangente, eInv)))
  End If
End Function

Private Function NegRev_(U As complexe) As complexe 'mult by -i
  NegRev_.reel = U.imag: NegRev_.imag = -U.reel
End Function

Private Function RevNeg_(U As complexe) As complexe 'mult by i
  RevNeg_.reel = -U.imag: RevNeg_.imag = U.reel
End Function

Private Function atangente(x As complexe) As complexe
  atangente = NegRev_(Ln(divis(Plus(un, RevNeg_(x)), Racine(Plus(un, fois(x, x))))))
End Function

Private Function Sh(x As complexe) As complexe
On Error GoTo Error_Msg
    If x.imag = 0 Then
        Sh.reel = (Exp(x.reel) - Exp(-x.reel)) / 2
    Else
        Sh = divisb(moins(e(x), e(opp(x))), 2)
    End If
Exit Function
Error_Msg:
    Select Case Err
        Case 6: ErrorMsg = OvrFlo
            Sh = x
    End Select
    Resume Next
End Function

Private Function ash(x As complexe) As complexe
    ash = opp(Ln(moins(Racine(Plus(un, fois(x, x))), x)))
End Function

Private Function ch(x As complexe) As complexe
On Error GoTo Error_Msg
    
    If x.imag = 0 Then
        ch.reel = (Exp(x.reel) + Exp(-x.reel)) / 2
    Else
        ch = divisb(Plus(e(x), e(opp(x))), 2)
    End If
Exit Function
Error_Msg:
    Select Case Err
        Case 6: ErrorMsg = OvrFlo
            ch = x
    End Select
    Resume Next
End Function

Private Function ach(x As complexe) As complexe
    Dim pi2 As complexe
        pi2.reel = Pi2_
    ach = Plus(pi2, RevNeg_(Ln(Plus(Racine(moins(un, fois(x, x))), RevNeg_(x)))))
    ach = Racine(fois(opp(un), fois(ach, ach)))
End Function

Private Function th(x As complexe) As complexe
On Error GoTo Error_Msg
    If x.imag = 0 Then
        th.reel = (Exp(x.reel) - Exp(-x.reel)) / (Exp(x.reel) + Exp(-x.reel))
    Else
        th = divis(moins(e(x), e(opp(x))), Plus(e(x), e(opp(x))))
    End If
Exit Function
Error_Msg:
    Select Case Err
        Case 6: ErrorMsg = OvrFlo
            th = x
    End Select
    Resume Next
End Function

Private Function opp(x As complexe) As complexe
On Error GoTo Error_Msg
    opp.reel = -x.reel
    opp.imag = -x.imag
Exit Function
Error_Msg:
    Select Case Err
        Case 6: ErrorMsg = OvrFlo
            opp = x
    End Select
    Resume Next
End Function

Private Function ath(x As complexe) As complexe
    ath = opp(Ln(divis(moins(un, x), Racine(moins(un, fois(x, x))))))
End Function

Private Function MODULO(a As complexe, b As complexe) As complexe
    If a.imag = 0 And b.imag = 0 Then
            'MODULO.reel = a.reel Mod b.reel
        MODULO.reel = vIntMod(a.reel, b.reel)
    Else
      ErrorMsg = "Invalid argument"
    End If
End Function

Private Function divis_entiere(a As complexe, b As complexe) As complexe
    If a.imag = 0 And b.imag = 0 Then
            divis_entiere.reel = a.reel \ b.reel
    Else
            ErrorMsg = "Invalid argument"
    End If
End Function

Private Function factorielle(a As complexe) As complexe
If a.imag = 0 Then
  If a.reel = Int(a.reel) Then
    If a.reel >= 0 Then _
      factorielle.reel = Fact(a.reel) _
    Else ErrorMsg = InfRslt
    Exit Function
  End If
End If
factorielle = GammaC(Plus(a, un))
End Function

Private Function Fact#(n)
On Error GoTo Error_Msg
    Dim p#, i&   'bug overflow for n > 12, 8-7-02 VL
    
    p = 1
    For i = 1 To n
        p = p * i
    Next
    Fact = p
    Exit Function
Error_Msg:
    Select Case Err
        Case 6: ErrorMsg = OvrFlo
        Fact = n
    End Select
End Function

Private Function combinatoire(a As complexe, b As complexe) As complexe
    If a.imag = 0 And b.imag = 0 And a.reel > 0 And b.reel > 0 Then
            combinatoire.reel = Comb(a.reel, b.reel)
    Else
            ErrorMsg = "Invalid argument"
    End If
End Function

Private Function Comb(a, b)
On Error GoTo Error_Msg
    Dim n&, k&, y&, i&
    'combination n objects, k classes
    n = Int(a)
    k = Int(b)
    If n < 0 Then Comb = 0
    If k < 1 Or k > n Then k = 0
    If n = 0 Or k = 0 Or k = n Then Comb = 1: Exit Function
    y = n
    If k > Int(CDbl(n / 2)) Then k = n - k
    For i = 2 To k
        y = y * (n + 1 - i) / i
    Next i
    Comb = y
Exit Function
Error_Msg:
    Select Case Err
        Case 6: ErrorMsg = OvrFlo
        Comb = 0
    End Select
End Function

Private Function minimum(a As complexe, b As complexe) As complexe
    If a.imag = 0 And b.imag = 0 Then
            minimum.reel = min_(a.reel, b.reel)
    Else
            ErrorMsg = "Invalid argument"
    End If
End Function

Private Function maximum(a As complexe, b As complexe) As complexe
    If a.imag = 0 And b.imag = 0 Then
            maximum.reel = max_(a.reel, b.reel)
    Else
            ErrorMsg = "Invalid argument"
    End If
End Function

Private Function PPCM(a As complexe, b As complexe) As complexe
    If a.imag = 0 And b.imag = 0 Then
            PPCM.reel = mcm_(a.reel, b.reel)
    Else
            ErrorMsg = "Invalid argument"
    End If
End Function

Private Function mcm_(a, b)
On Error GoTo Error_Msg
    Dim MCD_temp&
    'Find the mcm between two integer numbers
    MCD_temp = mcd_(a, b)
    mcm_ = a * b / MCD_temp
Exit Function
Error_Msg:
    Select Case Err
        Case 6: ErrorMsg = OvrFlo
        mcm_ = 1
    End Select
End Function

Private Function PGCD(a As complexe, b As complexe) As complexe
    If a.imag = 0 And b.imag = 0 Then
            PGCD.reel = mcd_(a.reel, b.reel)
    Else
            ErrorMsg = "Invalid argument"
    End If
End Function

Private Function mcd_(a, b)
On Error GoTo Error_Msg
    Dim x&, y&, r&
    'Find the MCD between two integer numbers
    y = a
    x = b
    Do Until x = 0
        r = y Mod x
        y = x
        x = r
    Loop
    mcd_ = y
Exit Function
Error_Msg:
    Select Case Err
        Case 6: ErrorMsg = OvrFlo
        mcd_ = 1
    End Select
End Function

Private Function fctFIX(a As complexe) As complexe
    If a.imag = 0 Then
            fctFIX.reel = Fix(a.reel)
    Else
            ErrorMsg = "Invalid argument"
    End If
End Function

Private Function fctINT(a As complexe) As complexe
    If a.imag = 0 Then
            fctINT.reel = Int(a.reel)
    Else
            ErrorMsg = "Invalid argument"
    End If
End Function

Private Function fctRND(a As complexe) As complexe
    If a.imag = 0 Then
            fctRND.reel = Rnd(a.reel)
    Else
            ErrorMsg = "Invalid argument"
    End If
End Function

Private Function betaC(z As complexe, w As complexe) As complexe
    betaC = e(moins(Plus(GammaLnC(z), GammaLnC(w)), GammaLnC(Plus(z, w))))
End Function

Private Function GammaC(a As complexe) As complexe
    GammaC = e(GammaLnC(a))
End Function

Private Function GammaLnC(a As complexe) As complexe
On Error GoTo Error_Msg
Dim s As complexe, CFi As complexe, Cpt As complexe
Dim Zg As complexe, i%, z As complexe
Const G_# = 4.7421875  '607/128
Const lspi# = "572364942924700087071E-21" ' Log(Sqr(Pi))
Const ls2p# = "91893853320467274178E-20" ' Log(Sqr(2*pi))
If a.reel = 0.5 Then If a.imag = 0 Then GammaLnC.reel = lspi: Exit Function
z.reel = a.reel
z.imag = a.imag

s.reel = GCf_(0)
For i = 1 To 15
    CFi.reel = GCf_(i)
    Cpt.reel = i - 1
    s = Plus(s, divis(CFi, Plus(z, Cpt)))
Next

Cpt.reel = G_ - 0.5
Zg = Plus(z, Cpt)

Cpt.reel = 0.5
CFi = moins(fois(moins(z, Cpt), Ln(Zg)), Zg)
Cpt.reel = ls2p
GammaLnC = Plus(Plus(Cpt, Ln(s)), CFi)

Exit Function
Error_Msg:
    ErrorMsg = InfRslt
End Function

Private Function ErfC_Continued_fraction(z As complexe) As complexe
    Dim f As complexe
    f.reel = z.reel
    f.imag = z.imag
    Dim c As complexe
    c.reel = f.reel
    c.imag = f.imag
    Dim d As complexe
    Dim Delta As complexe
    Dim a As complexe
    Const EPS# = 0.000000000000001
    Const Tiny# = 1E-20
    
    Do
        a.reel = a.reel + 0.5
        d = Plus(z, fois(a, d))
        c = Plus(z, divis(a, c))
        If d.reel = 0 And d.imag = 0 Then d.reel = Tiny
        d = Inv(d)
        Delta = fois(c, d)
        f = fois(f, Delta)
    Loop While (Abs(1# - absol(Delta).reel) > EPS)
    
    f = fois(Inv(f), e(opp(fois(z, z))))
    ErfC_Continued_fraction.reel = f.reel / SqPi_
    ErfC_Continued_fraction.imag = f.imag / SqPi_
    
End Function

Private Function ErfC_Serie(z As complexe) As complexe
    Dim Sum As complexe
    Dim Term As complexe
    Term.reel = z.reel
    Term.imag = z.imag
    Dim z2 As complexe
    z2 = fois(z, z)
    Dim vn As complexe
    Dim n As Integer
    n = 0
    Const Tiny# = 1E-20
    
    While (n < 3 Or absol(Term).reel > absol(Sum).reel * Tiny)
        vn.reel = 2 * n + 1
        Sum = Plus(Sum, divis(Term, vn))
        vn.reel = n + 1
        Term = opp(fois(Term, divis(z2, vn)))
        n = n + 1
    Wend
    
    ErfC_Serie.reel = 1 - Sum.reel * 2 / SqPi_
    ErfC_Serie.imag = -Sum.imag * 2 / SqPi_
    
End Function

Private Function ErfC_Rybicky(z As complexe) As complexe
    Const h# = 0.2
    Dim n0 As Double
    n0 = 2 * Int(CDbl(z.imag / (2 * h) + 0.5))
    Dim z0 As complexe
    z0.imag = n0 * h
    Dim zp As complexe
    zp = moins(z, z0)
    Dim Sum As complexe
    Dim np As Integer
    Dim t As complexe
    Dim b As complexe
    
    For np = -35 To 35 Step 2
        t.reel = zp.reel
        t.imag = zp.imag - np * h
        b = e(fois(t, t))
        b.reel = b.reel / (np + n0)
        b.imag = b.imag / (np + n0)
        Sum = Plus(Sum, b)
    Next
    Sum = fois(Sum, e(opp(fois(z, z))))
    
    ErfC_Rybicky.reel = 1 + Sum.imag * 2 / Pi_
    ErfC_Rybicky.imag = -Sum.reel * 2 / Pi_
    
End Function

Private Function ErfC_fraction(z As complexe) As complexe
    Dim result As complexe
   
    If z.reel > 0 Then
        ErfC_fraction = ErfC_Continued_fraction(z)
    Else
        result = ErfC_Continued_fraction(opp(z))
        ErfC_fraction.reel = 2 - result.reel
        ErfC_fraction.imag = -result.imag
    End If
End Function

Private Function ErfC(z As complexe) As complexe
    Dim result As complexe
    If absol(z).reel < 2# Then
        ErfC = ErfC_Serie(z)
    ElseIf Abs(z.reel) < 0.5 Then
        ErfC = ErfC_Rybicky(z)
    Else
        ErfC = ErfC_fraction(z)
    End If
End Function

Private Function fctErf(z As complexe) As complexe
    Dim val_erfc As complexe
    If z.reel > 0 Then
        val_erfc = ErfC(z)
        fctErf.reel = 1 - val_erfc.reel
        fctErf.imag = -val_erfc.imag
    Else
        val_erfc = ErfC(opp(z))
        fctErf.reel = -1 + val_erfc.reel
        fctErf.imag = val_erfc.imag
    End If
End Function

Private Function fctExpIntegral(z As complexe) As complexe
    Dim Fact As complexe
    Dim Sum As complexe
    Dim Term As complexe
    Dim prev As complexe
    Dim k As Integer
    
    Const EPS# = 0.000000000000001, maxit = 100, FPMIN# = 1E-30
    
    If absol(z).reel < FPMIN Then ' avoid failure of convergence
        fctExpIntegral = Ln(z)
        fctExpIntegral.reel = fctExpIntegral.reel + dEu_
    ElseIf absol(z).reel < -Log(EPS) Then 'use power serie
        Fact.reel = 1
        For k = 1 To maxit
            Fact = fois(Fact, z)
            Fact.reel = Fact.reel / k
            Fact.imag = Fact.imag / k
            Term.reel = Fact.reel / k
            Term.imag = Fact.imag / k
            Sum = Plus(Sum, Term)
        Next
        Term = moins(Ln(z), Ln(Inv(z)))
        Term.reel = Term.reel / 2 + dEu_
        Term.imag = Term.imag / 2
        fctExpIntegral = Plus(Sum, Term)
    Else ' use asymptotic series
        Sum.reel = 1
        Term.reel = 1
        For k = 1 To maxit
            prev = Term
            Term.reel = Term.reel / k
            Term.imag = Term.imag / k
            Term = divis(Term, z)
            If absol(Term).reel < EPS Then Exit For
            If absol(Term).reel < absol(prev).reel Then
                Sum = Plus(Sum, Term)
            Else
                Sum = moins(Sum, prev)
                Exit For
            End If
        Next
        Term = moins(Ln(z), Ln(Inv(z)))
        Term.reel = Term.reel / 2
        Term.imag = Term.imag / 2
        Term = moins(Term, Ln(opp(z)))
        fctExpIntegral = fois(divis(e(z), z), Sum)
        fctExpIntegral = Plus(fctExpIntegral, Term)
    End If
End Function

Private Function fctZeta(z As complexe) As complexe
Dim Cnk#, k&, n&
Dim s1 As complexe
Dim s  As complexe
Dim kp1 As complexe
Dim kp2 As complexe
Dim coeff As complexe

Const n_max = 1000
Const Tiny# = 0.000000000000001

    n = 0
    Do
        s1.reel = 0
        s1.imag = 0
        Cnk = 1
        For k = 0 To n
            If k > 0 Then Cnk = Cnk * (n - k + 1) / k
            kp1.reel = k + 1
            kp2.reel = (-1) ^ k * Cnk
            s1 = Plus(s1, divis(kp2, expos(kp1, z)))
        Next k
        kp1.reel = 2 ^ (1 + n)
        coeff = divis(s1, kp1)
        s = Plus(s, coeff)
        n = n + 1
    Loop Until absol(coeff).reel < Tiny Or n > n_max
    kp1.reel = 1
    kp2.reel = 2
    fctZeta = divis(s, moins(kp1, expos(kp2, moins(kp1, z))))
End Function

'#Const RPNCalc = 0

Private Function ComplexFunctionNVar(x() As complexe, v() As String, Name&) As complexe
    Dim y As complexe
    Select Case Name
        Case symInteg
            y = Romberg(v(1), v(2), x(3), x(4))
        Case symSerie
            y = Serie(v(1), v(2), x(3), x(4), v(5), x(6))
        Case Else
            setErrorMsg "Function <" & Name & "> missing?"
    End Select
    ComplexFunctionNVar = y
End Function

Private Function Romberg(chaine$, Variable$, a As complexe, b As complexe) As complexe
    Dim Funct As clsMathParserCx
    Dim ris As complexe
    Dim OK As Boolean
    Dim Index As Integer
    Dim nombrevariables As Long
    Dim VarName As String
'    Dim VarValue As complexe
    Dim indexvar As Integer
    Const Rank = 16
    Const ErrMax# = Ten_15
    Dim ErrLoop
    Dim i&, Nodes&, n%, j%
    Dim h As complexe
    Dim s As complexe
    Dim y1 As complexe
    Dim y2 As complexe
    Dim denom As complexe
    Dim VarValR#()
    Dim VarValI#()
    Dim r() As complexe
    Dim y() As complexe

On Error GoTo Error_Msg
Set Funct = New clsMathParserCx
'initErrorMsg
'    #If RPNCalc = 1 Then
'        chaine = ConversionRegionale(Mid$(chaine, 2, Len(chaine) - 2))
'    #Else
        chaine = Mid$(chaine, 2, Len(chaine) - 2)
'    #End If
    
    If Len(Variable) >= 2 Then Variable = Mid$(Variable, 2, Len(Variable) - 2)
    OK = Funct.StoreExpression(chaine)
    If Not OK Then
        setErrorMsg Funct.ErrorDescription
        Exit Function
    End If
    
    indexvar = 0
    nombrevariables = Funct.VarTop
    If nombrevariables > 0 Then
        ReDim VarValR(1 To nombrevariables)
        ReDim VarValI(1 To nombrevariables)
        For Index = 1 To nombrevariables
            VarName = Funct.VarName(Index)
            If VarName = Variable Then
                indexvar = Index
            Else
                If Left$(VarName, 1) <> ElementChaine Then
'                    #If RPNCalc = 1 Then
'                        VarValue = GetVarValue(VarName)
'                        If Len(getErrorMsg) <> 0 Then
'                            Exit Function
'                        End If
'                        VarValR(Index) = VarValue.reel
'                        VarValI(Index) = VarValue.imag
'                    #Else
                        setErrorMsg "One Variable Only"
                        Exit Function
'                    #End If
                End If
            End If
        Next
    End If
    
    
    If indexvar = 0 Then
        ris.reel = Funct.EvalComplexe(VarValR, VarValI)
        If Len(Funct.ErrorDescription) <> 0 Then
            setErrorMsg Funct.ErrorDescription
            Exit Function
        Else
            ris.imag = Funct.ImagComplexe
        End If
        Romberg = fois(moins(b, a), ris)
    Else
        n = 0
        Nodes = 1
        ReDim r(Rank, Rank), y(Nodes)
        
        VarValR(indexvar) = a.reel
        VarValI(indexvar) = a.imag
        ris.reel = Funct.EvalComplexe(VarValR, VarValI)
        If Len(Funct.ErrorDescription) <> 0 Then
            setErrorMsg Funct.ErrorDescription
            Exit Function
        Else
            ris.imag = Funct.ImagComplexe
        End If
        y(0) = ris
        VarValR(indexvar) = b.reel
        VarValI(indexvar) = b.imag
        ris.reel = Funct.EvalComplexe(VarValR, VarValI)
        If Len(Funct.ErrorDescription) <> 0 Then
            setErrorMsg Funct.ErrorDescription
            Exit Function
        Else
            ris.imag = Funct.ImagComplexe
        End If
        y(1) = ris
        h = moins(b, a)
        r(n, n) = fois(divisb(Plus(y(0), y(1)), 2), h)

'        y1 = Plus(y(0), y(1))
'        y2 = divisb(y1, 2)
'        s = fois(h, y2)
'    Dim tmp(3)
'    tmp(0) = h.reel * y2.reel
'    tmp(1) = h.imag * y2.imag
'    tmp(2) = h.reel * y2.imag
'    tmp(3) = h.imag * y2.reel
'Debug.Print "01", xCStr(tmp(0), 28), xCStr(tmp(1), 28)
'Debug.Print "23", xCStr(tmp(2), 28), xCStr(tmp(3), 28)
'Debug.Print "a", xCStr(a.reel, 28), xCStr(a.imag, 28)
'Debug.Print "b", xCStr(b.reel, 28), xCStr(b.imag, 28)
'Debug.Print "moins", xCStr(h.reel, 28), xCStr(h.imag, 28)
'Debug.Print "Plus", xCStr(y1.reel, 28), xCStr(y1.imag, 28)
'Debug.Print "divis", xCStr(y2.reel, 28), xCStr(y2.imag, 28)
'Debug.Print "fois", xCStr(s.reel, 28), xCStr(s.imag, 28)
'Debug.Print "r", xCStr(r(n, n).reel, 28), xCStr(r(n, n).imag, 28)

'        r(n, n) = fois(h, divis(Plus(y(0), y(1)), deux))
        Do
            n = n + 1
            Nodes = 2 * Nodes
            h = divisb(h, 2)
            ReDim Preserve y(Nodes)
            For i = Nodes To 1 Step -1
                If i Mod 2 = 0 Then
                    y(i) = y(i / 2)
                Else
                    VarValR(indexvar) = a.reel + i * h.reel
                    VarValI(indexvar) = a.imag + i * h.imag
                    ris.reel = Funct.EvalComplexe(VarValR, VarValI)
                    If Len(Funct.ErrorDescription) <> 0 Then
                        setErrorMsg Funct.ErrorDescription
                        Exit Function
                    Else
                        ris.imag = Funct.ImagComplexe
                    End If
                    y(i) = ris
                End If
            Next i
            s.reel = 0
            s.imag = 0
            For i = 1 To Nodes
                s = Plus(Plus(s, y(i)), y(i - 1))
            Next
            r(n, 0) = divisb(fois(h, s), 2)
            For j = 1 To n
                y1 = r(n - 1, j - 1)
                y2 = r(n, j - 1)
                denom.reel = 4 ^ j - 1
                r(n, j) = Plus(y2, divis(moins(y2, y1), denom))
            Next j
            ErrLoop = absol(moins(r(n, n), r(n, n - 1))).reel
            If absol(r(n, n)).reel > 10 Then
                ErrLoop = ErrLoop / absol(r(n, n)).reel
            End If
        Loop Until ErrLoop < ErrMax Or n >= Rank
        Romberg = r(n, n)
    End If
    Exit Function
    
Error_Msg:
    If Len(getErrorMsg) <> 0 Then setErrorMsg "Syntax Error"
End Function

Private Function Serie(chaine$, variableN$, n1 As complexe, n2 As complexe, variableX$, x As complexe) As complexe
    Dim ris As complexe
    Dim Funct As New clsMathParserCx
    Dim OK As Boolean
    Dim Index As Integer
    Dim nombrevariables As Long
    Dim VarValR#()
    Dim VarValI#()
    Dim VarName As String
    Dim VarValue As complexe
    Dim indexvarX As Integer
    Dim indexvarN As Integer
    Dim n_min As Integer
    Dim n_max As Integer
    Dim k As Integer

On Error GoTo Error_Msg
If VarType(chaine) < vbInteger Then setErrorMsg "Invalid Null": Exit Function

'    #If RPNCalc = 1 Then
'        chaine = ConversionRegionale(Mid$(chaine, 2, Len(chaine) - 2))
'    #Else
        chaine = Mid$(chaine, 2, Len(chaine) - 2)
'    #End If
    
    If Len(variableN) >= 2 Then variableN = Mid$(variableN, 2, Len(variableN) - 2)
    If Len(variableX) >= 2 Then variableX = Mid$(variableX, 2, Len(variableX) - 2)
    
    OK = Funct.StoreExpression(chaine)
    If Not OK Then
        setErrorMsg Funct.ErrorDescription
        Exit Function
    End If
    
    indexvarX = 0
    indexvarN = 0
    nombrevariables = Funct.VarTop
    If nombrevariables > 0 Then
        ReDim VarValR(1 To nombrevariables)
        ReDim VarValI(1 To nombrevariables)
        For Index = 1 To nombrevariables
            VarName = Funct.VarName(Index)
            If VarName = variableX Then
                indexvarX = Index
                VarValR(Index) = x.reel
                VarValI(Index) = x.imag
            ElseIf VarName = variableN Then
                indexvarN = Index
            Else
                If Left$(VarName, 1) <> ElementChaine Then
'                    #If RPNCalc = 1 Then
'                        VarValue = GetVarValue(VarName)
'                        If Len(getErrorMsg) <> 0 Then
'                            Exit Function
'                        End If
'                        VarValR(Index) = VarValue.reel
'                        VarValI(Index) = VarValue.imag
'                    #Else
                        setErrorMsg "One Variable Only"
                        Exit Function
'                    #End If
                End If
            End If
        Next
    End If
    
    Serie.reel = 0
    Serie.imag = 0
    n_min = n1.reel
    n_max = n2.reel
    VarValI(indexvarN) = 0
    For k = n_min To n_max
        If indexvarN <> 0 Then VarValR(indexvarN) = k
        ris.reel = Funct.EvalComplexe(VarValR, VarValI)
        If Len(Funct.ErrorDescription) <> 0 Then
            setErrorMsg Funct.ErrorDescription
            Exit Function
        Else
            ris.imag = Funct.ImagComplexe
        End If
        Serie = Plus(Serie, ris)
    Next
    Exit Function

Error_Msg:
    If Len(getErrorMsg) <> 0 Then setErrorMsg "Syntax Error"
End Function
VBA Filename ChangeBase.bas Extracted Macro
'Code written by:       Richard Huxtable
'Last updated on:       17 May 2002 at 4:52 pm

'CHANGE THE BASE OF A NUMBER
'1  It decides whether it is looking at a numeric number or a text string.
'2  It reads the number into an array with one digit in each element.
'3  It converts to the new base.
'4  It deals with some rounding errors.
'5  It decides whether the result is a numeric number or a text string.
'6  It makes a modest attempt to format any text strings in line with the number formats being used.

'When do rounding problems occur and why?
'   Only matters when the input number is not an integer.
'   Happens when the decimal recurs in the new base.
'   For example 0.5 in base 10 is 0.111111... in base 3
'   For example 0.1 in base 10 is 0.0001100110011... in base 2 - this is why Excel can make rounding errors.

'In this module:
'1  The numeric functions relating to changing the base are set out first.
'2  The functions that handle text strings come next.
'3  Two more related functions - sumDigits and areDigitsAllDifferent come last.

Option Explicit
Private Const maxN      As Integer = 54     'How many digits before the decimal point are allowed?
Private Const MaxD      As Integer = 16     'How many digits after the decimal point are allowed?
Private Const hurdle    As Integer = 4      'How many consecutive 9s or (newBase-1) trigger rounding?
                                            'Set to (maxD+1) for no rounding at all.

Private Negative        As Boolean          'is the number negative?

Private bigNo(1 To 3, -MaxD To maxN)         As Integer          'This array takes:
                                            'row 1 the number from the worksheet
                                            'row 2 the number converted to the new base
                                            'row 3 a copy of row 1 for working purposes
Private CellFmt$

Function BaseChange(number, old_base, new_base)     'Function validates the old and the new base.
Attribute BaseChange.VB_Description = "Converts a number from one base to another (up to 36)."
Attribute BaseChange.VB_HelpID = 127
Attribute BaseChange.VB_ProcData.VB_Invoke_Func = " \n14"
If IsObject(number) Then
    CellFmt = number.NumberFormatLocal
    If CellFmt = "@" Then CellFmt = "General" ' Switch "Text" to "General"
Else
  CellFmt = "General"
End If
    old_base = CDbl_(old_base) 'Then it decides whether it is looking at a numeric number or a text string.
    new_base = CDbl_(new_base)
    If Int(old_base) <> old_base Or old_base < 2 Then
        BaseChange = "Old base must be a positive integer (2 or more)"
        Exit Function
    End If
    If Int(new_base) <> new_base Or new_base < 2 Then
        BaseChange = "New base must be a positive integer (2 or more)"
        Exit Function
    End If
    If new_base > 36 Then
        BaseChange = "New base must be 36 or under."
        Exit Function
    End If
    Erase bigNo
    If Application.WorksheetFunction.IsNumber(number) Then   'Note that the VBA function IsNumeric returns true for "numbers" involving
        BaseChange = numRead(number, old_base, new_base)     'an E or a D such as 6E2.
    Else
        BaseChange = strRead(number, old_base, new_base)
    End If
End Function

Private Function numRead(number, oldBASE, newBASE)  'Read the number from the worksheeet into the array "bigNo"
    Dim col             As Integer
    Dim working         As Double
    Dim oldDigits       As Integer          'number of digits in the number from the worksheet before the decimal point
    
    Negative = number < 0
    col = 0                                 'In the worksheet, the number is always in base 10.
    working = Int(Abs(number))
    Do Until Int(working) = 0                'So, start by reading the number in as base 10.
'        bigNo(1, col) = working Mod 10
        bigNo(1, col) = vIntMod(working, 10)  'First, the digits before the decimal point.
        working = (working - bigNo(1, col)) / 10
        col = col + 1
    Loop
    If Int(Abs(number)) = 0 Then             'Find the number of digits in the number to the old base.
        oldDigits = 0
    Else
        oldDigits = col - 1
    End If
                                            'Now, the digits after the decimal point
    
    working = Round(CDbl((Abs(number) - Int(Abs(number))) * (10 ^ MaxD)))
'    working = Int(CDbl((Abs(number) - Int(Abs(number))) * (10 ^ maxD)))
'    If working Mod 10 = 9 And oldBase <= 10 Then  'The line above has a tendency to introduce rounding errors.
'        working = working + 1               'Test and correct if necessary. (Actually this only picks up some of the errors).
'    End If
    
    For col = -MaxD To -1
'        bigNo(1, col) = working Mod 10
        bigNo(1, col) = vIntMod(working, 10)
        working = (working - bigNo(1, col)) / 10
    Next col
    numRead = conversion(number, oldBASE, newBASE, oldDigits)
End Function

Private Function conversion(number, oldBASE, newBASE, oldDigits%)  'Convert the number from the old base to the new base.
    Dim col             As Integer
    Dim working         As Double
    Dim newDigits       As Integer
    Dim lastN           As Integer          'the position of the last consecutive 9 or (newBase-1) in a decimal
    Dim carry           As Long
    Dim lap             As Integer
    Dim decStart        As Integer
    
    decStart = -2 + formatNoDecimals(number) 'decStart weakens the validation test that looks for digits too big for the old base.
    If decStart > MaxD Then decStart = MaxD  'Without decStart the test trips up over rounding errors caused during the calculations.
    If decStart < 0 Then decStart = 0
    If over_N(1, oldBASE - 1, decStart) Then
        conversion = "Number includes digits too big for old base!"
        Exit Function
    End If
    For col = -MaxD To maxN                 'We have previously read the number into row 1.
        bigNo(3, col) = bigNo(1, col)       'Make a copy of it in row 3 to work on.
    Next col
                                            'Deal with the digits before the decimal point.
    Do While IsItZero(oldDigits, 3) = False
        working = 0                         'Very like division.
        carry = 0
        For col = oldDigits To 0 Step -1
            working = (carry * oldBASE) + bigNo(3, col)
            carry = working Mod newBASE
            bigNo(3, col) = (working - carry) / newBASE
        Next col
        lap = lap + 1
        If lap > maxN Then Exit Do
        bigNo(2, lap - 1) = carry
    Loop
    newDigits = lap - 1
    
    For lap = 1 To MaxD                     'Deal with the digits after the decimal point.
        carry = 0                           'Very like multiplication.
        For col = -MaxD To -1
            working = carry + (bigNo(3, col) * newBASE)
            bigNo(3, col) = working Mod oldBASE
            carry = (working - bigNo(3, col)) / oldBASE
        Next col
        bigNo(2, -lap) = carry
    Next lap
                                            'Now deal with rounding.  If you don't want rounding, or want less of it,
                                            '                                  increase "hurdle" at the module level.
    If bigNo(1, -MaxD) <> 0 Or bigNo(1, 1 - MaxD) <> 0 Then
        If newBASE < oldBASE Then           'If the new base is smaller, not much of a problem.  Simply add 1.
            carry = 1                       'Set carry to zero if you don't want rounding.
            For col = -MaxD To maxN
                working = carry + bigNo(2, col)
                bigNo(2, col) = working Mod newBASE
                carry = (working - bigNo(2, col)) / newBASE
            Next col
        Else                                'If the new base is bigger, the problem is greater.
            lastN = rounding(newBASE)
            If lastN < 0 Then
                For col = -MaxD To lastN - 1
                    bigNo(2, col) = 0
                Next col
                carry = 1
                For col = lastN To maxN
                    working = carry + bigNo(2, col)
                    bigNo(2, col) = working Mod newBASE
                    carry = (working - bigNo(2, col)) / newBASE
                Next col
            End If
        End If
    End If
    
'    If over_N(2, 9, MaxD) Then                'Does the result need text?
  If newDigits < 15 Then
    decStart = -MaxD
    While bigNo(2, decStart) = 0: decStart = decStart + 1: Wend
    If decStart >= 0 Then _
      If Not over_N(2, 9, -decStart) Then GoTo Convert2Double
  End If
  conversion = makeString(number, newDigits)
  Exit Function
Convert2Double:
    working = 0
    For col = decStart To newDigits 'Convert the new number into a form that can be shown in the worksheet.
      working = working + (bigNo(2, col) * (10 ^ col))
    Next col
        
    If Negative Then
      conversion = -working
    Else
      conversion = working
    End If
End Function

Private Function IsItZero(n%, Row%) As Boolean
    Dim col             As Integer          'This function returns "true" when all elements of a given row of bigNo1 are zero.
    
    For col = 0 To n
        If bigNo(Row, col) > 0 Then Exit Function
    Next col

    IsItZero = True
End Function

Private Function over_N(Row%, n%, decStart%) As Boolean
    Dim col%         'This function checks whether all the digits are less than the base.
    
    For col = -decStart To maxN
        If bigNo(Row, col) > n Then over_N = True: Exit Function
    Next col
End Function

Private Function rounding(newBASE) As Integer       'This function finds out whether there are at least a given ("hurdle") number of
                                            'consecutive 9s or (newBase-1) in the decimals of the result.  If there are, it returns
                                            'the position of the last one.  If not, it returns zero.
    Dim col             As Integer
    Dim a               As Integer
    Dim b               As Integer
    Dim started         As Boolean
    Dim working         As Double
        
    started = False
    a = 0
    For col = -1 To -MaxD Step -1
        If started Then
            If bigNo(2, col) = newBASE - 1 Then
                a = a + 1
                b = col
            Else
              started = False: If a > hurdle - 1 Then Exit For
            End If
        Else
            If bigNo(2, col) = newBASE - 1 Then
                a = a + 1
                started = True
            End If
        End If
    Next col
    
    If a > hurdle - 1 Then
        rounding = b
    Else
        rounding = 0
    End If
End Function

'**** STRING FUNCTIONS FOLLOW ****

Private Function makeString(number, newDigits%) As String
    Dim col             As Integer
    Dim s               As String           'working string
    Dim FmtNoDecs       As Integer          'the number of decimals required by the formatting
    
    If CellFmt Like "General" Then
        FmtNoDecs = 0
        For col = -MaxD To -1
            If bigNo(2, col) > 0 Then
                FmtNoDecs = -col            'Find the last significant digit.
                Exit For
            End If
        Next col
    Else
        FmtNoDecs = formatNoDecimals(number)
    End If
    If FmtNoDecs > MaxD Then FmtNoDecs = MaxD
    For col = newDigits To -FmtNoDecs Step -1
        If bigNo(2, col) > 9 Then
            s = s & Chr$(55 + bigNo(2, col))
        Else
            s = s & str$(bigNo(2, col))
        End If
        If col Mod 3 = 0 And col > 1 And CellFmt Like "*" & MilSep & "*" Then
            s = s & MilSep
        End If
        If col = 0 And FmtNoDecs > 0 Then
            s = s & DecSep
        End If
    Next col
    If IsItZero(maxN, 1) Then s = vbStr0 & DecSep & s
    
    If Negative Then
        If CellFmt Like "*)*" Then
            s = "(" & s & ")"
        Else
            s = "-" & s
        End If
    End If
    
    s = removeChr(s, " ")
    If CellFmt Like "*_*" And Not Negative Then s = s & " "
    makeString = s
    
End Function

Private Function strRead(number, oldBASE, newBASE)  'Read the number from the worksheeet into the array "bigNo".
    Dim col             As Integer
    Dim s               As String           'working string
    Dim oldDigits       As Integer          'number of digits in the number from the worksheet before the decimal point
    
    s = xUnformat(number) ' Remove MilSep and Spaces
'    s = removeChr(s, MilSep)
'    s = removeChr(s, " ")
    If s Like "*(*" Then
        Negative = True
        s = removeChr(s, "(")
        s = removeChr(s, ")")
    Else
      If Asc(s) = vbKeyMinus Then Negative = True: s = Right$(s, Len(s) - 1) Else Negative = False
    End If
    If oldBASE = 10 Then _
      s = xFmt(s, DIGITS_LIMIT, DIGITS_LIMIT) 'Ensure not scientific format
    If s Like "*" & DecSep & "*" Then
        oldDigits = InStr(s, DecSep) - 1
        s = removeChr(s, DecSep)
    Else
        oldDigits = Len(s)
    End If
    For col = 1 To Len(s)
        bigNo(1, oldDigits - col) = letters2num(Mid$(s, col, 1))
    Next col
    strRead = conversion(number, oldBASE, newBASE, oldDigits)
End Function

Private Function letters2num(s$) As Integer    'Converts letters in a string "number" into numbers
    If Asc(s) > 57 Then                     'S is a letter
        letters2num = Asc(s) - 55
    Else                                    'S must be a number
        letters2num = Val(s)
    End If
End Function

Private Function removeChr(s$, char$) As String
    Dim a               As Integer
    Dim b               As String           'working string
    
    b = vbNullString
    For a = 1 To Len(s)
        If Mid$(s, a, 1) <> char Then
            b = b & Mid$(s, a, 1)
        End If
    Next a
    removeChr = b
End Function

Private Function formatNoDecimals(Cell) As Integer    'Finds the number of decimals in a number format string
    Dim a           As Integer
    Dim b           As Integer              'a counter
    
    On Error Resume Next   'fix bug 24.9.04  thanks to Gabriel Simmonds
    If CellFmt Like "*" & DecSep & "*" Then
        For a = InStr(CellFmt, DecSep) + 1 To Len(CellFmt)
            If Mid$(CellFmt, a, 1) Like "#" Then   'If the characters following the decimal point are either 0 or the
                b = b + 1                   'number sign, "#", count them.
            Else
                formatNoDecimals = b
                Exit Function
            End If
        Next a
        formatNoDecimals = b
    Else                                    'If there is no decimal point, the number of decimals is nil.
        formatNoDecimals = 0
    End If
End Function

'**** TWO MORE RELATED FUNCTIONS ****

Function SumDigits(number)
Attribute SumDigits.VB_Description = "Add up the digits of an integer."
Attribute SumDigits.VB_HelpID = 129
Attribute SumDigits.VB_ProcData.VB_Invoke_Func = " \n14"
    Dim col             As Integer
    Dim total           As Integer
    Dim digit           As Integer
    Dim working         As Double
    Dim s               As String
    
    If Application.WorksheetFunction.IsNumber(number) Then   'Note that the VBA function IsNumeric returns true for "numbers" involving
                                                             'an E or a D such as 6E2.
        If Int(number) <> number Then
            SumDigits = "number must be an integer"
            Exit Function
        End If
        
        s = CStr(Abs(number))
        
'        working = Abs(number)
'        total = 0
'        Do Until working = 0
'            digit = working Mod 10
'            working = (working - digit) / 10
'            total = total + digit
'        Loop
    Else
        s = number
        If s Like "*" & DecSep & "*" Then
            SumDigits = "number must be an integer"
            Exit Function
        End If
        s = removeChr(s, ",")
        s = removeChr(s, " ")
        s = removeChr(s, "(")
        s = removeChr(s, ")")
        s = removeChr(s, "-")
        
    End If
    col = InStr(s, "E")
    If col > 0 Then
      s = Left$(s, col - 1)
    Else
      col = InStr(s, "e")
      If col > 0 Then s = Left$(s, col - 1)
    End If
        total = 0
        For col = 1 To Len(s)
            total = total + letters2num(Mid$(s, col, 1))
        Next col
    SumDigits = total
End Function

Private Function areDigitsAllDifferent(number)
Attribute areDigitsAllDifferent.VB_Description = "Are the digits of an integer all different?"
Attribute areDigitsAllDifferent.VB_ProcData.VB_Invoke_Func = " \n14"
    Dim works(maxN)     As Integer
    Dim col             As Integer
    Dim a               As Integer
    Dim Digits          As Integer
    Dim s               As String
        
    If Application.WorksheetFunction.IsNumber(number) Then   'Note that the VBA function IsNumeric returns true for "numbers" involving
                                                             'an E or a D such as 6E2.
    
        If Int(number) <> number Then
            areDigitsAllDifferent = "number must be an integer"
            Exit Function
        End If
        
        Erase works
        Digits = 0
        number = Abs(number)
        For col = 0 To maxN
            'works(col) = number Mod 10  'bug #VALUE for number=9876543210, VL 8-8-2002
            works(col) = number - Int(CDbl(number / 10)) * 10
            number = (number - works(col)) / 10
            If number > 0 Then Digits = Digits + 1
        Next col
    
        For col = 0 To Digits - 1
            For a = (col + 1) To Digits
                If works(col) = works(a) Then
                    areDigitsAllDifferent = False
                    Exit Function
                End If
            Next a
        Next col
        areDigitsAllDifferent = True
    Else
        s = number
'        If s Like "*" & DecSep & "*" Then
'            areDigitsAllDifferent = "number must be an integer"
'            Exit Function
'        End If
        s = removeChr(s, ".")
        s = removeChr(s, ",")
        s = removeChr(s, " ")
        s = removeChr(s, "(")
        s = removeChr(s, ")")
        s = removeChr(s, "-")
    
        For col = 1 To Len(s) - 1
            For a = (col + 1) To Len(s)
                If Mid$(s, col, 1) = Mid$(s, a, 1) Then
                    areDigitsAllDifferent = False
                    Exit Function
                End If
            Next a
        Next col
        areDigitsAllDifferent = True
    End If
End Function

'*******************************************************+
Function DigitsAllDiff(number)
Attribute DigitsAllDiff.VB_Description = "Checks if the digits are all different"
Attribute DigitsAllDiff.VB_HelpID = 137
Attribute DigitsAllDiff.VB_ProcData.VB_Invoke_Func = " \n14"
DigitsAllDiff = areDigitsAllDifferent(number)
End Function
VBA Filename frmODEField.frm Extracted Macro

'Option Explicit
Dim xMax#, xMin#, yMax#, yMin#, Ngrid%, ErrMsg
Dim RangeVar, RangeFun

Private Sub CommandButton_help_Click()
Application.Help XHelpFile, 312
End Sub

Private Sub CommandButton_run_Click()
'check input
If Len(Me.RefEdit1) = 0 Then
    MsgBox "Missing Differential Equation", vbCritical
    Me.RefEdit1.SetFocus
    Exit Sub
End If
If Len(Me.RefEdit2) = 0 Then
    MsgBox "Missing variables", vbCritical
    Me.RefEdit2.SetFocus
    Exit Sub
End If

RangeFun = Me.RefEdit1
RangeVar = Me.RefEdit2

'check setting
If Len(Me.TextBox_xmax) = 0 Then
    Me.TextBox_xmax.SetFocus
    MsgBox "Missing scale bound", vbCritical
    Exit Sub
End If
If Len(Me.TextBox_xmin) = 0 Then
    Me.TextBox_xmin.SetFocus
    MsgBox "Missing scale bound", vbCritical
    Exit Sub
End If
If Len(Me.TextBox_ymin) = 0 Then
    Me.TextBox_ymin.SetFocus
    MsgBox "Missing scale bound", vbCritical
    Exit Sub
End If
If Len(Me.TextBox_ymax) = 0 Then
    Me.TextBox_ymax.SetFocus
    MsgBox "Missing scale bound", vbCritical
    Exit Sub
End If

xMax = Me.TextBox_xmax
xMin = Me.TextBox_xmin
yMax = Me.TextBox_ymax
yMin = Me.TextBox_ymin

If xMin >= xMax Or yMin >= yMax Then
    MsgBox "Wrong scale bounds", vbCritical
    Exit Sub
End If

Ngrid = CInt_(Me.ComboBox_grid)
If Ngrid > 25 Or Ngrid < 4 Then
    MsgBox "grid range must be > 4 and < 25", vbCritical
    Exit Sub
End If

'run
ErrMsg = vbNullString
Me.Hide
DoEvents

Field_Generate

If Len(ErrMsg) <> 0 Then
    MsgBox ErrMsg, vbCritical
Else
    Setting_Manager "save"
End If
Unload Me
End Sub


Private Sub UserForm_Activate()
'setting previous values (if any)
End Sub

Private Sub UserForm_Initialize()

For i = 8 To 24
    Me.ComboBox_grid.AddItem i
Next i
Me.ComboBox_grid.ListIndex = 7
Setting_Manager "restore"

Input_Setting
 
End Sub

Private Sub Setting_Manager(s$)
With ThisWorkbook.Worksheets("setting")
If Left$(LCase$(s), 1) = "s" Then
Dim OrigCalcStatus As Integer
On Error Resume Next
OrigCalcStatus = Application.Calculation
Application.Calculation = xlCalculationManual
    'save
    .Range("E101") = Me.ComboBox_grid.ListIndex
    .Range("E102") = CDbl_(Me.TextBox_xmax)
    .Range("E103") = CDbl_(Me.TextBox_xmin)
    .Range("E104") = CDbl_(Me.TextBox_ymax)
    .Range("E105") = CDbl_(Me.TextBox_ymin)
    .Range("E106") = Me.CheckBox_axe
    .Range("E107") = Me.CheckBox_dot
    .Range("E108") = Me.CheckBox_scalelabels
Application.Calculation = OrigCalcStatus

ElseIf Left$(LCase$(s), 1) = "r" Then
    'restore
    If .Range("E101") <> vbNullString Then Me.ComboBox_grid.ListIndex = .Range("E101")
    If .Range("E102") <> vbNullString Then Me.TextBox_xmax = CStr(.Range("E102"))
    If .Range("E103") <> vbNullString Then Me.TextBox_xmin = CStr(.Range("E103"))
    If .Range("E104") <> vbNullString Then Me.TextBox_ymax = CStr(.Range("E104"))
    If .Range("E105") <> vbNullString Then Me.TextBox_ymin = CStr(.Range("E105"))
    If .Range("E106") <> vbNullString Then Me.CheckBox_axe = .Range("E106")
    If .Range("E107") <> vbNullString Then Me.CheckBox_dot = .Range("E107")
    If .Range("E108") <> vbNullString Then Me.CheckBox_scalelabels = .Range("E108")

End If
End With
End Sub

'initialization input fields
Private Sub Input_Setting()
Dim C0, R0, cn, rn, tmp
'a range is selected?
If Selection.Cells.Count < 3 Then Exit Sub
'continue
With Selection
    R0 = .Row
    C0 = .Column
    rn = .Rows.Count
    cn = .Columns.Count
End With
If cn <> 3 Then
    MsgBox "Wrong selection: columns must be 3", vbInformation
    Exit Sub
End If
ODE_Ord = 1

'select the first row containing value
If Not IsNumeric(Cells(R0, C0)) Then R0 = R0 + 1: rn = rn - 1
If Not IsNumeric(Cells(R0, C0)) Then
    MsgBox "Starting values x0 missing", vbInformation
    Exit Sub
End If

'select the equation range, variable range, starting range
tmp = Range(Cells(R0, C0 + ODE_Ord + 1), Cells(R0, C0 + 2 * ODE_Ord)).Address(False, False)
Me.RefEdit1 = tmp
tmp = Range(Cells(R0, C0), Cells(R0, C0 + ODE_Ord)).Address(False, False)
Me.RefEdit2 = tmp
Me.RefEdit1.SetFocus
End Sub


Private Sub Field_Generate()
Dim p(), Box(1 To 2, 1 To 2), plane(1 To 2, 1 To 2), TR, x, y
Dim aux()

'save initial values
x0 = Range(RangeVar).Cells(1)
y0 = Range(RangeVar).Cells(2)

On Error GoTo ErrorHandler

n = Ngrid

' b(1)= top-left corner  b(2)= bottom-right corner
Box(1, 1) = 10
Box(1, 2) = 10
Box(2, 1) = 310
Box(2, 2) = 310

s1 = AddBox(Box)

plane(1, 1) = xMin
plane(1, 2) = yMin
plane(2, 1) = xMax
plane(2, 2) = yMax
'add axes
If Me.CheckBox_axe = True Then
    s2 = Draw_XAxes(Box, plane)
    If Len(s2) <> 0 Then s1 = AddShape(s1, s2)
    s2 = Draw_YAxes(Box, plane)
    If Len(s2) <> 0 Then s1 = AddShape(s1, s2)
End If
'disegna una reticolo di punti
ReDim p(1 To n ^ 2, 1 To 2), aux(1 To n ^ 2, 1 To 2)
hx = (xMax - xMin) / (n + 1)
hy = (yMax - yMin) / (n + 1)
k = 0
For i = 1 To n
For j = 1 To n
    k = k + 1
    x = i * hx + xMin
    y = j * hy + yMin
    'transform (x,y) --> (u,v)
    Transf x, y, p(k, 1), p(k, 2), plane, Box
    'save (x, y)
    aux(k, 1) = x
    aux(k, 2) = y
Next j, i

If Me.CheckBox_dot = True Then
    s2 = Draw_Point(p, 3)  'aggiunge un insieme di punti
    s1 = AddShape(s1, s2)
End If
DoEvents
'per ogni punto disegna il segmento centrato di lunghezza 2h
Application.ScreenUpdating = False  '

h = (hx + hy) / 4  '<<
For k = 1 To UBound(aux)
    ReDim p(1 To 3, 1 To 2)
    x = aux(k, 1)
    y = aux(k, 2)
    'transform (x,y) --> (u,v)
    Transf x, y, p(2, 1), p(2, 2), plane, Box

    'calcolo pendenza y'
    FCT x, y, yd '    yd = -2 * x * y
    If Not IsError(yd) Then
        TETA = Atn(yd)
        dX = 0.5 * hx * Cos(TETA)
        dY = 0.5 * hy * Sin(TETA)
        'compute the segment bounds
        x1 = x + dX
        y1 = y + dY
        'transform (x,y) --> (u,v)
        Transf x1, y1, p(1, 1), p(1, 2), plane, Box

        x2 = x - dX
        y2 = y - dY
        'transform (x,y) --> (u,v)
        Transf x2, y2, p(3, 1), p(3, 2), plane, Box

        'draw segment [x1,y1 - x,y - x2,y2]
        s2 = Draw_Curve(p)   'aggiunge un insieme di segmenti
        s1 = AddShape(s1, s2)
    End If
Next k

'restore initial values
Range(RangeVar).Cells(1) = x0
Range(RangeVar).Cells(2) = y0

Application.ScreenUpdating = True

Exit Sub

ErrorHandler:
ErrMsg = Err.Description
'restore initial values
Range(RangeVar).Cells(1) = x0
Range(RangeVar).Cells(2) = y0
Application.ScreenUpdating = True
End Sub

Private Sub FCT(x, y, yd)
Range(RangeVar).Cells(1) = x
Range(RangeVar).Cells(2) = y
Application.Calculate
yd = Range(RangeFun)
End Sub
'
VBA Filename mdShapeDrawing.bas Extracted Macro
Option Private Module
'Option Explicit

'attenzione funziona solo per numero dei punti > 2
Function Draw_Curve(p())
Dim s, U, v, n
n = UBound(p)
With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, p(1, 1), p(1, 2))
    U = p(1, 1): v = p(1, 2)
    For i = 2 To n
        d = points_distance(U, v, p(i, 1), p(i, 2))
        If d > 1.5 Then
            .AddNodes msoSegmentLine, msoEditingAuto, p(i, 1), p(i, 2)
            U = p(i, 1): v = p(i, 2)
        End If
    Next i
    Set s = .ConvertToShape
    s.Line.ForeColor.RGB = RGB(119, 119, 119)
    s.Fill.Visible = msoFalse
End With
Draw_Curve = s.Name
End Function

'returns the name of the object selected
'retuns empty string if no shape object is selected
Function ShapeSelect()
ShapeSelect = vbNullString
On Error Resume Next
ShapeSelect = Selection.ShapeRange.Name
End Function

Private Function points_distance(x1, y1, x2, y2)
points_distance = Sqr((x2 - x1) ^ 2 + (y2 - y1) ^ 2)
End Function

Function Transf(x, y, U, v, p, b)
'transform (x,y) --> (u,v)
    U = (x - p(1, 1)) / (p(2, 1) - p(1, 1)) * (b(2, 1) - b(1, 1)) + b(1, 1)
    v = b(2, 2) - (y - p(1, 2)) / (p(2, 2) - p(1, 2)) * (b(2, 2) - b(1, 2))
    'box constraining
    If U < b(1, 1) Then U = b(1, 1)
    If U > b(2, 1) Then U = b(2, 1)
    If v < b(1, 2) Then v = b(1, 2)
    If v > b(2, 2) Then v = b(2, 2)
End Function

Function AddBox(b)
Attribute AddBox.VB_Description = "Macro registrata il 14/09/2003 da Enel.it"
Attribute AddBox.VB_ProcData.VB_Invoke_Func = " \n14"
Dim s
h = b(2, 2) - b(1, 2)
w = b(2, 1) - b(1, 1)
Set s = ActiveSheet.Shapes.AddShape(msoShapeRectangle, b(1, 1), b(1, 2), w, h)
AddBox = s.Name
End Function

Function AddShape(s1, s2)
Dim s
    ActiveSheet.Shapes.Range(Array(s1, s2)).Select
    Set s = Selection.ShapeRange.Group
    AddShape = s.Name
End Function

Function Draw_Point(p(), Optional r)
Dim s, U, v, s1, s_name
n = UBound(p)
If IsMissing(r) Then r = 1
With ActiveSheet.Shapes
    rx = p(1, 1) - r / 2
    ry = p(1, 2) - r / 2
    Set s = .AddShape(msoShapeOval, rx, ry, r, r)
    s.Fill.ForeColor.SchemeColor = 8
    s_name = s.Name
    U = p(1, 1): v = p(1, 2)
    For i = 2 To n
            d = points_distance(U, v, p(i, 1), p(i, 2))
            If d > 1.5 Then
                rx = p(i, 1) - r / 2
                ry = p(i, 2) - r / 2
                Set s = .AddShape(msoShapeOval, rx, ry, r, r)
                s.Fill.ForeColor.SchemeColor = 8
                s_name = AddShape(s_name, s.Name)
                U = p(i, 1): v = p(i, 2)
            End If
    Next i
End With
Draw_Point = s_name
End Function

'draw a line between point p1-p2
Function Draw_Line(p())
Dim s
With ActiveSheet.Shapes
    Set s = .AddLine(p(1, 1), p(1, 2), p(2, 1), p(2, 2))
    s.Fill.ForeColor.SchemeColor = 8
End With
Draw_Line = s.Name
End Function

Function Draw_Mesh(b, nx, ny, Optional Line_Visible)
Dim s As Shape, U, v, s1, s_name
' Line_Visible: True / False
If IsMissing(Line_Visible) Then Line_Visible = msoTrue
hx = (b(2, 1) - b(1, 1)) / nx
hy = (b(2, 2) - b(1, 2)) / ny
With ActiveSheet.Shapes
    For i = 1 To nx
    For j = 1 To ny
        U = (i - 1) * hx + b(1, 1)
        v = (j - 1) * hy + b(1, 2)
        Set s = .AddShape(msoShapeRectangle, U, v, hx, hy)
        If Not Line_Visible Then s.Line.Visible = msoFalse
        If i = 1 And j = 1 Then
            s_name = s.Name
        Else
            s_name = AddShape(s_name, s.Name)
        End If
    Next j, i
End With
Draw_Mesh = s_name
End Function

Sub Draw_Zintensity(Mesh, p, zMax, zMin)
Dim s As Shape
Set s = ActiveSheet.Shapes(Mesh)
n = s.GroupItems.Count
nx = UBound(p, 1)
ny = UBound(p, 2)
    
For i = 1 To nx
For j = 1 To ny
    k = (i - 1) * ny + j
    z = 255 * p(i, j) / (zMax - zMin)
    s.GroupItems(k).Fill.ForeColor.RGB = RGB(z, z, z)
Next j, i

End Sub

'Function Draw_XAxes(box, plane)
'Dim p(), x, y, s1
''x axe
'If plane(1, 2) < 0 And plane(2, 2) > 0 Then
'    ReDim p(1 To 3, 1 To 2)
'    y = 0 ' '(plane(1, 2) + plane(2, 2)) / 2
'    x = plane(1, 1)
'    Transf x, y, p(1, 1), p(1, 2), plane, box
'    x = (plane(1, 1) + plane(2, 1)) / 2
'    Transf x, y, p(2, 1), p(2, 2), plane, box
'    x = plane(2, 1)
'    Transf x, y, p(3, 1), p(3, 2), plane, box
'    s1 = Draw_Curve(p)
'    Draw_XAxes = s1
'Else
'    Draw_XAxes = vbNullString
'End If
'End Function

Function Draw_XAxes(Box, plane)
Dim p(), x, y, s1
'x axe
If plane(1, 2) < 0 And plane(2, 2) > 0 Then
    ReDim p(1 To 2, 1 To 2)
    y = 0 ' '(plane(1, 2) + plane(2, 2)) / 2
    x = plane(1, 1)
    Transf x, y, p(1, 1), p(1, 2), plane, Box
    x = plane(2, 1)
    Transf x, y, p(2, 1), p(2, 2), plane, Box
    s1 = Draw_Line(p)
    ActiveSheet.Shapes(s1).Line.EndArrowheadStyle = msoArrowheadTriangle
    Draw_XAxes = s1
Else
    Draw_XAxes = vbNullString
End If
End Function

Function Draw_YAxes(Box, plane)
Dim p(), x, y, s2
'y axe
If plane(1, 1) < 0 And plane(2, 1) > 0 Then
    ReDim p(1 To 2, 1 To 2)
    x = 0 ' (plane(1, 1) + plane(2, 1)) / 2
    y = plane(1, 2)
    Transf x, y, p(1, 1), p(1, 2), plane, Box
    y = plane(2, 2)
    Transf x, y, p(2, 1), p(2, 2), plane, Box
    s1 = Draw_Line(p)
    ActiveSheet.Shapes(s1).Line.EndArrowheadStyle = msoArrowheadTriangle
    Draw_YAxes = s1
Else
    Draw_YAxes = vbNullString
End If
End Function

VBA Filename jconvert.bas Extracted Macro
'Jconvert.bas
'v. 15.6.2006 original by John Jones
'v. 19.6.2006 by John Jones + VL
'v. 25.6.2006 by John Jones + VL - corrects stb, loop detection, international separators, pi() error, <> precedence

Option Private Module
Option Explicit

Sub ConvIt()
Dim s$
s = " a + b + 1 - c "
s = ConvertIt(s, "DgMx", True)
Debug.Print s
End Sub

Function ConvertIt(sFM$, Optional Digit_Max, Optional CvtLogi As Boolean = False) As String
Dim FM$
FM = Replace(sFM, " ", vbNullString)
' This converts a well formed excel formula to the equivalent
' in terms of xadd etc. The advantage over x-evaluate is that
' the code can be debugged in normal excel using small values
' and in a familiar form. When the spreadsheet works it is
' converted to using nested x-calls for the precision work.
' the intention is to tag the conversion onto the copy worksheet function
' so that you end up with a multi-precision copy of the original.
'
' ORs   - doesnt deal with ! (factorial)
'       - is silent when nesting goes beyond 7 levels (excel 2000-2003 limit)
'       - _code technique means that code segments and their effects are not backed out even If a later step fails.
'       - doesn't deal with arrays ({1,2,3},{4,5,6}) as parameters
'       - doesn't handle functions with variable length parameters i.e. SUM(1,2,3,4,5). 1 array only
'       - improperly converts skipped functions parameters into strings.
'
' The technique is opaque to say the least. The crux is a simple
' annotated lexical analyser which runs as j-code (a simple stack machine)
' If all goes well it usually works, or silently leaves an exit reason.
' The source is an m4 (worse than gpm) macro language which makes the j-code
' simple (huh) to write
' this version of j-code is VB native but it still looks awful.
'
        
' here is the recogniser
' m4 prevents using the normal lex type constructs, [|] etc so here use whitespace
' separation for rather oddly named macros as follows
' note that there is no attempt to go for the max match unlike regular expressions.
' L(name) ... _endL recognises and swallows a portion of the formula returned as "w"
' _is(name) invokes same, normally followed by a pushvw sequence
' A sequence_1 I sequence_2 I sequence_3 Z recognises either sequence_1 2 or 3
' use A seq I Z For optional sequence seq
' N sequence_1 I sequence_2 I sequence_3 Z recognises neither sequence_1 2 or 3
' so in particular will exit a do loop If any match
' _do ... _od zero or more repeats of the enclosed
' _c(char,char,..) recognises a sequence of characters
' _code(jcode,jcode,...) inserts a sequence of jcode operations
' _x recognise any character - use in a _do loop with N..Z to come out at some point.
' _q recognise a quote (") character


'  _is(fe) _code(pusho(eof),popvm,jstop)
'  L(fe) A _c(+) _code(pusho(uplus)) I _c(-) _code(pusho(uminus)) I Z _is(ex) A _is(op) _is(fe) I Z _endL
'  L(ex) A _c(() _code(pusho(obrac)) _is(fe) _c()) _code(pusho(cbrac)) I
'        _is(mod) _c(() _code(pushow,pusho(fn),pusho(obrac),pushrm,pushrp,pusho(obrac)) _is(stc)
'                 _is(fe) _code(pusho(cbrac),popvm,poprp) _is(fe) _c()) _code(pusho(comma),dropo,swapvm,poprm,pusho(cbrac)) I
'        _is(string) _code(pushvw) I
'        _is(number) _code(pushvqw) I
'        _is(word) _c(() _code(pushow,pusho(fn),pusho(obrac)) _is(fe) _c()) _code(pusho(cbrac)) I
'        _is(word) _code(pushvw) Z _endL
'  L(string) _q _do A _q _q I N _q Z _x Z _od _q _endL
'  L(number) A _is(d) _do _is(d) _od A _ci(decsep) I Z I _ci(decsep) Z  _do _is(d) _od A _c(E) A _c(+) I _c(-) I Z _do _is(d) _od I Z _endL
'  L(stc) _is(stb) _ci(argsep) _endL
'  L(stb) _do N _c()) I _q I _c(() I _ci(argsep) Z _x _od _do A _is(string) I
'         _c(() _is(stb) _do _ci(argsep) _is(stb) _od _c()) Z _od _do N _ci(argsep) I _c()) Z _is(stb) _od _endL
'  L(op)  A _is(op1) _code(pushow,pusho(compcode)) I _is(op2) _code(pushow,pusho(opcode)) I _is(op3) _code(pushow,pusho(mul)) I
'         _c(^) _code(pusho(up)) I _ci(argsep) _code(pusho(comma)) Z _endL
'  L(op1) A _c(<,=) I _c(>,=) I _c(<,>) I _c(<) I _c(=) I _c(>) Z _endL
'  L(op2) A _c(+) I _c(-) I _c(&) Z _endL
'  L(op3) A _c(*) I _c(/) Z _endL
'  L(d) A _c(0) I _c(1) I _c(2) I _c(3) I _c(4) I _c(5) I _c(6) I _c(7) I _c(8) I _c(9) Z _endL
'  L(mod) A _c(M) I _c(m) Z A _c(O) I _c(o) Z A _c(D) I _c(d) Z _endL
'  L(word) _do N _c(() I _c()) I _is(jop) Z _trace(in word) _x _od _endL
'  L(jop)  A _c()) I _is(op1) I _is(op2) I _is(op3) I
'         _c(^) I _ci(argsep) Z _endL

' NB the only perverse bit is in dealing with Mod - the code sequence loops through the rest of the
' formula to find the matching modulus string, since this has to be applied to + _ / and ^ in
' the first part of the function. STC and STB do this by skipping strings and matching nested ()s
' another perversity is that "jop" should equal "op" with no code sequences.
' End of prog

' o-stack constants

Const uplus = 1         ' unary plus
Const uminus = 2        ' unary minus
Const obrac = 3         ' open bracket
Const cbrac = 4         ' close bracket
Const fn = 6            ' function (preceded by function name)
Const opcode = 7        ' op_code (preceded by operation code as a string - see op2)
Const compcode = 8      ' compcode - one of <> etc
Const mul = 9           ' multiplication-code (preceded by * or /)
Const up = 10           ' up_code (^) - exponentiation
Const comma = 11        ' comma_code
Const eof = 12          ' eof_code


' OPcode priorities For the o-stack

Dim inpri(eof), stpri(eof) As Integer

inpri(uplus) = 5:     stpri(uplus) = 5
inpri(uminus) = 5:    stpri(uminus) = 5
inpri(obrac) = 2:     stpri(obrac) = 16
inpri(cbrac) = 18:    stpri(cbrac) = 2
inpri(fn) = 4:        stpri(fn) = 4
inpri(opcode) = 10:   stpri(opcode) = 10
inpri(compcode) = 11: stpri(compcode) = 11
inpri(mul) = 8:       stpri(mul) = 8
inpri(up) = 6:        stpri(up) = 6 ' up brackets from the left as in excel.
inpri(comma) = 11:    stpri(comma) = 12 ' important - this means commas stack so enabling Mod operation
inpri(eof) = 20:      stpri(eof) = 20 ' eof stacks on nothing else

' j-machine
Const defStLen = 50 ' default stack length
'Const rstLen = 100 ' r-stack length
Dim rstLen%         ' r-stack length
rstLen = Len(FM)

If rstLen > DIGITS_LIMIT Then
  rstLen = DIGITS_LIMIT
ElseIf rstLen < 100 Then
  rstLen = 100
End If

Dim j As Integer                ' program counter
Dim p As Integer                ' pointer in formula
Dim m As String                 ' modulus string or blank
Dim n As Integer                ' number of iterations allowed in a do..od loop
Dim w As String                 ' word - substring of fm returned by an is(call)
Dim vs(defStLen) As String      ' value stack
Dim os(defStLen) As Integer     ' opcode stack
Dim osp(defStLen) As String     ' opcode parameter
ReDim rs(rstLen) As Variant       ' r-stack
Dim vp, op, rp As Integer       ' stack ptrs - always to the top or zero If clear
Dim writepos As Integer         ' diagnostic
Dim success As Boolean          ' set to indicate success or need to backtrack
Dim exitreason As String        ' returned instead of conversion If an error

Dim sdgt$, opn%, Temp, collapse As Boolean, oppar, optype, UseR As Boolean

' Internationalisation
Const sDecSep = "."
Const sArgSep = ","

vp = 0: op = 0: rp = 0: writepos = 2
m = vbNullString
w = vbNullString
n = rstLen ' allowed number of iterations in a do..od loop

j = 1
p = 1
success = False


'VL 19.6.2006. set the default For Digit_Max.
'Digit_Max may be:
'1) an integer number e.g. 30
'2) a fixed reference of a cell, e.g. $B$1
'3) a name of a cell, e.g. "digits"
'4) simply nothing.
If IsMissing(Digit_Max) Then
    sdgt = ")"  'nothing is the Xnumber default
Else
    sdgt = sArgSep & Digit_Max & ")"
    UseR = True
End If

On Error GoTo ErrorHandler ' probably due to an ill-formed function
' actual recogniser

 GoSub l_fe: If Not success Then GoTo endstring
  opn = eof: GoSub pusho: GoSub popvm: success = True: GoTo endstring

 ' fe
l_fe: GoSub pushrp:
 ' [
 GoSub pushrp: If Mid$(FM, p, 1) <> "+" Then GoTo J3
 p = p + 1: opn = uplus: GoSub pusho:
 ' |
 GoTo j2
J3: GoSub toprp: If Mid$(FM, p, 1) <> "-" Then GoTo J5
 p = p + 1: opn = uminus: GoSub pusho:
 ' |
 GoTo j2
J5: GoSub toprp:
 ' ]
 GoTo j2
J6: GoSub poprp: GoTo j0
j2: GoSub dropr: GoSub l_ex: If Not success Then GoTo j0
  
 ' [
 GoSub pushrp: GoSub l_op: If Not success Then GoTo J8
  GoSub l_fe: If Not success Then GoTo J8
  
 ' |
 GoTo J7
J8: GoSub toprp:
 ' ]
 GoTo J7
J10: GoSub poprp: GoTo j0
J7: GoSub dropr: GoTo j1
j0: GoSub poprp: success = False: Return

j1: GoSub setword: GoSub dropr: success = True: Return

 ' ex
l_ex: GoSub pushrp:
 ' [
 GoSub pushrp: If Mid$(FM, p, 1) <> "(" Then GoTo J14
 GoSub inc_p: opn = obrac: GoSub pusho: GoSub l_fe: If Not success Then GoTo J14
  If Mid$(FM, p, 1) <> ")" Then GoTo J14
 p = p + 1: opn = cbrac: GoSub pusho:
 ' |
 GoTo J13
J14: GoSub toprp:
       GoSub l_mod: If Not success Then GoTo J16
  If Mid$(FM, p, 1) <> "(" Then GoTo J16
 GoSub inc_p: GoSub pushow: opn = fn: GoSub pusho: opn = obrac: GoSub pusho: GoSub pushrm
 GoSub pushrp: opn = obrac: GoSub pusho: GoSub l_stc: If Not success Then GoTo J16
 
                GoSub l_fe: If Not success Then GoTo J16
  opn = cbrac: GoSub pusho: GoSub popvm: GoSub poprp: GoSub l_fe: If Not success Then GoTo J16
  If Mid$(FM, p, 1) <> ")" Then GoTo J16
 p = p + 1: opn = comma: GoSub pusho: GoSub dropo: GoSub swapvm: GoSub poprm
 opn = cbrac: GoSub pusho:
 ' |
 GoTo J13
J16: GoSub toprp:
       GoSub l_string: If Not success Then GoTo J17
  GoSub pushvw:
 ' |
 GoTo J13
J17: GoSub toprp:
       GoSub l_number: If Not success Then GoTo J18
  GoSub pushvqw:
 ' |
 GoTo J13
J18: GoSub toprp:
       GoSub l_word: If Not success Then GoTo J19
  If Mid$(FM, p, 1) <> "(" Then GoTo J19
 GoSub inc_p: GoSub pushow: opn = fn: GoSub pusho: opn = obrac: GoSub pusho: GoSub l_fe
 If Not success Then GoTo J19
  If Mid$(FM, p, 1) <> ")" Then GoTo J19
 p = p + 1: opn = cbrac: GoSub pusho:
 ' |
 GoTo J13
J19: GoSub toprp:
       GoSub l_word: If Not success Then GoTo J20
  GoSub pushvw:
 ' ]
 GoTo J13
J20: GoSub poprp: GoTo J11
J13: GoSub dropr: GoTo J12
J11: GoSub poprp: success = False: Return

J12: GoSub setword: GoSub dropr: success = True: Return

 ' string
l_string: GoSub pushrp: If Mid$(FM, p, 1) <> """" Then GoTo J21
 p = p + 1:
 ' DO
 GoSub pushrn:
J23: GoSub pushrp:
 ' [
 GoSub pushrp: If Mid$(FM, p, 1) <> """" Then GoTo J27
 p = p + 1: If Mid$(FM, p, 1) <> """" Then GoTo J27
 p = p + 1:
 ' |
 GoTo J26
J27: GoSub toprp:
 ' [^
 GoSub pushrp: If Mid$(FM, p, 1) <> """" Then GoTo J31
 p = p + 1:
 ' ]
 
J30: GoSub poprp: GoTo J29
J31: GoSub dropr:
 If p <= Len(FM) Then
 p = p + 1
 Else
 GoTo J29
 End If
 
 ' ]
 GoTo J26
J29: GoSub poprp: GoTo J24
J26: GoSub dropr:
 ' OD
 GoSub dropr: GoSub decr: GoTo J23
J24: GoSub poprp: GoSub dropr: If Mid$(FM, p, 1) <> """" Then GoTo J21
 p = p + 1: GoTo J22
J21: GoSub poprp: success = False: Return

J22: GoSub setword: GoSub dropr: success = True: Return

 ' number
l_number: GoSub pushrp:
 ' [
 GoSub pushrp: GoSub l_d: If Not success Then GoTo J36
  
 ' DO
 GoSub pushrn:
J38: GoSub pushrp: GoSub l_d: If Not success Then GoTo J39
  
 ' OD
 GoSub dropr: GoSub decr: GoTo J38
J39: GoSub poprp: GoSub dropr:
 ' [
 GoSub pushrp: If Mid$(FM, p, 1) <> sDecSep Then GoTo J42
 p = p + 1:
 ' |
 GoTo J41
J42: GoSub toprp:
 ' ]
 GoTo J41
J44: GoSub poprp: GoTo J36
J41: GoSub dropr:
 ' |
 GoTo J35
J36: GoSub toprp: If Mid$(FM, p, 1) <> sDecSep Then GoTo J45
 p = p + 1:
 ' ]
 GoTo J35
J45: GoSub poprp: GoTo J33
J35: GoSub dropr:
 ' DO
 GoSub pushrn:
J46: GoSub pushrp: GoSub l_d: If Not success Then GoTo J47
  
 ' OD
 GoSub dropr: GoSub decr: GoTo J46
J47: GoSub poprp: GoSub dropr:
 ' [
 GoSub pushrp: If Mid$(FM, p, 1) <> "E" Then GoTo J50
 p = p + 1:
 ' [
 GoSub pushrp: If Mid$(FM, p, 1) <> "+" Then GoTo J53
 p = p + 1:
 ' |
 GoTo J52
J53: GoSub toprp: If Mid$(FM, p, 1) <> "-" Then GoTo J55
 p = p + 1:
 ' |
 GoTo J52
J55: GoSub toprp:
 ' ]
 GoTo J52
J56: GoSub poprp: GoTo J50
J52: GoSub dropr:
 ' DO
 GoSub pushrn:
J57: GoSub pushrp: GoSub l_d: If Not success Then GoTo J58
  
 ' OD
 GoSub dropr: GoSub decr: GoTo J57
J58: GoSub poprp: GoSub dropr:
 ' |
 GoTo J49
J50: GoSub toprp:
 ' ]
 GoTo J49
J60: GoSub poprp: GoTo J33
J49: GoSub dropr: GoTo J34
J33: GoSub poprp: success = False: Return

J34: GoSub setword: GoSub dropr: success = True: Return

 ' stc
l_stc: GoSub pushrp: GoSub l_stb: If Not success Then GoTo J61
  If Mid$(FM, p, 1) <> sArgSep Then GoTo J61
  GoSub inc_p: GoTo J62
J61: GoSub poprp: success = False: Return

J62: GoSub setword: GoSub dropr: success = True: Return

 ' stb
l_stb: GoSub pushrp:
 ' DO
 GoSub pushrn:
J65: GoSub pushrp:
 ' [^
 GoSub pushrp: If Mid$(FM, p, 1) <> ")" Then GoTo J69
 p = p + 1:
 ' |
 GoTo J68
J69: GoSub toprp: If Mid$(FM, p, 1) <> """" Then GoTo J71
 p = p + 1:
 ' |
 GoTo J68
J71: GoSub toprp: If Mid$(FM, p, 1) <> "(" Then GoTo J72
 GoSub inc_p:
 ' |
 GoTo J68
J72: GoSub toprp: If Mid$(FM, p, 1) <> sArgSep Then GoTo J73
 GoSub inc_p:
 ' ]
 
J68: GoSub poprp: GoTo J66
J73: GoSub dropr:
 If p <= Len(FM) Then
 p = p + 1
 Else
 GoTo J66
 End If
 
 ' OD
 GoSub dropr: GoSub decr: GoTo J65
J66: GoSub poprp: GoSub dropr:
 ' DO
 GoSub pushrn:
J74: GoSub pushrp:
 ' [
 GoSub pushrp: GoSub l_string: If Not success Then GoTo J78
  
 ' |
 GoTo J77
J78: GoSub toprp:
        If Mid$(FM, p, 1) <> "(" Then GoTo J80
 GoSub inc_p: GoSub l_stb: If Not success Then GoTo J80
  
 ' DO
 GoSub pushrn:
J81: GoSub pushrp: If Mid$(FM, p, 1) <> sArgSep Then GoTo J82
 GoSub inc_p: GoSub l_stb: If Not success Then GoTo J82
  
 ' OD
 GoSub dropr: GoSub decr: GoTo J81
J82: GoSub poprp: GoSub dropr: If Mid$(FM, p, 1) <> ")" Then GoTo J80
 p = p + 1:
 ' ]
 GoTo J77
J80: GoSub poprp: GoTo J75
J77: GoSub dropr:
 ' OD
 GoSub dropr: GoSub decr: GoTo J74
J75: GoSub poprp: GoSub dropr:
 ' DO
 GoSub pushrn:
J84: GoSub pushrp:
 ' [^
 GoSub pushrp: If Mid$(FM, p, 1) <> sArgSep Then GoTo J88
 GoSub inc_p:
 ' |
 GoTo J87
J88: GoSub toprp: If Mid$(FM, p, 1) <> ")" Then GoTo J90
 p = p + 1:
 ' ]
 
J87: GoSub poprp: GoTo J85
J90: GoSub dropr: GoSub l_stb: If Not success Then GoTo J85
  
 ' OD
 GoSub dropr: GoSub decr: GoTo J84
J85: GoSub poprp: GoSub dropr: GoTo J64
J63: GoSub poprp: success = False: Return

J64: GoSub setword: GoSub dropr: success = True: Return

 ' op
l_op: GoSub pushrp:
 ' [
 GoSub pushrp: GoSub l_op1: If Not success Then GoTo J94
  GoSub pushow: opn = compcode: GoSub pusho:
 ' |
 GoTo J93
J94: GoSub toprp: GoSub l_op2: If Not success Then GoTo J96
  GoSub pushow: opn = opcode: GoSub pusho:
 ' |
 GoTo J93
J96: GoSub toprp: GoSub l_op3: If Not success Then GoTo J97
  GoSub pushow: opn = mul: GoSub pusho:
 ' |
 GoTo J93
J97: GoSub toprp:
        If Mid$(FM, p, 1) <> "^" Then GoTo J98
 p = p + 1: opn = up: GoSub pusho:
 ' |
 GoTo J93
J98: GoSub toprp: If Mid$(FM, p, 1) <> sArgSep Then GoTo J99
 GoSub inc_p: opn = comma: GoSub pusho:
 ' ]
 GoTo J93
J99: GoSub poprp: GoTo J91
J93: GoSub dropr: GoTo J92
J91: GoSub poprp: success = False: Return

J92: GoSub setword: GoSub dropr: success = True: Return

 ' op1
l_op1: GoSub pushrp:
 ' [
 GoSub pushrp: If Mid$(FM, p, 1) <> "<" Then GoTo J103
 p = p + 1: If Mid$(FM, p, 1) <> "=" Then GoTo J103
 p = p + 1:
 ' |
 GoTo J102
J103: GoSub toprp: If Mid$(FM, p, 1) <> ">" Then GoTo J105
 p = p + 1: If Mid$(FM, p, 1) <> "=" Then GoTo J105
 p = p + 1:
 ' |
 GoTo J102
J105: GoSub toprp: If Mid$(FM, p, 1) <> "<" Then GoTo J106
 p = p + 1: If Mid$(FM, p, 1) <> ">" Then GoTo J106
 p = p + 1:
 ' |
 GoTo J102
J106: GoSub toprp: If Mid$(FM, p, 1) <> "<" Then GoTo J107
 p = p + 1:
 ' |
 GoTo J102
J107: GoSub toprp: If Mid$(FM, p, 1) <> "=" Then GoTo J108
 p = p + 1:
 ' |
 GoTo J102
J108: GoSub toprp: If Mid$(FM, p, 1) <> ">" Then GoTo J109
 p = p + 1:
 ' ]
 GoTo J102
J109: GoSub poprp: GoTo J100
J102: GoSub dropr: GoTo J101
J100: GoSub poprp: success = False: Return

J101: GoSub setword: GoSub dropr: success = True: Return

 ' op2
l_op2: GoSub pushrp:
 ' [
 GoSub pushrp: If Mid$(FM, p, 1) <> "+" Then GoTo J113
 p = p + 1:
 ' |
 GoTo J112
J113: GoSub toprp: If Mid$(FM, p, 1) <> "-" Then GoTo J115
 p = p + 1:
 ' |
 GoTo J112
J115: GoSub toprp: If Mid$(FM, p, 1) <> "&" Then GoTo J116
 p = p + 1:
 ' ]
 GoTo J112
J116: GoSub poprp: GoTo J110
J112: GoSub dropr: GoTo J111
J110: GoSub poprp: success = False: Return

J111: GoSub setword: GoSub dropr: success = True: Return

 ' op3
l_op3: GoSub pushrp:
 ' [
 GoSub pushrp: If Mid$(FM, p, 1) <> "*" Then GoTo J120
 p = p + 1:
 ' |
 GoTo J119
J120: GoSub toprp: If Mid$(FM, p, 1) <> "/" Then GoTo J122
 p = p + 1:
 ' ]
 GoTo J119
J122: GoSub poprp: GoTo J117
J119: GoSub dropr: GoTo J118
J117: GoSub poprp: success = False: Return

J118: GoSub setword: GoSub dropr: success = True: Return

 ' d
l_d: GoSub pushrp:

 GoSub pushrp: If IsNumeric(Mid$(FM, p, 1)) Then GoTo J125n
  GoSub poprp: GoSub poprp: success = False: Return

J125n: p = p + 1: GoSub dropr: GoSub setword: GoSub dropr: success = True: Return


' ' [
' GoSub pushrp: If Mid$(fm, p, 1) <> vbStr0 Then GoTo J126
' p = p + 1:
' ' |
' GoTo J125
'J126: GoSub toprp: If Mid$(fm, p, 1) <> vbStr1 Then GoTo J128
' p = p + 1:
' ' |
' GoTo J125
'J128: GoSub toprp: If Mid$(fm, p, 1) <> "2" Then GoTo J129
' p = p + 1:
' ' |
' GoTo J125
'J129: GoSub toprp: If Mid$(fm, p, 1) <> "3" Then GoTo J130
' p = p + 1:
' ' |
' GoTo J125
'J130: GoSub toprp: If Mid$(fm, p, 1) <> "4" Then GoTo J131
' p = p + 1:
' ' |
' GoTo J125
'J131: GoSub toprp: If Mid$(fm, p, 1) <> "5" Then GoTo J132
' p = p + 1:
' ' |
' GoTo J125
'J132: GoSub toprp: If Mid$(fm, p, 1) <> "6" Then GoTo J133
' p = p + 1:
' ' |
' GoTo J125
'J133: GoSub toprp: If Mid$(fm, p, 1) <> "7" Then GoTo J134
' p = p + 1:
' ' |
' GoTo J125
'J134: GoSub toprp: If Mid$(fm, p, 1) <> "8" Then GoTo J135
' p = p + 1:
' ' |
' GoTo J125
'J135: GoSub toprp: If Mid$(fm, p, 1) <> "9" Then GoTo J136
' p = p + 1:
' ' ]
' GoTo J125
'J136: GoSub poprp: GoTo J123
'J125: GoSub dropr: GoTo J124
'J123: GoSub poprp: success = False: Return
'
'J124: GoSub setword: GoSub dropr: success = True: Return

 ' mod
l_mod: GoSub pushrp:
 ' [
 GoSub pushrp: If Mid$(FM, p, 1) <> "M" Then GoTo J140
 p = p + 1:
 ' |
 GoTo J139
J140: GoSub toprp: If Mid$(FM, p, 1) <> "m" Then GoTo J142
 p = p + 1:
 ' ]
 GoTo J139
J142: GoSub poprp: GoTo J137
J139: GoSub dropr:
 ' [
 GoSub pushrp: If Mid$(FM, p, 1) <> "O" Then GoTo J144
 p = p + 1:
 ' |
 GoTo J143
J144: GoSub toprp: If Mid$(FM, p, 1) <> "o" Then GoTo J146
 p = p + 1:
 ' ]
 GoTo J143
J146: GoSub poprp: GoTo J137
J143: GoSub dropr:
 ' [
 GoSub pushrp: If Mid$(FM, p, 1) <> "D" Then GoTo J148
 p = p + 1:
 ' |
 GoTo J147
J148: GoSub toprp: If Mid$(FM, p, 1) <> "d" Then GoTo J150
 p = p + 1:
 ' ]
 GoTo J147
J150: GoSub poprp: GoTo J137
J147: GoSub dropr: GoTo J138
J137: GoSub poprp: success = False: Return

J138: GoSub setword: GoSub dropr: success = True: Return

 ' word
l_word: GoSub pushrp:
 ' DO
 GoSub pushrn:
J153: GoSub pushrp:
 ' [^
 GoSub pushrp: If Mid$(FM, p, 1) <> "(" Then GoTo J157
 GoSub inc_p:
 ' |
 GoTo J156
J157: GoSub toprp: If Mid$(FM, p, 1) <> ")" Then GoTo J159
 p = p + 1:
 ' |
 GoTo J156
J159: GoSub toprp: GoSub l_jop: If Not success Then GoTo J160
  
 ' ]
 
J156: GoSub poprp: GoTo J154
J160: GoSub dropr:
 If p <= Len(FM) Then p = p + 1 Else GoTo J154
 
 ' OD
 GoSub dropr: GoSub decr: GoTo J153
J154: GoSub poprp: GoSub dropr: GoTo J152
J151: GoSub poprp: success = False: Return

J152: GoSub setword: GoSub dropr: success = True: Return

 ' jop
l_jop: GoSub pushrp:
 ' [
 GoSub pushrp: If Mid$(FM, p, 1) <> ")" Then GoTo J164
 p = p + 1:
 ' |
 GoTo J163
J164: GoSub toprp: GoSub l_op1: If Not success Then GoTo J166
  
 ' |
 GoTo J163
J166: GoSub toprp: GoSub l_op2: If Not success Then GoTo J167
  
 ' |
 GoTo J163
J167: GoSub toprp: GoSub l_op3: If Not success Then GoTo J168
  
 ' |
 GoTo J163
J168: GoSub toprp:
        If Mid$(FM, p, 1) <> "^" Then GoTo J169
 p = p + 1:
 ' |
 GoTo J163
J169: GoSub toprp: If Mid$(FM, p, 1) <> sArgSep Then GoTo J170
 GoSub inc_p:
 ' ]
 GoTo J163
J170: GoSub poprp: GoTo J161
J163: GoSub dropr: GoTo J162
J161: GoSub poprp: success = False: Return

J162: GoSub setword: GoSub dropr: success = True: Return

' If jstop is executed the program will not reach here, so

exitreason = "run past End": GoTo BadExit

inc_p: p = p + 1: If Mid$(FM, p, 1) = " " Then GoTo inc_p
Return

' Here are the j machine operations - many could be moved inline at the expense
' of complete illegibility

pushrp:
        If rp > rstLen - 2 Then GoTo StkRfull
        rp = rp + 1: rs(rp) = p
        Return

pushrm:
        If rp > rstLen - 2 Then GoTo StkRfull
        rp = rp + 1: rs(rp) = m
        Return

pushrn:
        If rp > rstLen - 2 Then GoTo StkRfull
        rp = rp + 1: rs(rp) = n
        Return

decr: rs(rp) = rs(rp) - 1
        If rs(rp) <= 0 Then
                exitreason = "too many do..od iterations": GoTo BadExit
        End If
        Return

pushvm:
        If vp > rstLen - 2 Then GoTo StkVfull
        vp = vp + 1: vs(vp) = m
        Return

poprp:
        p = rs(rp): rp = rp - 1
        If rp < 0 Then GoTo StkRunder
        Return

poprm:
        m = rs(rp): rp = rp - 1
        If rp < 0 Then GoTo StkRunder
        Return

toprp:
        p = rs(rp)
        Return

dropr:
        rp = rp - 1
        If rp < 0 Then GoTo StkRunder
        Return

swaprp:
        Temp = rs(rp): rs(rp) = p: p = Temp
        Return

swaprm:
        Temp = rs(rp): rs(rp) = m: m = Temp
        Return

swapvm:
        Temp = vs(vp): vs(vp) = m: m = Temp
        Return

setword: ' assumes that top of r is the p value on entry to the l(call)
        w = Mid$(FM, rs(rp), p - rs(rp))
        Return

pushvw:
        If vp > defStLen - 2 Then GoTo StkVfull
        vp = vp + 1: vs(vp) = w
        Return

pushvqw:
        If vp > defStLen - 2 Then GoTo StkVfull
        vp = vp + 1: vs(vp) = """" & w & """"
        Return

pushow:
        If op > defStLen - 2 Then GoTo StkOfull
        osp(op + 1) = w  ' stack ptr will move with pusho
        Return

dropo:
        op = op - 1
        If op < 0 Then
                exitreason = "stack o underflow": GoTo BadExit
        End If
        Return

popvm:
        m = vs(vp): vp = vp - 1
        If vp < 0 Then
                exitreason = "stack v underflow": GoTo BadExit
        End If
        Return

pusho:
        If op > defStLen - 2 Then GoTo StkOfull
        op = op + 1: os(op) = opn
        ' now we need to collapse the stack If its top is too heavy
        ' this is effectively the railway shunt algorithm
        collapse = True
        While collapse And (op > 1)
        If inpri(os(op)) >= stpri(os(op - 1)) Then
          opn = os(op - 1): oppar = osp(op - 1)
          os(op - 1) = os(op): osp(op - 1) = osp(op)
          op = op - 1
          Select Case opn
           Case uplus
            ' no need For it
           Case uminus
            vs(vp) = "xNeg(" & vs(vp) & ")"
           Case obrac
            op = op - 1 ' remove cbrac as well
           Case fn
            optype = "xdigits"
            Select Case Trim$(LCase$(oppar))
            Case "abs":         oppar = "xAbs":       optype = "xalone"
            Case "acos":        oppar = "xAcos"
            Case "acosh":       oppar = "xAcosh"
            Case "and": optype = "xalone": If CvtLogi Then oppar = "x_And"
            Case "asin":        oppar = "xAsin"
            Case "asinh":       oppar = "xAsinh"
            Case "atan":        oppar = "xAtan"
            Case "atan2":       oppar = "xAtan2":     optype = "reverse"
            Case "atanh":       oppar = "xAtanh"
            Case "average":     oppar = "xMean"
            Case "avedev":      oppar = "xAveDev"
            Case "besseli":     oppar = "BesselIx":   optype = "xalone"
            Case "besselj":     oppar = "BesselJx":   optype = "xalone"
            Case "besselk":     oppar = "BesselKx":   optype = "xalone"
            Case "bessely":     oppar = "BesselYx":   optype = "xalone"
            Case "binomdist", "binom.dist": oppar = "xBinomial"
            Case "ceiling":     oppar = "xCeil":      optype = "xalone"
            Case "combin":      oppar = "xComb"
            Case "complex":     oppar = "xCplx":      optype = "xalone"
            Case "concatenate": oppar = "xCat":       optype = "addfirst"
            Case "correl":      oppar = "xCorrel"
            Case "cos":         oppar = "xCos"
            Case "cosh":        oppar = "xCosh"
            Case "covar":       oppar = "xCoVar"
            Case "degrees":     oppar = "xDegrees"
            Case "delta":       oppar = "xDelta":     optype = "xalone"
            Case "devsq":       oppar = "xDevSq"
            Case "erf", "erf.precise": oppar = "xERF"
            Case "erfc", "erfc.precise": oppar = "xERFC"
            Case "even":        oppar = "xEven":      optype = "xalone"
            Case "exp":         oppar = "xExp"
            Case "fact":        oppar = "xFact"
            Case "factdouble":  oppar = "xFact2"
            Case "fisher":      oppar = "xFisher"
            Case "fisherinv":   oppar = "xFishInv"
            Case "floor":       oppar = "xFloor":     optype = "xalone"
            Case "gammaln":     oppar = "xGammaLn":   optype = "xalone"
            Case "gcd":         oppar = "xMCD":       optype = "xalone"
            Case "geomean":     oppar = "xGmean"
            Case "gestep":      oppar = "xGEstep":    optype = "xalone"
            Case "harmean":     oppar = "xHmean"
            Case "if": optype = "xalone": If CvtLogi Then oppar = "x_If"
            Case "imabs":       oppar = "xCplxAbs"
            Case "imaginary":   oppar = "xImag":      optype = "xalone"
            Case "imargument":  oppar = "xCplxArg"
            Case "imconjugate": oppar = "xCplxConj":  optype = "xalone"
            Case "imcos":       oppar = "xCplxCos"
            Case "imdiv":       oppar = "xCplxDiv"
            Case "imexp":       oppar = "xCplxExp"
            Case "imln":        oppar = "xCplxLn"
            Case "imlog10":     oppar = "xCplxLog10"
            Case "imlog2":      oppar = "xCplxLog2"
            Case "impower":     oppar = "xCplxPow"
            Case "improduct":   oppar = "xCplxMult"
            Case "imreal":      oppar = "xReal":      optype = "xalone"
            Case "imsin":       oppar = "xCplxSin"
            Case "imsqrt":      oppar = "xCplxSqr"
            Case "imsub":       oppar = "xCplxSub"
            Case "imsum":       oppar = "xCplxAdd"
            Case "int":         oppar = "xInt":       optype = "xalone"
            Case "intercept":   oppar = "xIntercept"
            Case "iseven":      oppar = "xIsEven":    optype = "xalone"
            Case "isodd":       oppar = "xIsOdd":     optype = "xalone"
            Case "lcm":         oppar = "xMCM":       optype = "xalone"
            Case "ln":          oppar = "xLn"
            Case "log":         oppar = "xLog"
            Case "log10":       oppar = "xCplxLog10"
            Case "lognorm.dist": oppar = "xLogNorm"
            Case "max":         oppar = "xMax":       optype = "xalone"
            Case "mdeterm":     oppar = "xMatDet"
            Case "median":      oppar = "xMedian":    optype = "xalone"
            Case "min":         oppar = "xMin":       optype = "xalone"
            Case "minverse":    oppar = "xMatInv"
            Case "mmult":       oppar = "xMatMult"
            Case "mod":         oppar = "xIntMod":    optype = "xalone"
            Case "mode", "mode.sngl": oppar = "xMode": optype = "xalone"
            Case "mround":      oppar = "xMround":    optype = "xalone"
            Case "multinomial": oppar = "xMultinom"
            Case "normdist", "norm.dist": oppar = "xNormal"
            Case "normsdist":   oppar = "xNormS"
            Case "norm.s.dist": oppar = "xNormalS"
            Case "not": optype = "xalone": If CvtLogi Then oppar = "x_Not"
            Case "odd":         oppar = "xOdd":       optype = "xalone"
            Case "or": optype = "xalone": If CvtLogi Then oppar = "x_Or"
            Case "pearson":     oppar = "xPearson"
            Case "permut":      oppar = "xPerm"
            Case "pi":          oppar = "xPi"
            Case "power":       oppar = "xExpBase"
            Case "product":     oppar = "xProd"
            Case "quotient":    oppar = "xDivTrunc":  optype = "xalone"
            Case "radians":     oppar = "xRadians"
            Case "rand":        oppar = "xRand"
            Case "randbetween": oppar = "xRandI"
            Case "rank", "rank.eq": oppar = "xRank":  optype = "xalone"
            Case "round":       oppar = "xRound":     optype = "xalone"
            Case "rounddown":   oppar = "xRdown":     optype = "xalone"
            Case "roundup":     oppar = "xRup":       optype = "xalone"
            Case "rsq":         oppar = "xRsq"
            Case "seriessum":   oppar = "xSerSum"
            Case "sign":        oppar = "xCompZ":     optype = "xalone"
            Case "sin":         oppar = "xSin"
            Case "sinh":        oppar = "xSinh"
            Case "slope":       oppar = "xSlope"
            Case "sqrt", "sqr": oppar = "xSqr"
            Case "sqrtpi":      oppar = "xSqrPi"
            Case "stdev", "stdev.s": oppar = "xStdev"
            Case "stdevp", "stdev.p": oppar = "xStdevp"
            Case "sum":         oppar = "xSum"
            Case "sumproduct":  oppar = "xSumProd"
            Case "sumsq":       oppar = "xSumSq"
            Case "sumxmy2":     oppar = "xSumXmY2"
            Case "sumx2my2":    oppar = "xSumX2mY2"
            Case "sumx2py2":    oppar = "xSumX2pY2"
            Case "tan":         oppar = "xTan"
            Case "tanh":        oppar = "xTanh"
            Case "trunc":       oppar = "xTrunc":     optype = "xalone"
            Case "var", "var.s": oppar = "xVar"
            Case "varp", "var.p": oppar = "xVarp"
            Case "weibull", "weibull.dist": oppar = "xWeibull"
            Case Else:                                optype = "xalone"  ' leave it alone - eg "If" etc
            End Select
            Select Case optype
              Case "xdigits"
                If Len(vs(vp)) <> 0 Then
                  vs(vp) = oppar & "(" & vs(vp) & sdgt
                Else
                  If sdgt = ")" Then
                    vs(vp) = oppar & "()"
                  Else
                    vs(vp) = oppar & "(" & Mid$(sdgt, 2) 'remove the argsep
                  End If
                End If
              Case "reverse"
                vs(vp) = oppar & "(" & vs(vp + 1) & "," & _
                  Left$(vs(vp), InStr(2, vs(vp), sArgSep) - 1) & sdgt
              Case "addfirst"
                vs(vp) = oppar & "(," & vs(vp) & ")"
              Case Else ' "xalone"
                vs(vp) = oppar & "(" & vs(vp) & ")"
            End Select
          Case opcode
            vp = vp - 1
            Select Case oppar
              Case "+"
                If Len(m) = 0 Then
                  If vp <> 1 And UseR Then
                    vs(vp) = "xAddR(" & vs(vp) & "," & vs(vp + 1) & sdgt
                  Else
                    vs(vp) = "xAdd(" & vs(vp) & "," & vs(vp + 1) & sdgt
                  End If
                Else
                  vs(vp) = "xAddMod(" & vs(vp) & "," & vs(vp + 1) & "," & m & ")"
                End If
              Case "-"
                If Len(m) = 0 Then
                  If vp <> 1 And UseR Then
                    vs(vp) = "xSubR(" & vs(vp) & "," & vs(vp + 1) & sdgt
                  Else
                    vs(vp) = "xSub(" & vs(vp) & "," & vs(vp + 1) & sdgt
                  End If
                Else
                  vs(vp) = "xSubMod(" & vs(vp) & "," & vs(vp + 1) & "," & m & ")"
                End If
              Case "&"
                vs(vp) = vs(vp) & "&" & vs(vp + 1)
            End Select
          Case mul
            vp = vp - 1
            Select Case oppar
              Case "*"
                If Len(m) = 0 Then
                  If vp <> 1 And UseR Then
                    vs(vp) = "xMultR(" & vs(vp) & "," & vs(vp + 1) & sdgt
                  Else
                    vs(vp) = "xMult(" & vs(vp) & "," & vs(vp + 1) & sdgt
                  End If
                Else
                  vs(vp) = "xMultMod(" & vs(vp) & "," & vs(vp + 1) & "," & m & ")"
                End If
              Case "/"
                If Len(m) = 0 Then
                  If vp <> 1 And UseR Then
                    vs(vp) = "xDivR(" & vs(vp) & "," & vs(vp + 1) & sdgt
                  Else
                    vs(vp) = "xDiv(" & vs(vp) & "," & vs(vp + 1) & sdgt
                  End If
                Else
                  vs(vp) = "xDivMod(" & vs(vp) & "," & vs(vp + 1) & "," & m & ")"
                End If
              Case Else ' error Case
                exitreason = "oppar error " & oppar: GoTo BadExit
            End Select
          Case up
            vp = vp - 1
            If Len(m) = 0 Then
              vs(vp) = "xExpBase(" & vs(vp) & "," & vs(vp + 1) & sdgt
            Else
              vs(vp) = "xPowMod(" & vs(vp) & "," & vs(vp + 1) & "," & m & sdgt
            End If
          Case comma
            vp = vp - 1
            vs(vp) = vs(vp) & "," & vs(vp + 1)
          Case compcode ' comparison operator
            vp = vp - 1
            vs(vp) = "xComp(" & vs(vp) & "," & vs(vp + 1) & ")" & oppar & vbStr0
          Case Else ' error Case
            exitreason = "opcode error " & opn: GoTo BadExit
          End Select
        Else
          collapse = False
        End If
        Wend
        Return
        
StkVfull: exitreason = "stack v full": GoTo BadExit
StkOfull: exitreason = "stack o full": GoTo BadExit
StkRfull: exitreason = "stack r full": GoTo BadExit
StkRunder: exitreason = "stack r underflow": GoTo BadExit
ErrorHandler: exitreason = "VB Error"
BadExit: success = False
endstring:
' here m is the converted formula If success
      If success Then
        If Len(m) = 0 Then GoTo ErrorHandler
' Internationalisation, fix DecSep in strings
        If DecSep <> "." Then
          For j = 1 To Len(m)
            If Mid$(m, j, 1) = "." Then Mid$(m, j, 1) = DecSep
          Next
        End If
        ConvertIt = m
      Else
        ConvertIt = """! " & exitreason & """"
      End If
End Function

VBA Filename xBaseChange_50.bas Extracted Macro
Option Explicit
'mod. 3.9.2006 VL
'****************************************************************************
'*       XBaseChange                                            Ton Jeursen *
'*                                                                          *
'*       This routine is open source and freeware.                          *
'*       tonjeursen@hotmail.com                                             *
'****************************************************************************

'****************************************************************************
'*       XBaseChange                                            Ton Jeursen *
'*                                                                          *
'*       This function converts a number from any base (2 .. >1 million).   *
'*       A number is entered like                                           *
'*              xBaseChange(oldnumber[oldbase],newbase).                    *
'*       The oldnumber is assumed to be base 10 if no oldbase is            *
'*       provided between square brackets [].                               *
'*                                                                          *
'*       Digits of numbers with a base higher than 10 must be               *
'*       separated with a colon :       9:34:9:23[36]                       *
'*                                                                          *
'*       Example:      xBaseChange("9:34:9:23[36]",7)                       *
'*       Results in:   3642455[7]                                           *
'*                                                                          *
'*       Example:      xBaseChange("1098414",16)                            *
'*       Results in:   10C2AE[16]                                           *
'*                                                                          *
'*       Example:      xBaseChange(1098414,46)                              *
'*       Results in:   11:13:4:26[46]                                       *
'*                                                                          *
'*       Example       xBaseChange(1098414.987,"0416")  fills with zeros    *
'*       Results in:   006:144:174,410:246:113:063:096:212:...[0416]        *
'*                                                                          *
'****************************************************************************

Const xBC_Testen = False
Const xBC_Decimals = 55
'                    50 is just fast enough
'                    100 is slow
'                    200 is too slow to work with

Const xBC_DigitSep = ":" 'colon

Const xBC_BaseSep0 = "["
Const xBC_BaseSep9 = "]"
Const xBC_Err = "* ERROR * "
Const xBC_Dots = "..."
Const xBC_Letters = 36 - 1 'for hex etc.

Const xBC_i0 = 1
Const xBC_i9 = xBC_Decimals

Const xBC_f0 = 1
Const xBC_f9 = xBC_Decimals

Dim xBC_g1i(), xBC_g2i() As Long, xBC_g3i() As Long
Dim xBC_g1f(), xBC_g2f() As Long, xBC_g3f() As Long
Dim xBC_Error
Dim xBC_OldNum$, xBC_OldBase, xBC_OldNum_i, xBC_OldNum_f
Dim xBC_NewNum, xBC_NewBase
Dim xBC_ri, xBC_DigitSep5, xBC_temp, h$
Dim xBC_CommaPos, xBC_CommaPosSign
Dim xBC_from0, xBC_from9
Dim xBC_Address, xBC_Text, deep
Dim xBC_Address0, xBC_Negative As Boolean

Dim xBC_i1 ' 1
Dim xBC_i8 ' xBC_decimals
Dim xBC_f1 ' 1
Dim xBC_f8 ' xBC_decimals

Function xBaseChange(xBC__OldNum, Optional xBC__NewBase, Optional deep_)
Attribute xBaseChange.VB_Description = "Multiprecision base conversion"
Attribute xBaseChange.VB_HelpID = 305
Attribute xBaseChange.VB_ProcData.VB_Invoke_Func = " \n14"
'  Application.Volatile
  Dim i
If VarType(xBC__OldNum) = vbString Then
  xBC_OldNum = xBC__OldNum
Else
  xBC_OldNum = dCStr_(xBC__OldNum)
End If
  'replace base letters with [digits]
  Select Case LCase$(Right$(xBC_OldNum, 1))
  Case "b": xBC_OldNum_i = Left$(xBC_OldNum, Len(xBC_OldNum) - 1) & "[2]"
  Case "o": xBC_OldNum_i = Left$(xBC_OldNum, Len(xBC_OldNum) - 1) & "[8]"
  Case "q": xBC_OldNum_i = Left$(xBC_OldNum, Len(xBC_OldNum) - 1) & "[8]"
  Case "d": xBC_OldNum_i = Left$(xBC_OldNum, Len(xBC_OldNum) - 1) & "[10]"
  Case "x": xBC_OldNum_i = Left$(xBC_OldNum, Len(xBC_OldNum) - 1) & "[10]"
  Case "h": xBC_OldNum_i = Left$(xBC_OldNum, Len(xBC_OldNum) - 1) & "[16]"
  End Select
  'remove trailing dots ..... (as in 4,5927777777...)
  xBC_OldNum = Replace(xBC_OldNum, "'" & xBC_Dots, vbNullString)
  xBC_OldNum = Replace(xBC_OldNum, xBC_Dots, vbNullString)
  
  'if no new base is chosen, new base is 10
  If IsMissing(xBC__NewBase) Then xBC_NewBase = 10 Else xBC_NewBase = CDbl_(xBC__NewBase)
  
  'clear arrays
  ReDim xBC_g1i(xBC_i0 To xBC_i9), xBC_g2i(xBC_i0 To xBC_i9), xBC_g3i(xBC_i0 To xBC_i9)
  ReDim xBC_g1f(xBC_f0 To xBC_f9), xBC_g2f(xBC_f0 To xBC_f9), xBC_g3f(xBC_f0 To xBC_f9)

  '---------------------------------------------------
  'find old base
  xBC_Error = xBaseChange_FindOldBase(xBC_OldNum, xBC_OldBase, xBC_NewBase)
  If xBC_Error = xBC_Err Then xBaseChange = xBC_Err & "old base error": Exit Function
  
  'set number of decimal places
  If IsMissing(deep_) Then deep = xBC_f9 Else deep = min_(CDbl_(deep_), xBC_f9)
'  If IsMissing(deep) Then deep = Log(xBC_NewBase) / Log(xBC_OldBase)  'VL
  
  'find sign, comma and comma sign (. ,)
  xBC_CommaPos = 0: xBC_CommaPosSign = vbNullString
  If Asc(xBC_OldNum) = vbKeyMinus Then xBC_Negative = True Else xBC_Negative = False
  If InStr(xBC_OldNum, ".") > 0 Then xBC_CommaPos = InStr(xBC_OldNum, "."): xBC_CommaPosSign = "."
  If InStr(xBC_OldNum, ",") > 0 Then xBC_CommaPos = InStr(xBC_OldNum, ","): xBC_CommaPosSign = ","
  If xBC_CommaPos <> 0 Then
    xBC_OldNum_i = Left$(xBC_OldNum, xBC_CommaPos - 1)
    xBC_OldNum_f = Mid$(xBC_OldNum, xBC_CommaPos + 1)
  Else
    xBC_OldNum_i = xBC_OldNum
    xBC_OldNum_f = vbNullString
  End If
  
  '---------------------------------------------------
  'add separators if necessary
  xBC_DigitSep5 = InStr(xBC_OldNum, xBC_DigitSep)
  
  'add seperators
  'separator for short number e.g. 12[60] is not required
  If xBC_DigitSep5 = 0 Then
    xBC_temp = xBC_OldNum
    xBC_OldNum = vbNullString
    For i = 1 To Len(xBC_temp)
      xBC_OldNum = xBC_OldNum & Mid$(xBC_temp, i, 1) + xBC_DigitSep
    Next i
  End If
  xBC_OldNum = Replace(xBC_OldNum, xBC_DigitSep & xBC_CommaPosSign & xBC_DigitSep, xBC_CommaPosSign)
  
  '---------------------------------------------------
  'replace letters with digits for hexadecimal etc.
  xBC_temp = xBC_OldNum
  xBC_OldNum = vbNullString
  For i = 1 To Len(xBC_temp)
    h$ = LCase$(Mid$(xBC_temp, i, 1))
    If h$ >= "a" And h$ <= "z" Then h$ = Trim$(Asc(h$) - 97 + 10)
    xBC_OldNum = xBC_OldNum & h$
  Next i
  
  '---------------------------------------------------
  'handle decimal point or xBC_CommaPos
  xBC_CommaPos = 0: xBC_CommaPosSign = vbNullString
  If InStr(xBC_OldNum, ".") > 0 Then xBC_CommaPos = InStr(xBC_OldNum, "."): xBC_CommaPosSign = "."
  If InStr(xBC_OldNum, ",") > 0 Then xBC_CommaPos = InStr(xBC_OldNum, ","): xBC_CommaPosSign = ","
  If xBC_CommaPos <> 0 Then
    xBC_OldNum_i = Left$(xBC_OldNum, xBC_CommaPos - 1)
    xBC_OldNum_f = Mid$(xBC_OldNum, xBC_CommaPos + 1)
  Else
    xBC_OldNum_i = xBC_OldNum
    xBC_OldNum_f = vbNullString
  End If
  
  '---------------------------------------------------
  'split number into integer and fractional part
  xBaseChange_Splitter xBC_OldNum, xBC_OldBase                        'xBC_OldNum -> xBC_g1i()
  If xBC_Error = xBC_Err Then xBaseChange = xBC_Err & "split integer/fraction error": Exit Function
  
  '---------------------------------------------------
  'do the conversion
  xBaseChange_Calc_i xBC_OldBase, xBC_NewBase                         ' calculate integer part
  xBaseChange_Calc_f xBC_OldBase, xBC_NewBase                         ' calculate fractional part
  
  '---------------------------------------------------
  'replace digits with letters for hexadecimal etc. (2..36)
  If xBC_NewBase <= xBC_Letters Then
    For i = 1 To xBC_Decimals
      If xBC_g1i(i) > 9 Then xBC_g1i(i) = Chr$(xBC_g1i(i) + 97 - 10 - 32)
      If xBC_g1f(i) > 9 Then xBC_g1f(i) = Chr$(xBC_g1f(i) + 97 - 10 - 32)
    Next i
  End If
  
  'merge all separate items
  xBC_NewNum = xBaseChange_Together(xBC_OldNum, xBC_OldBase, xBC_NewBase, deep)
  xBC_NewNum = xBC_NewNum & "[" & IIf(Asc(xBC_NewBase) = vbKey0, vbStr0, vbNullString) & Trim$(str$(xBC_NewBase)) & "]"
  If Left$(xBC_NewNum, 1) = xBC_DigitSep Then xBC_NewNum = Mid$(xBC_NewNum, 2)
  If xBC_Negative Then xBC_NewNum = "-" & xBC_NewNum
  
  'ready
  xBaseChange = xBC_NewNum
End Function

Private Function xBaseChange_FindOldBase(xBC_OldNum, xBC_OldBase, xBC_NewBase)
  xBC_from0 = InStr(xBC_OldNum, xBC_BaseSep0)
  xBC_from9 = InStr(xBC_OldNum, xBC_BaseSep9)
  
  If xBC_from0 <> 0 And xBC_from9 <> 0 Then                         '[ ]
    xBC_from0 = xBC_from0 + 1
    xBC_from9 = xBC_from9 - 1
    If xBC_from9 >= xBC_from0 Then
      xBC_OldBase = Val(Mid$(xBC_OldNum, xBC_from0, xBC_from9 - xBC_from0 + 1))
      xBC_OldNum = Left$(xBC_OldNum, xBC_from0 - 2)
    Else
      xBaseChange_FindOldBase = xBC_Err & vbStr1
      Exit Function
    End If
  End If
  If (xBC_from0 <> 0 And xBC_from9 = 0) Or (xBC_from0 = 0 And xBC_from9 <> 0) Then
    xBaseChange_FindOldBase = xBC_Err & vbStr2
    Exit Function
  End If
  If xBC_from0 = 0 And xBC_from9 = 0 Then
    xBC_OldBase = 10
    If InStrRev(xBC_OldNum, "E", -1, vbTextCompare) Then _
      xBC_OldNum = xFmt(xBC_OldNum, DIGITS_LIMIT, DIGITS_LIMIT) 'Remove scientific format
  End If
  If xBC_DigitSep5 > 0 And xBC_from0 = 0 And xBC_from9 = 0 Then
    xBaseChange_FindOldBase = xBC_Err & "3"
    Exit Function
  End If
  
  xBaseChange_FindOldBase = vbNullString
End Function

Private Sub xBaseChange_Splitter(xBC_OldNum, xBC_OldBase)
  If xBC_CommaPos > 0 Then
    If Left$(xBC_OldNum_i, 1) = xBC_DigitSep Then xBC_OldNum_i = Mid$(xBC_OldNum_i, 2)
    If Right$(xBC_OldNum_i, 1) = xBC_DigitSep Then xBC_OldNum_i = Left$(xBC_OldNum_i, Len(xBC_OldNum_i) - 1)
    xBaseChange_Splitter_i xBC_OldNum_i, xBC_OldBase
    '
    If Left$(xBC_OldNum_f, 1) = xBC_DigitSep Then xBC_OldNum_f = Mid$(xBC_OldNum_f, 2)
    If Right$(xBC_OldNum_f, 1) = xBC_DigitSep Then xBC_OldNum_f = Left$(xBC_OldNum_f, Len(xBC_OldNum_f) - 1)
    xBaseChange_Splitter_f xBC_OldNum_f, xBC_OldBase
  Else
    If Left$(xBC_OldNum_i, 1) = xBC_DigitSep Then xBC_OldNum_i = Mid$(xBC_OldNum_i, 2)
    If Right$(xBC_OldNum_i, 1) = xBC_DigitSep Then xBC_OldNum_i = Left$(xBC_OldNum_i, Len(xBC_OldNum_i) - 1)
    xBaseChange_Splitter_i xBC_OldNum_i, xBC_OldBase
  End If
End Sub
'
Private Sub xBaseChange_Splitter_i(xBC_OldNum, xBC_OldBase)
  Dim i, gi, h$, hh$, g
'  Dim splitter_   'VL
  gi = xBC_i9
  hh$ = vbNullString
  g = xBC_DigitSep & xBC_OldNum
  For i = Len(g) To 1 Step -1
    h$ = Mid$(g, i, 1)
    If IsNumeric(h$) Then hh$ = h$ & hh$
    If h$ = xBC_DigitSep Then
      xBC_g1i(gi) = Val(hh$)
      If xBC_g1i(gi) >= xBC_OldBase Then xBC_Error = xBC_Err & "i": Exit Sub
      gi = gi - 1
      hh$ = vbNullString
    End If
  Next i
  xBC_Error = vbNullString
End Sub

Private Sub xBaseChange_Splitter_f(xBC_OldNum, xBC_OldBase)
  Dim f, gf, h$, hh$, g
  gf = xBC_f0
  hh$ = vbNullString
  g = xBC_OldNum & xBC_DigitSep
  For f = 1 To Len(g)
    h$ = Mid$(g, f, 1)
    If IsNumeric(h$) Then hh$ = hh$ & h$
    If h$ = xBC_DigitSep Then
      xBC_g1f(gf) = Val(hh$)
      If xBC_g1f(gf) >= xBC_OldBase Then xBC_Error = xBC_Err & "f": Exit Sub
      gf = gf + 1
      hh$ = vbNullString
    End If
  Next f
  xBC_Error = vbNullString
End Sub

'here starts the integer conversion
Private Sub xBaseChange_Calc_i(xBC_OldBase, xBC_NewBase)
  Dim i As Integer
  
  'find first non-zero element
  xBC_i1 = 0
  For i = xBC_i0 To xBC_i9
    If Val(xBC_g1i(i)) <> 0 Then xBC_i1 = i: Exit For
  Next
  
  If xBC_OldBase < xBC_NewBase Then
   xBC_i1 = xBC_i9 - (xBC_i9 - xBC_i1) * Log(xBC_OldBase) / Log(xBC_NewBase) - 4
   If xBC_i1 < xBC_i0 Then xBC_i1 = xBC_i0
  End If
  
  xBC_ri = xBC_i9
  For i = xBC_i0 + 1 To xBC_i9
    xBC_g3i(xBC_ri) = xBaseChange_Calc_i_(xBC_OldBase, xBC_NewBase)
    xBC_ri = xBC_ri - 1
  Next
  For i = xBC_i0 To xBC_i9: xBC_g1i(i) = xBC_g3i(i): Next
End Sub

Private Function xBaseChange_Calc_i_(xBC_OldBase, xBC_NewBase)
  Dim i, d
  
  ReDim xBC_g2i(xBC_i0 To xBC_i9)
  For i = xBC_i0 + 1 To xBC_i9
    If xBC_g1i(i - 1) > 0 Or xBC_g1i(i) > 0 Then
        xBC_g1i(i) = xBC_OldBase * xBC_g1i(i - 1) + xBC_g1i(i)
        d = Int(CDbl(xBC_g1i(i) / xBC_NewBase))
        xBC_g1i(i) = xBC_g1i(i) - d * xBC_NewBase
        xBC_g2i(i) = xBC_g2i(i) + d
        If xBC_g1i(i) >= xBC_NewBase Then
            xBC_g1i(i) = xBC_g1i(i) - xBC_NewBase
            xBC_g2i(i) = xBC_g2i(i) + 1
        End If
    End If
  Next i
  xBaseChange_Calc_i_ = xBC_g1i(xBC_i9)
  For i = xBC_i0 To xBC_i9: xBC_g1i(i) = xBC_g2i(i): Next
  ReDim xBC_g2i(xBC_i0 To xBC_i9)
End Function

'here starts the fraction conversion
Private Sub xBaseChange_Calc_f(xBC_OldBase, xBC_NewBase)
  Dim f
  xBC_ri = xBC_f0
  For f = xBC_f9 - 1 To xBC_f0 Step -1
    xBC_g3f(xBC_ri) = xBaseChange_Calc_f_(xBC_OldBase, xBC_NewBase)
    xBC_ri = xBC_ri + 1
  Next
  For f = xBC_f0 To xBC_f9: xBC_g1f(f) = xBC_g3f(f): Next
  If xBC_g1f(xBC_f9) <> 0 Then xBC_g1f(xBC_f9) = xBC_g1f(xBC_f9) + 1: If xBC_g1f(xBC_f9) = xBC_NewBase Then CalcAdjf xBC_f9, xBC_NewBase
  If xBC_g1f(xBC_f9 - 1) <> 0 Then xBC_g1f(xBC_f9 - 1) = xBC_g1f(xBC_f9 - 1) + 1: If xBC_g1f(xBC_f9 - 1) = xBC_NewBase Then CalcAdjf xBC_f9 - 1, xBC_NewBase
End Sub
Private Sub CalcAdjf(ByVal f, xBC_NewBase)
TryAgain:
xBC_g1f(f) = 0: f = f - 1
If f < xBC_f0 Then Exit Sub
xBC_g1f(f) = xBC_g1f(f) + 1
If xBC_g1f(f) = xBC_NewBase Then GoTo TryAgain
End Sub

Private Function xBaseChange_Calc_f_(xBC_OldBase, xBC_NewBase)
  Dim f
  ReDim xBC_g2f(xBC_f0 To xBC_f9)
  For f = xBC_f9 - 1 To xBC_f0 Step -1
    If xBC_g2f(f + 1) > 0 Or xBC_g1f(f) > 0 Then
      xBC_g1f(f) = xBC_g2f(f + 1) + xBC_g1f(f) * xBC_NewBase
      xBC_g2f(f) = xBC_g1f(f) \ xBC_OldBase
      xBC_g1f(f) = xBC_g1f(f) Mod xBC_OldBase
    End If
  Next f
  xBaseChange_Calc_f_ = xBC_g2f(xBC_f0)
End Function

Private Function xBaseChange_Together(xBC_OldNum, xBC_OldBase, xBC_NewBase, deep)
  Dim vnb, vns, i
  Dim pre, pres, NeedDots As Boolean
  
  'decide how many zeros go before xBC_OldNum
  If Asc(xBC_NewBase) = vbKey0 Then
    pre = Application.WorksheetFunction.Log10(xBC_NewBase)
    If Int(pre) <> pre Then pre = Int(pre) + 1
  End If
  pres = String$(pre, vbKey0)
  
  'find first significant digit of integer part
  vnb = xBC_f9
  For i = xBC_f9 To xBC_f0 Step -1
    If xBC_g1i(i) <> vbStr0 Then vnb = i
  Next i
  'put together integer part
  vns = vbNullString
  For i = vnb To xBC_i9
    If xBC_NewBase > xBC_Letters Then
      If Asc(xBC_NewBase) = vbKey0 Then
        vns = vns & xBC_DigitSep & Right$(pres & xBC_g1i(i), pre)
      Else
        vns = vns & xBC_DigitSep & xBC_g1i(i)
      End If
    Else
      vns = vns & xBC_g1i(i)
    End If
  Next i
  xBaseChange_Together = vns
  If Len(xBC_CommaPosSign) = 0 Then Exit Function
  
  'find last significant digit of fractional part
  vnb = xBC_f0
  For i = xBC_f0 To xBC_f9
    If xBC_g1f(i) <> 0 Then vnb = i
  Next i
  If vnb >= deep Then vnb = deep: NeedDots = True
  'put together fractional part
  vns = vbNullString
  For i = xBC_f0 To vnb
    If xBC_NewBase > xBC_Letters Then
      If Asc(xBC_NewBase) = vbKey0 Then
        vns = vns & xBC_DigitSep & Right$(pres & xBC_g1f(i), pre)
      Else
        vns = vns & xBC_DigitSep & xBC_g1f(i)
      End If
    Else
      vns = vns & xBC_g1f(i)
    End If
  Next i
  If Left$(vns, 1) = xBC_DigitSep Then vns = Mid$(vns, 2)
  
  xBaseChange_Together = xBaseChange_Together & xBC_CommaPosSign & vns
  If NeedDots Then xBaseChange_Together = xBaseChange_Together & xBC_Dots
End Function

VBA Filename xCalc_50.bas Extracted Macro
'mod. v. 1.1 3-9-06
Option Explicit

'****************************************************************************
'*       XCalc                                                  Ton Jeursen *
'*                                                                          *
'*       This routine is open source and freeware.                          *
'*       tonjeursen@hotmail.com                                             *
'****************************************************************************

'****************************************************************************
'*       XCalc                                                  Ton Jeursen *
'*                                                                          *
'*       Formulas can be entered just like in Excel.                        *
'*       This function uses the Xnumbers functions to calculate them        *
'*       in multiprecision.                                                 *
'*       Function included are:                                             *
'*       + - * / ^                                                          *
'*       ABS ACOS ACOSH ASIN ASINH ATAN ATANH                               *
'*       COMBIN COS COSH EXP FACT INT LN LOG MOD                            *
'*       PI ROUND SIGN SIN SINH SQRT TAN TANH                               *
'*                                                                          *
'*       References to other workbooks are supported, but may result        *
'*       in an error when the file name has multiple single or double       *
'*       quotes.                                                            *
'*                                                                          *
'****************************************************************************

'system separators for Application.Caller.Formula independent of international settings
Const xC_DecSepSys = "."
Const xC_LstSepSys = ","

Function xCalc(Formula, Optional Digit_Max)
Attribute xCalc.VB_Description = "Multiprecision Excel formula evaluation"
Attribute xCalc.VB_HelpID = 306
Attribute xCalc.VB_ProcData.VB_Invoke_Func = " \n14"
On Error GoTo EH
Dim xC_Digits_%, xC_Form$, n%, l%
If IsMissing(Digit_Max) Then
  xC_Digits_ = Digits_Def
Else
  SetDigit_Max Digit_Max
  xC_Digits_ = Digit_Max
End If
n = VarType(Formula)
If n = vbError Or xIsNumeric(Formula) Then ' does the formula resolve to a number?
  If IsObject(Formula) Then
    xC_Form = Formula.Formula
    xC_Form = Right$(xC_Form, Len(xC_Form) - 1) 'extract formula to be calculated
  Else
    xC_Form = Application.Caller.Formula   ' extract formula
    n = InStr(1, xC_Form, "xCalc(", vbTextCompare)
    If n = 0 Then
      xC_Form = Application.ThisCell.Formula   ' extract formula
      n = InStr(1, xC_Form, "xCalc(", vbTextCompare)
      If n = 0 Then xCalc = "ERROR: Application.Caller.Formula": Exit Function
    End If
    If IsMissing(Digit_Max) Then
      l = InStrRev(xC_Form, "(")
      If l = n + 5 Then
        xC_Form = Left$(xC_Form, InStr(l, xC_Form, ")"))
      Else
        xC_Form = Left$(xC_Form, InStr(InStr(l, xC_Form, ")") + 1, xC_Form, ")"))
      End If
    Else
      xC_Form = Left$(xC_Form, InStrRev(xC_Form, xC_LstSepSys) - 1) & ")"  ' take off Digit_Max part
    End If
    xC_Form = Right$(xC_Form, Len(xC_Form) - n - 4) 'extract formula to be calculated
  End If
ElseIf n = vbString Then
    xC_Form = Formula
Else
  Exit Function
End If
  
  xC_Form = x_si_ListSep(xC_Form)
  
  xC_Form = xPrexC_Eval_Clc(xC_Form)    ' turn xdiv into div etc.
  xC_Form = xFindCellRef(xC_Form)       ' replace A1, L56, etc. with value
  xCalc = xC_Eval(xC_Form, xC_Digits_)  ' do the calculation in multiprec.
  Exit Function
EH: xCalc = Err.Description
End Function

Private Function xC_Eval(ByVal Expr$, ByVal DgtMax%)
'compute a numerical expression in multiprecision using the Function xEval
'translate Excel function names into MathParser names

   Expr = Replace(Expr, "pi1(0)", "pi")
   Expr = Replace(Expr, "sign", "sgn")
   Expr = Replace(Expr, "combin", "comb")

'evaluate the numerical string

   xC_Eval = xEval(Expr, , DgtMax)
   
End Function

Private Function xPrexC_Eval_Clc(ByVal Expr$)
  Dim xPE$, xl%, i%
  
  Expr = LCase$(Expr)
  Expr = Replace(Expr, "pi(", "pi1(")
  Expr = Replace(Expr, "pi1()", "pi1(0)")
  Expr = Replace(Expr, "pi2()", "pi2(0)")
  Expr = Replace(Expr, "pi4()", "pi4(0)")
  
  xl = 4: xPE = "sqrt.asin.acos.atan."
  For i = 1 To Len(xPE) Step xl + 1
    Expr = Replace(Expr, "x" & Mid$(xPE, i, xl), Mid$(xPE, i, xl))
  Next i
  
  xl = 3: xPE = "sin.cos.tan.atn.sqr.log.exp.pi2.pi4.not.abs.int."
  For i = 1 To Len(xPE) Step xl + 1
    Expr = Replace(Expr, "x" & Mid$(xPE, i, xl), Mid$(xPE, i, xl))
  Next i
  
  xl = 2: xPE = "ln.pi."
  For i = 1 To Len(xPE) Step xl + 1
    Expr = Replace(Expr, "x" & Mid$(xPE, i, xl), Mid$(xPE, i, xl))
  Next i
  
  xPrexC_Eval_Clc = Expr
  
End Function

Private Function x_si_DecSep(k$)
  x_si_DecSep = Replace(k, xC_DecSepSys, DecSep)
End Function

Private Function x_si_ListSep(k$)
  x_si_ListSep = Replace(k, xC_LstSepSys, ArgSep)
End Function

'****************************************************************************
'*       xFindCellRef    Find cell references in a string       Ton Jeursen *
'*                       and replace them with the cell value               *
'*                                                                          *
'*       This routine is open source and freeware.                          *
'*       jeursen@zonnet.nl                                                  *
'****************************************************************************

Private Function xFindCellRef(x)
  Const xCellRefBegin = "abcdefghijklmnopqrstuvwxyz'$"
  Const xCellRefToEnd = xCellRefBegin & "0123456789_!" '+ " ~@#$%^&|+"  '\/?*[] are not allowed.
                                                                        '. (dot) gives errors.
  Const xFunctionBegin = "("     'first character of a function
  
  Const xSpecialSheetBegin = "'" 'first character of a special sheet name: single quote
  Const xSpecialSheetEnd = "'!"  'last characters of a special sheet name: single quote + excl.mark
  
  Const xWorkbookBegin = "["     'first character of a workbook name: square bracket
  Const xWorkbookEnd = "]"       'last character of a workbook name: square bracket
  
  'not working yet for workbook names with multiple single quotes
  Const xSpecialWorkbookBegin = "'[" 'first character of a special workbook name: single quote + square bracket
  Const xSpecialWorkbookEnd = "'!"   'last characters of a special workbook name: single quote + excl.mark
  
  Dim x1$, xh, i, j, teken, teken0, Ref, RefSheet, SN, sn1, fsn$
  fsn = "'[" & Application.Caller.Worksheet.Parent.Name & "]" & Application.Caller.Worksheet.Name & "'!"
 
  x1 = vbNullString
  x = "(" & x & ")"  'x = xSetDecSep(x)
  
  RefSheet = vbNullString
  For i = 1 To Len(x)
    teken = LCase$(Mid$(x, i, 1))
    
    If teken = xSpecialWorkbookBegin Then ' this is a workbook name, goto ]
      Do
        SN = InStr(i, x, xSpecialWorkbookEnd)
        sn1 = InStr(i, x, "'" & xSpecialWorkbookEnd)
        If SN - 1 <> sn1 Then
          RefSheet = Mid$(x, i, SN - i) & xSpecialWorkbookEnd
          i = SN + Len(xSpecialWorkbookEnd)
          teken0 = True
          teken = LCase$(Mid$(x, i, 1))
          Exit Do
        End If
      Loop Until SN - 1 <> sn1
    End If
    
    If teken = xWorkbookBegin Then ' this is a workbook name, goto ]
      Do
        SN = InStr(i, x, xSpecialWorkbookEnd)
        sn1 = InStr(i, x, "'" & xSpecialWorkbookEnd)
        If SN - 1 <> sn1 Then
          RefSheet = Mid$(x, i, SN - i) & xWorkbookEnd
          i = SN + Len(xWorkbookEnd)
          teken0 = True
          teken = LCase$(Mid$(x, i, 1))
          Exit Do
        End If
      Loop Until SN - 1 <> sn1
    End If
    
    If teken = xSpecialSheetBegin Then ' this is a sheet name, goto '!
      Do
        SN = InStr(i, x, xSpecialWorkbookEnd)
        sn1 = InStr(i, x, "'" & xSpecialWorkbookEnd)
        If SN - 1 <> sn1 Then
          RefSheet = Mid$(x, i, SN - i) & xSpecialSheetEnd
          i = SN + Len(xSpecialSheetEnd)
          teken0 = True
          teken = LCase$(Mid$(x, i, 1))
          Exit Do
        Else
          i = SN + 1
        End If
      Loop Until SN - 1 <> sn1
    End If
    
    If InStr(xCellRefBegin, teken) > 0 Then
      Ref = teken
      For j = i + 1 To Len(x)
        teken = LCase$(Mid$(x, j, 1))
        teken0 = False
        If Len(x1) > 0 And teken = xFunctionBegin Then ' this is a function
          x1 = x1 & Ref & teken
          teken0 = True
          Exit For
        End If
        If InStr(xCellRefToEnd, teken) > 0 Then  ' dit is een deel van een verwijzing
          Ref = Ref & teken
          teken0 = True
        End If
        If Not teken0 Then ' dit een verwijzing
          If Len(RefSheet) = 0 Then RefSheet = fsn
          xh = dCStr_(Range(RefSheet & Ref).Value)
          xh = "(" & xh & ")"                     'VL 4.9.06
          Ref = vbNullString
          RefSheet = vbNullString
          x1 = x1 & xh & teken
          Exit For
        End If
      Next j
      i = j
    Else
      x1 = x1 & teken
    End If
  Next i
  
  x1 = x_si_DecSep(x1)
  xFindCellRef = x1
End Function
VBA Filename frmD3integr.frm Extracted Macro

Option Explicit
'Dim UserChoice As Long
Dim Layout&, R0&, C0&, Tstart As Single, Ttot#, s$

Private Sub CommandButton_help_Click()
Application.Help XHelpFile, 307
End Sub

Private Sub CommandButton_run_Click()
'UserChoice = 1
If Len(Me.RefEdit_Fxyz) = 0 Then
    MsgBox "polynomial missing", vbExclamation
    Me.RefEdit_Fxyz.SetFocus
    Exit Sub
ElseIf Len(Me.RefEdit_Xmax) = 0 Then
    MsgBox "X bounding limit missing", vbExclamation
    Me.RefEdit_Xmax.SetFocus
    Exit Sub
ElseIf Len(Me.RefEdit_Xmin) = 0 Then
    MsgBox "X bounding limit missing", vbExclamation
    Me.RefEdit_Xmin.SetFocus
    Exit Sub
ElseIf Len(Me.RefEdit_Ymax) = 0 Then
    MsgBox "Y bounding limit missing", vbExclamation
    Me.RefEdit_Ymax.SetFocus
    Exit Sub
ElseIf Len(Me.RefEdit_Ymin) = 0 Then
    MsgBox "Y bounding limit missing", vbExclamation
    Me.RefEdit_Ymin.SetFocus
    Exit Sub
ElseIf Len(Me.RefEdit_Zmax) = 0 Then
    MsgBox "Z bounding limit missing", vbExclamation
    Me.RefEdit_Zmax.SetFocus
    Exit Sub
ElseIf Len(Me.RefEdit_Zmin) = 0 Then
    MsgBox "Z bounding limit missing", vbExclamation
    Me.RefEdit_Zmin.SetFocus
    Exit Sub
End If

If Len(Me.RefEdit_Out) = 0 Then Set_Default_Output_Cell
Me.Label_msg = "running..."
DoEvents

Integration3D_Starts

Me.Label_msg = "elaboration end"

End Sub

Private Sub OptionButton1_Click()
    Variable_Label_set
End Sub
Private Sub OptionButton2_Click()
    Variable_Label_set
End Sub
Private Sub OptionButton3_Click()
    Variable_Label_set
End Sub


Private Sub UserForm_Activate()
Me.Label_msg = vbNullString
Me.OptionButton1 = True
If Not ActiveCell Is Nothing Then
  If Not IsEmpty(ActiveCell) Then
    Me.RefEdit_Fxyz = ActiveCell.Address
    Set_output_range
  End If
End If
Variable_Label_set
End Sub

Private Sub UserForm_Initialize()
'nothing to do
End Sub

Private Sub Set_output_range()
Dim myRange As Range, s$
Set myRange = Range(Me.RefEdit_Fxyz)
R0 = myRange.Row
C0 = myRange.Column
If Not IsEmpty(Cells(R0, C0 + 1)) Then 'guess layout horizontal
  Layout = 0
  Me.RefEdit_Xmin = Cells(R0, C0 + 1).Address
  If IsEmpty(Cells(R0, C0 + 2)) Then GoTo SetOutCell
  Me.RefEdit_Xmax = Cells(R0, C0 + 2).Address
  If IsEmpty(Cells(R0, C0 + 3)) Then GoTo SetOutCell
  Me.RefEdit_Ymin = Cells(R0, C0 + 3).Address
  If IsEmpty(Cells(R0, C0 + 4)) Then GoTo SetOutCell
  Me.RefEdit_Ymax = Cells(R0, C0 + 4).Address
  If IsEmpty(Cells(R0, C0 + 5)) Then GoTo SetOutCell
  Me.RefEdit_Zmin = Cells(R0, C0 + 5).Address
  If IsEmpty(Cells(R0, C0 + 6)) Then GoTo SetOutCell
  Me.RefEdit_Zmax = Cells(R0, C0 + 6).Address
  If Not IsEmpty(Cells(R0, C0 + 7)) Then If R0 <> 1 Then _
    If Not IsEmpty(Cells(R0 - 1, C0 + 7)) Then _
      Param_Address_Right R0 - 1, C0 + 7, s: Me.RefEdit_Param = s
ElseIf Not IsEmpty(Cells(R0 + 1, C0)) Then
  Layout = 1
  Me.RefEdit_Xmin = Cells(R0 + 1, C0).Address
  If IsEmpty(Cells(R0 + 2, C0)) Then GoTo SetOutCell
  Me.RefEdit_Xmax = Cells(R0 + 2, C0).Address
  If IsEmpty(Cells(R0 + 3, C0)) Then GoTo SetOutCell
  Me.RefEdit_Ymin = Cells(R0 + 3, C0).Address
  If IsEmpty(Cells(R0 + 4, C0)) Then GoTo SetOutCell
  Me.RefEdit_Ymax = Cells(R0 + 4, C0).Address
  If IsEmpty(Cells(R0 + 5, C0)) Then GoTo SetOutCell
  Me.RefEdit_Zmin = Cells(R0 + 5, C0).Address
  If IsEmpty(Cells(R0 + 6, C0)) Then GoTo SetOutCell
  Me.RefEdit_Zmax = Cells(R0 + 6, C0).Address
  If Not IsEmpty(Cells(R0 + 7, C0)) Then If C0 <> 1 Then _
    If Not IsEmpty(Cells(R0 + 7, C0 - 1)) Then _
      Param_Address_Down R0 + 7, C0 - 1, s: Me.RefEdit_Param = s
End If
SetOutCell: Set_Default_Output_Cell
End Sub

Sub Set_Default_Output_Cell()
    If Layout = 1 Then
        Me.RefEdit_Out = Cells(R0, C0 + 2).Address
    Else
        Me.RefEdit_Out = Cells(R0 + 2, C0).Address
    End If
End Sub


Private Sub Integration3D_Starts()
Dim Fxyz$, kMax&, ErrMax#, SysCoor%, Param, ParamRange$
Dim Bound_min(1 To 3), Bound_max(1 To 3), results(), ErrMsg$, Out_Range, Lay
Dim U(1 To 2, 1 To 5), v, i&, j&

'initialization
Tstart = Timer
Ttot = 0
With Me
  If .OptionButton1 Then SysCoor = 1
  If .OptionButton2 Then SysCoor = 2
  If .OptionButton3 Then SysCoor = 3
  
  kMax = .TextBox_Kmax
  Fxyz = .RefEdit_Fxyz
  Bound_min(1) = .RefEdit_Xmin
  Bound_min(2) = .RefEdit_Ymin
  Bound_min(3) = .RefEdit_Zmin
  Bound_max(1) = .RefEdit_Xmax
  Bound_max(2) = .RefEdit_Ymax
  Bound_max(3) = .RefEdit_Zmax
  ParamRange = .RefEdit_Param
  ErrMax = .TextBox_Error
End With

'substitute cell references with their values
If InStr(Fxyz, "$") Then Fxyz = Range(Fxyz).Value
For i = 1 To 3
    If InStr(Bound_min(i), "$") Then Bound_min(i) = Range(Bound_min(i)).Value
    If InStr(Bound_max(i), "$") Then Bound_max(i) = Range(Bound_max(i)).Value
Next i

'substitutes the coordinate system variables (if any)
For i = 1 To 3
    Bound_min(i) = Replace_SysVar(Bound_min(i))
    Bound_max(i) = Replace_SysVar(Bound_max(i))
Next i

If Len(ParamRange) <> 0 Then
    If IsNumeric(ParamRange) Then Param = ParamRange Else Param = Range(ParamRange)
    Integral_3D_N1 Fxyz, Bound_min, Bound_max, results, kMax, ErrMsg, ErrMax, SysCoor, Param
Else
    Integral_3D_N1 Fxyz, Bound_min, Bound_max, results, kMax, ErrMsg, ErrMax, SysCoor
End If
'
Ttot = Timer - Tstart + Ttot
GoSub Write_Results
Exit Sub
'
'internal routine ------------
Write_Results:
    Out_Range = Me.RefEdit_Out
    'setting results for output
    R0 = Range(Out_Range).Row
    C0 = Range(Out_Range).Column
    If Len(ErrMsg) = 0 Or ErrMsg = "Evaluation error" Then
        If Len(ErrMsg) <> 0 Then
            ErrMsg = "Singularity: dubious accuracy"
        End If
        U(1, 1) = "Integral"
        U(1, 2) = "Err. rel."
        U(1, 3) = "Points"
        U(1, 4) = "Time"
        U(1, 5) = vbNullString
        U(2, 1) = results(1)
        U(2, 2) = results(3)
        U(2, 3) = results(4) + results(5)
        U(2, 4) = Ttot
        U(2, 5) = ErrMsg
        
    Else
        U(1, 1) = ErrMsg
    End If
    v = U
    If Lay = 1 Then v = Application.WorksheetFunction.Transpose(v)
Dim OrigCalcStatus As Integer
On Error Resume Next
OrigCalcStatus = Application.Calculation
Application.Calculation = xlCalculationManual
    For i = 1 To UBound(v, 1)
    For j = 1 To UBound(v, 2)
        Cells(R0 + i - 1, C0 + j - 1) = v(i, j)
    Next j, i
    If Len(ErrMsg) <> 0 Then
        Me.Label_msg = ErrMsg
    Else
        Me.Label_msg = "Elaboration end"
    End If
Application.Calculation = OrigCalcStatus
Return
End Sub

Function TimeStop(n) As Boolean
Dim t0#, t1#, r%
t0 = Timer - Tstart
t1 = t0 + Ttot
Me.Label_msg = Format(t1, "0.00") & "  (" & n & ")"
DoEvents
If t0 > 10 Then
    Ttot = t1 'elapsed time
    r = MsgBox("Do you want to continue", vbInformation + vbYesNo)
    If r = vbNo Then
        TimeStop = True
        Exit Function
    End If
    Tstart = Timer 'reinitialize
End If
End Function


Private Sub Variable_Label_set()
If Me.OptionButton1 Then
    Me.Label_1.Font = "Tahoma"
    Me.Label_1 = "x"
    Me.Label_2.Font = "Tahoma"
    Me.Label_2 = "y"
    Me.Label_3.Font = "Tahoma"
    Me.Label_3 = "z"

ElseIf Me.OptionButton2 Then
    Me.Label_1.Font = "Symbol"
    Me.Label_1 = "r"
    Me.Label_2.Font = "Symbol"
    Me.Label_2 = "q"
    Me.Label_3.Font = "Symbol"
    Me.Label_3 = "f"
    
ElseIf Me.OptionButton3 Then
    Me.Label_1.Font = "Symbol"
    Me.Label_1 = "r"
    Me.Label_2.Font = "Symbol"
    Me.Label_2 = "q"
    Me.Label_3.Font = "Tahoma"
    Me.Label_3 = "z"
    
End If
End Sub

'substitutes the polar and cylindrical varibales (r, q, f) -> ( x, y, z)
'or (ro, theta, phi) -> (x, y, z)
Private Function Replace_SysVar(ByVal sFormula)
    replace_substr sFormula, "r", "x"
    replace_substr sFormula, "q", "y"
    replace_substr sFormula, "f", "z"
    replace_substr sFormula, "ro", "x"
    replace_substr sFormula, "theta", "y"
    replace_substr sFormula, "phi", "z"
    Replace_SysVar = sFormula
End Function

'check if it is a letter
Private Function IsLetter(ByVal char$) As Boolean
  Dim code As Integer
  code = Asc(char)
  IsLetter = (65 <= code And code <= 90) Or (97 <= code And code <= 122) Or char = "_"
End Function

Private Sub replace_substr(s, s1, s2)
Dim i%, c1$, c2$, ss1$, ss2$
i = 1
Do
    i = InStr(i, s, s1, vbTextCompare)
    If i = 0 Then Exit Do
    If i > 1 Then c1 = Mid$(s, i - 1, 1) Else c1 = " "
    If i < Len(s) Then c2 = Mid$(s, i + Len(s1), 1) Else c2 = " "
    If Not IsLetter(c1) And Not IsLetter(c2) And Not IsNumeric(c2) Then
        ss1 = Left$(s, i - 1)
        ss2 = Right$(s, Len(s) - Len(s1) - i + 1)
        s = ss1 + s2 + ss2
    End If
    i = i + 1
Loop

End Sub

VBA Filename XnumbPrivate.bas Extracted Macro
Option Explicit
Option Private Module

'********************************************************************************************
'****** You should NOT alter this module unless you really know what you are doing **********
'********************************************************************************************
'#Compile Time Constants - XnumbPrivate Module only

' Must set AutoPacketSize to False to activate "Custom" PacketSize and NumOfPackets
Public Const AutoPacketSize As Boolean = True
#Const PacketSize = 8
Const NumOfPackets& = 102

#Const RetUnFmtStr = False

'Xnumbers now alters this module dynamically when DIGITS_LIMIT or RetUnFmtStr is changed from
'the configuration screen, or when installing in a 32/64bit environment that is different than
'the last saved disk image. It is still possible to hard code a PacketSize by setting
'AutoPacketSize to False, but some features are then disabled.
'32bit should choose PacketSize 6 if more than 630 digits are desired(PacketSize 7 Max)
'64bit should choose PacketSize 7 if more than 7376 digits are desired(PacketSize 8 Max)
'PacketSizes 5 & 9-14 appear to no longer have any utility, they are just slower.
'Some functions are quite slow if more than a few hundred digits are requested. These
'include but are not limited to the x Derivatives, x Gamma, Beta, Zeta and the ERF functions.
'When Compiling and Saving a new Add-In no spreadsheet that calls the add-in should be loaded.
'When Switching Platforms, 32/64 bit or different versions of Excel, a full DeCompile is
'recommended. Please see:  http://cpap.com.br/orlando/VBADecompilerMore.asp?IdC=Help
'Set appropriate NumOfPackets for xNum.dgt[n] and its PacketSize (5-14)
' The Original Xnumbers.xla v.5.6 set 95 and 6 for 250 digits
' NumOfPackets Compilation Max of 8188 for 32bit, 16377 for 64bits
' Problematic when DIGITS_LIMIT (NumOfPackets * PacketSize(xBASE))is < 35 or > 32765
' PacketSize|NumOfPackets Max (based on variable-type overflow or 32765 DIGITS_LIMIT)
'  14  |  7
'  13  |  792
'  12  |  2730
'  11  |  2978
'  10  |  3276
'   9  |  9    64bit, 3640 32bit
'   8  |  922  64bit, 4095 32bit
'   7  |  4680 64bit, 90   32bit
'   6  |  5460
'   5  |  6553
'
'***NOTE TO 64bit Users***
'***Please see:  http://support.microsoft.com/kb/2454202
'***As of Feb 2012 Microsoft has still deemed it appropriate to degrade VBA's stack by 80%.
'***Stack Problems can exist when NumOfPackets is too large, especially in custom VBA modules.
'***Hopefully this will be fixed in some future release.

'Run Time Public variables only avail to this VBA Project(Private Module)
' Set the Version #
Public Const xNver$ = "6.0.5.6"
Public Const xNumTitle$ = "Multi-Precision Floating Point Calculus"

'VBA7,VBA6 and Win64 = 1 when True, Local Consts = -1 when True, all are 0 when False

#If Win64 Then
  Public Const vbMax343$ = "24703282292062329687E-343" 'VBA7 Largest String converted to 0
  Public Const vbMin343$ = "24703282292062329688E-343" 'VBA7 Smallest String not converted to 0
  Public Const VbMax$ = "17976931348623158079E289" 'Max VBA Double String Value(+ or -)
  Public Const Max64bits^ = "9223372036854775807", Min64bits^ = -Max64bits - 1
#Else
  Public Const vbMax343$ = "24703282292062327209E-343" 'VBA Largest String converted to 0
  Public Const vbMin343$ = "24703282292062327210E-343" 'VBA Smallest String not converted to 0
  Public Const VbMax$ = "17976931348623158077E289" 'Max VBA Double String Value(+ or -)
  Public Const Max64bits@ = "9223372036854775807E-4", Min64bits@ = -Max64bits - 0.0001
#End If
Public Const MaxVDstr$ = "79228162514264337593543950335"
Public Const TPi_# = "62831853071795865E-16", Pi_# = TPi_ / 2#, Pi2_# = TPi_ / 4#, Pi4_# = TPi_ / 8#
Public Const Pi_180# = Pi4_ / 45#, Pi_200# = Pi4_ / 50#, dLn10_# = "2302585092994046E-15"
Public Const dE_# = "2718281828459045E-15", SqPi_# = "1772453850905516E-15", dRad5_# = "223606797749979E-14"
Public Const dLn2_# = "6931471805599453E-16", dLog2# = "301029995663981E-15", dEu_# = "5772156649015329E-16"
Public Const vbKeyPlus As Byte = 43, vbKeyMinus As Byte = 45, vbStrN1 As String * 2 = "-1"
Public Const vbStr0 As String * 1 = "0", vbStr1 As String * 1 = "1", vbStr2 As String * 1 = "2", vbStr5 As String * 1 = "5", vbStr9 As String * 1 = "9"
Public Const Two_63# = 2 ^ 63, Two_52# = 2 ^ 52, Ten6# = 10 ^ 6, Ten10# = 10 ^ 10, Ten15# = 10 ^ 15, Ten13# = 10 ^ 13
Public Const Ten_12# = 10 ^ -12, Ten_13# = 10 ^ -13, Ten_14# = 10 ^ -14, Ten_15# = 10 ^ -15, Ten_16# = 10 ^ -16
Public Const MaxCellLen = 32767

Public XHelpFile As String, XnCfgFile As String
Public xRad5_ As String
Public xE_ As String
Public xEu_ As String
Public xPi4_ As String
Public x2Pi_ As String
Public xLn10_ As String
Public xLn2_ As String
Public xPi_ As String
Public xPi2_ As String
Public xSqPi_ As String
Public Digits_Def As Long
Public MyBar As String
Public CaseSen As Boolean
Public UseXroundOUT As Boolean
Public UseXroundIN As Boolean
Public UseTinyFlg As Boolean
Public LeadZeros As Integer
Public TrailZeros As Integer
Public MultiTiny As Double
Public StdTiny As Double
'Public appDecSep As String * 1
Public aDecSep As Byte
Public DecSep As String * 1, WrongDecSep As String * 1
Public MilSep As String * 1
Public ArgSep As String * 1
'Public AltSep As String * 1
Public ColSep As String * 1
Public RowSep As String * 1
Public qRad5_ As Variant
Public qE_ As Variant
Public qEu_ As Variant
Public qPi_ As Variant
Public q2Pi_ As Variant
Public qPi2_ As Variant
Public qPi4_ As Variant
Public qSqPi_ As Variant
Public qLn2_ As Variant
Public qLn10_ As Variant
Public Pof2M(0 To 1075) As Variant
Public Pof2E(0 To 1075) As Integer
Public GCf_(15) As Double
Public qGCf_(15) As Variant
Public MacroFlag As Boolean
Public CplxChar As String * 1
Public D2StrDgts As Integer
Public CD2xNdgts As Integer
Public func_param(3)
Public DoFullCalc As Boolean, AlreadyInstalled As Boolean, WeAreCompiled As Boolean
Public FullyInitalized As Boolean, MemVarsGood As Boolean
Public SMPadj As Integer
Public xAddAdj As Integer
Public xDivAdj As Integer
Public xMultAdj As Integer
Public xDefDgts As Integer
Public xPM() As String, xSq12_$, XpMin&, XpMax&, xPRows&
Public xLCDd() As String, MaxLCDorder%, MaxLCDpts%
Public xBASE_1 As Double
Public ExtPgmCfgFile As String
Public AppVer As Single, MaxRowOrCol&
Public SpeedIndex As Double
Public Pof10(-324 To 309) As Double, psi_coeff(1 To 11) As Double
Public uXN() As xNum, tXN() As xNum, xPow95() As xNum
Public MenuMax&, OverFlowFlg As Boolean, PrevRandNum$, AskSwDecSep%
Public CanSwDecSep As Boolean, CurUseSysSep As Variant
Public xSpouge$(), SpougeN&, xSpougeX() As xNum, xSpougeN&, xGCf_$(1 To 21)
Public PythonPath$, PythonwPath$, wsObj As Object ',DataObj As Object

#Const UseVarDec = (Win64 And (PacketSize > 9)) Or ((Win64 = False) And (PacketSize > 7))
#If PacketSize = 14 Then
  Public Const xBASE = 14
#ElseIf PacketSize = 13 Then
  Public Const xBASE = 13
#ElseIf PacketSize = 12 Then
  Public Const xBASE = 12
#ElseIf PacketSize = 11 Then
  Public Const xBASE = 11
#ElseIf PacketSize = 10 Then
  Public Const xBASE = 10
#ElseIf PacketSize = 9 Then
  Public Const xBASE = 9
#ElseIf PacketSize = 8 Then
  Public Const xBASE = 8
#ElseIf PacketSize = 7 Then
  Public Const xBASE = 7
#ElseIf PacketSize = 6 Then
  Public Const xBASE = 6
#ElseIf PacketSize = 5 Then
  Public Const xBASE = 5
#Else
  Invalid___PacketSize_Must_Be_5_Thru_14
#End If
Public Const xDgtLim = NumOfPackets - 1
Public Const DIGITS_LIMIT = NumOfPackets * xBASE
#If Win64 Then
  Const DM^ = 10 ^ xBASE, DM_1^ = DM - 1
#Else
  Const DM# = 10 ^ xBASE, DM_1# = DM - 1
  Public Const vbLongLong% = 20
#End If
#If PacketSize = 14 Then
  Const DM2# = "10000000000000001782142992384", DM3# = "1000000000000000044885712678075916785549312"
#ElseIf PacketSize = 13 Then
  Const DM2# = DM ^ 2, DM3# = DM ^ 3
#ElseIf PacketSize = 12 Then
  Const DM2# = "1000000000000000117440512", DM3# = DM ^ 3
#ElseIf PacketSize = 11 Then
  Const DM2# = DM ^ 2, DM3# = "1000000000000000089690419062898688"
#ElseIf PacketSize = 10 Then
  Const DM2# = DM ^ 2, DM3# = DM ^ 3
#ElseIf PacketSize = 9 Then
  Const DM2# = DM ^ 2, DM3# = DM ^ 3, DM4# = DM ^ 4
#ElseIf PacketSize = 8 Then
  Const DM2# = DM ^ 2, DM3# = "1000000000000000117440512", DM4# = DM ^ 4
#ElseIf PacketSize = 7 Then
  Const DM2# = DM ^ 2, DM3# = DM ^ 3, DM4# = "10000000000000001782142992384", DM5# = "100000000000000015310110181627527168"
#ElseIf PacketSize = 6 Then
  Const DM2# = DM ^ 2, DM3# = DM ^ 3, DM4# = "1000000000000000117440512", DM5# = DM ^ 5
#ElseIf PacketSize = 5 Then
  Const DM2# = DM ^ 2, DM3# = DM ^ 3, DM4# = DM ^ 4, DM5# = DM ^ 5, DM6# = DM ^ 6
#End If
Public Const xPow2Max = 7133786258# + (33.1 * DIGITS_LIMIT) \ 10
#If RetUnFmtStr Then
  Public Const CurRetUnFmtStr As Boolean = True
#Else
  Public Const CurRetUnFmtStr As Boolean = False
#End If

Type xNum
  #If Win64 Then
    dgt(xDgtLim)  As LongLong  ' Packets
  #Else
    dgt(xDgtLim)  As Double  ' Packets
  #End If
    esp           As Long     ' Exponent
    ndgt          As Integer  ' Number of Used Packets
    Sign          As Boolean ' True for neg, False(default) for pos
End Type

Type xDif
    hLog          As Double
    AdjMat        As Double
    AdjH          As Double
    EndsMat       As Double
    EndsH         As Double
    FinalH        As Double
End Type

Type CplxParametro
    Sym     As String   'symbol
    valr    As Variant   'real part
    vali    As Variant   'immaginary part
End Type

Type Parametro
    Sym     As String   'symbol
    valr    As Variant   'value
End Type
Public Const ConstLen = DIGITS_LIMIT + xBASE
Const qConstLen = 34, MaxExtraPi4len = 32765 - DIGITS_LIMIT

Type my1double: myDouble As Double: End Type
Type my8byte
  myByte0 As Byte
  myByte1 As Byte
  myByte2 As Byte
  myByte3 As Byte
  myByte4 As Byte
  myByte5 As Byte
  myByte6 As Byte
  myByte7 As Byte
End Type
Type my4ints
  myInt0  As Integer
  myInt1  As Integer
  myInt2  As Integer
  myInt3  As Integer
End Type
Type my2longs
  myLong0 As Long
  myLong1 As Long
End Type
#If Win64 Then
  Type my1lnglng: mylnglng As LongLong: End Type
#Else
  Type my1cur: myCur As Currency: End Type
#End If
'Type my16bytes
'  myBytes(7) As Byte
'  my8Bytes As my4ints
'End Type

'Functions that use temp variable xPow95(25)
'CReal2str
'CDbl2str
'xfDgMat
'rDgMat_
'xSubSmallValue
'xComp_
'xAtan2_
'Pof2Lrg

'Functions that use uXN
'xSqr_ 0-3
'SubExp 0-3
'xLn_ 0-4
'xTan_rid 0-2
'xAtan_ 0-3
'xDivQr_ 3-4
'dCStr_ 1
'xCStr_ 0

'Default configuration is in Column C Foglio13(setting)
'Foglio13.Range("C6") = 30     'Digits_Def
'Foglio13.Range("C7") = True   'UseXroundOUT
'Foglio13.Range("C8") = 5      'TrailZeros
'Foglio13.Range("C9") = 5      'LeadZeros
'Foglio13.Range("C10") = True   'UseXroundIN
'Foglio13.Range("C11") = False  'UseTinyFlg
'Foglio13.Range("C12") = 2147483647 'MultiTiny
'Foglio13.Range("C13") = 308    'StdTiny
'Foglio13.Range("C14") = "i"    'CplxChar
'Foglio13.Range("C15") = 29     'D2StrDgts
'Foglio13.Range("C16") = True   'LoadFunBookAtStart
'Foglio13.Range("C17") = True   'CalcOnSet
'Foglio13.Range("C18") = 5      'SMPadj
'Foglio13.Range("C19") = False  'CaseSen
'Foglio13.Range("C20") = 2      'xMultAdj
'Foglio13.Range("C21") = 0      'xDivAdj
'Foglio13.Range("C22") = 0      'xAddAdj
'Foglio13.Range("C23") = 2      'Check and Ask for Regional Decimal Separator MisMatch
'Foglio13.Range("C24") = DIGITS_LIMIT  'Current DIGITS_LIMIT
'Foglio13.Range("C25") = CurRetUnFmtStr   'Unformatted Strings

'BuiltinDocumentProperties used
'1 Title, Description that shows on add-in install,ToolBar and Presentation Form
'5 Comment,that shows on add-in install
'14 OrigCalcStatus
'15 OrigSavedStatus of ActiveWorkBook
'16 Calculate Event Handler Enable/Disable
'19 Restore Decimal Separator Character
'20 Configuration file Title

' These Functions will not appear in the "User Defined" list
' but will be avail to this VBA Project

Function FixFullPath(FullPath) As String 'Also called by frmOptions
If Len(FullPath) < 129 Then FixFullPath = FullPath: Exit Function
FixFullPath = Left$(FullPath, 25) & "..." & Right$(FullPath, 100)
End Function

Sub SetNewLabels(tmpWorkBook As Workbook, FullPath$)
Dim d As Date, s$
d = Date
s = "Ver " & xNver & UCase$(Right$(FullPath, 1))
#If RetUnFmtStr Then
  s = s & "R"
#End If
If Not AutoPacketSize Then s = s & Right$(xBASE, 1)
s = s & " " & Day(d) & MonthName(Month(d), True) & Year(d)
tmpWorkBook.BuiltinDocumentProperties(1) = "Xnumbers " & s
s = xNumTitle & vbLf & s & " MaxDigits " & DIGITS_LIMIT & vbLf & FullPath
tmpWorkBook.BuiltinDocumentProperties(5) = s
End Sub

Sub SchedMemVarsChk() ' Called by Event Handler
Application.ScreenUpdating = False
AutoCheck "!XnumbPrivate.CheckMemVars"
AutoCheck "!InitPrivate.ReCompile" 'last in is first out
AutoCheck True
End Sub

Sub ReSetCalcStatus()
If ThisWorkbook.CustomDocumentProperties.Count = 0 Then 'don't reset when frmOptions will do it
  If Workbooks.Count <> 0 Then
    If ThisWorkbook.BuiltinDocumentProperties(14) <> 0 Then
      If Application.Calculation <> ThisWorkbook.BuiltinDocumentProperties(14) Then _
        Application.Calculation = ThisWorkbook.BuiltinDocumentProperties(14)
      Workbooks(1).Saved = ThisWorkbook.BuiltinDocumentProperties(15)
    End If
  End If
  ThisWorkbook.BuiltinDocumentProperties(14) = 0
  FullyInitalized = True
  Application.ScreenUpdating = True
End If
AutoCheck True
End Sub

Sub CheckMemVars() 'Also called by xNum_MenuBar_Switch and frmOptions
If AppVer = 0 Then ' Mem variables have been destroyed
  ReInitMemVars1
Else ' See if DecSep has changed
  CheckDecSep
  If DoFullCalc Then xnCalculateFull: ReSetCalcStatus Else AutoCheck True
End If
End Sub

Sub ReInitMemVars() 'Called as Menu Item
Application.ScreenUpdating = False
AutoCheck "!XnumbPrivate.ReInitMemVars1"
AutoCheck True
End Sub

Sub ReInitMemVars1() ' Scheduled by Menu Item and called by CheckMemVars
Dim OrigCalcStatus%
AutoCheck False ' Disable Auto Checking
Application.ScreenUpdating = False
DoFullCalc = True
ThisWorkbook.BuiltinDocumentProperties(15) = 0 'not saved if resetting
If Workbooks.Count <> 0 Then
  OrigCalcStatus = Application.Calculation
  Application.Calculation = xlCalculationManual
End If
If ThisWorkbook.BuiltinDocumentProperties(14) = 0 Then ThisWorkbook.BuiltinDocumentProperties(14) = OrigCalcStatus '0 if not set
SetNewLabels ThisWorkbook, FixFullPath(ThisWorkbook.FullName)
Foglio13.Range("A24") = DIGITS_LIMIT
Foglio13.Range("A25") = CurRetUnFmtStr
XHelpFile = vbNullString 'Force Help ReInit
ReInitPubVars
SetHelpFile 'Will also recalc,ReSetCalcStatus and restart Auto Checking
End Sub

Sub CheckFullCalc()
If Workbooks.Count <> 0 Then
  If ThisWorkbook.BuiltinDocumentProperties(14) = 0 Then
    If Application.Calculation <> xlCalculationManual Then DoFullCalc = True
  ElseIf ThisWorkbook.BuiltinDocumentProperties(14) <> xlCalculationManual Then
    DoFullCalc = True
  End If
End If
End Sub

Sub AutoInitMemVars() 'Scheduled by Workbook_Open
ReInitPubVars
CheckFullCalc
SetHelpFile 'Will also recalc if DoFullCalc,ReSetCalcStatus and restart Auto Checking
End Sub

Sub ReInitPubVars() 'Called by Workbook_Open
Dim s As Single
AlreadyInstalled = True 'Incase it was destroyed
SetXnCfgFile
MenuMax = shToolbarGen.Range("E:E").End(xlDown).Row
xMultAdj = Foglio13.Range("A20")
xDivAdj = Foglio13.Range("A21") + xBASE * 2 - 2
xAddAdj = Foglio13.Range("A22") + xBASE - 2
SMPadj = Foglio13.Range("A18")
MyBar = shToolbarGen.Range("A2")
Digits_Def = Foglio13.Range("A6")
If Digits_Def > DIGITS_LIMIT Then Digits_Def = DIGITS_LIMIT
UseXroundOUT = Foglio13.Range("A7")
TrailZeros = Foglio13.Range("A8")
LeadZeros = Foglio13.Range("A9")
UseXroundIN = Foglio13.Range("A10")
UseTinyFlg = Foglio13.Range("A11")
MultiTiny = Foglio13.Range("A12")
StdTiny = Foglio13.Range("A13")
CplxChar = Foglio13.Range("A14")
SetXnDefCStr Foglio13.Range("A15")
CaseSen = Foglio13.Range("A19")
CanSwDecSep = Foglio13.Range("C1")
AskSwDecSep = Foglio13.Range("A23")

x2Pi_ = Left$(Foglio13.Range("E1"), ConstLen)
xPi_ = Left$(Foglio13.Range("E2"), ConstLen)
xPi2_ = Left$(Foglio13.Range("E3"), ConstLen)
xPi4_ = Left$(Foglio13.Range("E4"), ConstLen + 1)
xLn2_ = Left$(Foglio13.Range("E5"), ConstLen + 1)
xLn10_ = Left$(Foglio13.Range("E6"), ConstLen)
xE_ = Left$(Foglio13.Range("E7"), ConstLen)
xEu_ = Left$(Foglio13.Range("E8"), ConstLen + 1)
xRad5_ = Left$(Foglio13.Range("E9"), ConstLen)
xSq12_ = Left$(Foglio13.Range("E10"), ConstLen)
xSqPi_ = Left$(Foglio13.Range("E11"), ConstLen)

AppVer = Val(Application.Version)
MilSep = Application.International(xlThousandsSeparator)
ColSep = Application.International(xlColumnSeparator)
RowSep = Application.International(xlRowSeparator)
CheckDecSep

qPi_ = CDec(BC(xPi_, qConstLen)) 'BC uses DecSep, UseXroundOUT & Digits_Def
q2Pi_ = CDec(BC(x2Pi_, qConstLen))
qPi2_ = CDec(BC(xPi2_, qConstLen))
qPi4_ = CDec(BC(xPi4_, qConstLen))
qLn2_ = CDec(BC(xLn2_, qConstLen))
qLn10_ = CDec(BC(xLn10_, qConstLen))
qE_ = CDec(BC(xE_, qConstLen))
qEu_ = CDec(BC(xEu_, qConstLen))
qRad5_ = CDec(BC(xRad5_, qConstLen))
qSqPi_ = CDec(BC(xSqPi_, qConstLen))

ReDim xSpougeX(-1 To -1), tXN(0 To 3) As xNum, xPow95(0 To 25), uXN(0 To 4)
SpougeN = 0: xSpougeN = 0
xSpougeX(-1).dgt(0) = 1: xSpougeX(-1).ndgt = 1 ' Used to invert xnumbers
MacroFlag = False
xNumInvAppCallFlg = False
InitPof2 ' Everything should work after return
'If DataObj Is Nothing Then Set DataObj = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
If Len(PrevRandNum) = 0 Then
  Randomize
TryAgain: s = Rnd(): If s = 0 Then GoTo TryAgain
  PrevRandNum = xMantissa(s) & "E-1"
End If
xBASE_1 = GetPrevDouble(xBASE)
If MaxExtraPi4len > DIGITS_LIMIT Then _
  CStr2xNum xPow95(24), Mid$(Foglio13.Range("E4"), DIGITS_LIMIT + 2, DIGITS_LIMIT) _
  & "E-" & (DIGITS_LIMIT * 2&), DIGITS_LIMIT _
Else _
  CStr2xNum xPow95(24), Mid$(Foglio13.Range("E4"), DIGITS_LIMIT + 2, MaxExtraPi4len) _
  & Left$(Foglio13.Range("E12"), DIGITS_LIMIT - MaxExtraPi4len) & "E-" & (DIGITS_LIMIT * 2&), DIGITS_LIMIT
MemVarsGood = True
End Sub

Sub CheckDecSep()
If Not CanSwDecSep Then AskSwDecSep = 0: GoTo Done ' No sense in checking if we are unable to switch
If AskSwDecSep = 0 Then GoTo Done 'User has disabled the check
If MilSep <> Application.International(xlThousandsSeparator) Then DoFullCalc = True
If AppVer > 9 Then If Application.UseSystemSeparators Then RestoreDecSep 'if we have one saved
If Mid$(CStr(3 / 2), 2, 1) = Foglio13.Range("C3") Then GoTo Done ' VBA and EXCEL match
If AskSwDecSep = 2 Then ' User wants us to ask
  Dim Msg$, Response
  Msg = "Resulting Spreadsheet Number Formats:" & vbLf & vbLf & _
  "    Xnumbers Strings   " & CStr(3 / 2) & vbLf & _
  "    EXCEL Numbers      " & "1" & Foglio13.Range("C3") & "5" & vbLf & vbLf & _
  "You can Disable this check from the Configuration screen." & vbLf & _
  "Automatically change the Regional Separators for this session?"
  Response = MsgBox(Msg, vbYesNoCancel + vbMsgBoxHelpButton + vbExclamation + vbDefaultButton1, _
    "Xnumbers - Decimal Separator MisMatch", XHelpFile, 505)
  If Response = vbYes Then AskSwDecSep = 1 Else AskSwDecSep = 0: GoTo Done 'only ask once per reinit
End If
If ThisWorkbook.BuiltinDocumentProperties(19) = vbNullString Then ThisWorkbook.BuiltinDocumentProperties(19) = Mid$(CStr(3 / 2), 2, 1)
SetNewDecSep Foglio13.Range("C3")
DoFullCalc = True
Done:
If AppVer > 9 Then CurUseSysSep = Application.UseSystemSeparators
DecSep = Mid$(CStr(3 / 2), 2, 1)
aDecSep = Asc(DecSep)
If aDecSep = 46 Then WrongDecSep = "," Else WrongDecSep = "."
'appDecSep = Application.International(xlDecimalSeparator)
MilSep = Application.International(xlThousandsSeparator)
ArgSep = Application.International(xlListSeparator)
If DecSep = ArgSep Then ArgSep = Application.International(xlAlternateArraySeparator)
End Sub

Sub InitPof2()
Dim i%, m$, e#, x#, d&
CStr2xNum xPow95(0), Foglio13.Range("E13"), DIGITS_LIMIT 'Get 2 ^ -1074
For i = 1 To 22: CStr2xNum xPow95(i), Foglio13.Range("F" & i), DIGITS_LIMIT: Next
For i = 0 To 49: split_exp_ CStr(2 ^ i), m, Pof2E(i): Pof2M(i) = CDec(m): Next
'qCStr uses abs(i-52) 2-43 set above
For i = 50 To 95: split_exp_ qCStr(2 ^ i), m, Pof2E(i): Pof2M(i) = CDec(m): Next
i = 96: d = 36: tXN(1).dgt(0) = 2: tXN(1).ndgt = 1: tXN(1).Sign = False: tXN(1).esp = 0
CStr2xNum tXN(0), "79228162514264337593543950336", d
L1: split_exp_ xNum2str(tXN(0)), m, Pof2E(i): Pof2M(i) = CDec(m)
  If i < 1023 Then i = i + 1: xMult_ tXN(0), tXN(0), tXN(1), d: GoTo L1
Pof2M(96) = CDec("79228162514264337593543950335E-28") 'does not round well
i = 1075: xDiv_ tXN(0), xPow95(0), tXN(1), d
L2: split_exp_ xNum2str(tXN(0)), m, Pof2E(i): Pof2M(i) = CDec(m)
  If i > 1024 Then i = i - 1: xMult_ tXN(0), tXN(0), tXN(1), d: GoTo L2
xMult_ xPow95(23), xPow95(0), xPow95(22), DIGITS_LIMIT
xRound_ xPow95(23), 0

Pof10(-324) = 4.94065645841247E-324
Pof10(309) = CDbl(VbMax)
For i = -323 To 308
  x = 10 ^ i
  e = vIntLog2(x)
  If e < -1022 Then e = -1022
  e = 2 ^ (e - 52)
  
  If i = vExponent(qCStr(x)) Then
tryagainEQ:
    x = x - e
    If i = vExponent(qCStr(x)) Then GoTo tryagainEQ
    x = x + e
  Else
tryagainNE:
    x = x + e
    If i <> vExponent(qCStr(x)) Then GoTo tryagainNE
  End If
  Pof10(i) = x
Next i

For i = 0 To 15: qGCf_(i) = CDec(Foglio13.Range("H" & i + 1)): GCf_(i) = qGCf_(i): Next
For i = 1 To 21: xGCf_(i) = Foglio13.Range("G" & i): Next
For i = 1 To 11: psi_coeff(i) = Foglio13.Range("E" & i + 14): Next

ReDim xPM(0, 1) As String
xPM(0, 0) = vbStr1: xPM(0, 1) = vbStr0: XpMin = 0: XpMax = 0: xPRows = 1
ReDim xLCDd(1 To 1, 1 To 1) As String
MaxLCDorder = 1: MaxLCDpts = 1
Dim cyFrequency@, q, dt1@, dt2@
getFrequency cyFrequency
q = CDec(cyFrequency) / 1000
x = 0
getTickCount dt1
loopcnt: x = x + 1
getTickCount dt2
If dt2 - dt1 < q Then GoTo loopcnt
SpeedIndex = x
End Sub

Function xIsEven_(v As xNum) As Boolean
Dim i%, k&, d#
If v.esp <= 0 Then
  If v.ndgt > 0 Then
    k = -(v.esp \ xBASE) ' Calc Location of DecSep
    If k >= v.ndgt Then GoTo ItIsEven ' no digits to the left of DecSep
    i = -v.esp - k * xBASE ' Calc position of DecSep in v.Dgt(k)
'    If i < 0 Then
'      d = v.dgt(k + 1) / 2#
'    Else
  #If Win64 Then
      d = (v.dgt(k) \ 10^ ^ i) / 2#
  #ElseIf PacketSize > 9 Then
      d = Int(CDbl(v.dgt(k) / 10# ^ i)) / 2#
  #Else
      d = (v.dgt(k) \ 10# ^ i) / 2#
  #End If
'    End If
    If d <> Int(d) Then Exit Function
  End If
End If
ItIsEven: xIsEven_ = True
End Function

Function xIsOdd_(v As xNum) As Boolean
If v.esp > 0 Then Exit Function ' all digits to left of DecSep
If v.ndgt = 0 Then Exit Function ' 0 is even
Dim i%, k&, d#
k = -(v.esp \ xBASE) ' Calc Location of DecSep
If k >= v.ndgt Then Exit Function ' no digits to the left of DecSep
i = -v.esp - k * xBASE ' Calc position of DecSep in v.Dgt(k)
#If Win64 Then
 d = (v.dgt(k) \ 10^ ^ i) / 2#
#ElseIf PacketSize > 9 Then
  d = Int(CDbl(v.dgt(k) / 10# ^ i)) / 2#
#Else
  d = (v.dgt(k) \ 10# ^ i) / 2#
#End If
If d = Int(d) Then Exit Function
xIsOdd_ = True
End Function

Function xIsInt_(v As xNum) As Boolean
Dim i%, k&
If v.esp < 0 Then
  If v.ndgt > 0 Then
    k = -(v.esp \ xBASE) ' Calc Location of DecSep
    If k >= v.ndgt Then Exit Function ' no digits to the left of DecSep
      i = k - 1: For i = i To 0 Step -1: If v.dgt(i) > 0 Then Exit Function
      Next
      i = -v.esp - k * xBASE ' Calc position of DecSep in v.Dgt(k)
      If i < 0 Then
        If v.dgt(k) > 0 Then Exit Function
      Else
    #If Win64 Then
        If v.dgt(k) <> (v.dgt(k) \ 10^ ^ i) * 10^ ^ i Then Exit Function
    #ElseIf PacketSize > 9 Then
        If v.dgt(k) <> Int(CDbl(v.dgt(k) / 10# ^ i)) * 10# ^ i Then Exit Function
    #Else
        If v.dgt(k) <> (v.dgt(k) \ 10# ^ i) * 10# ^ i Then Exit Function
    #End If
      End If
  End If
End If
xIsInt_ = True
End Function

Function xIsNumeric_(x) As Boolean
  xIsNumeric_ = xIsNumeric(x)
End Function

Function IsInteger(x) As Boolean
  If Not IsNumeric(x) Then Exit Function
  If Abs(x) = Int(Abs(x)) Then IsInteger = True
End Function

Function IsLetter(a$) As Boolean
Select Case Asc(a)
  Case Is < 65, 91 To 96, Is > 122: Exit Function
End Select
IsLetter = True
End Function

Function IsNum(x) As Boolean
Dim i%
i = VarType(x)
If i < vbInteger Then Exit Function   ' Empty and Null (False)
IsNum = True
  If i < vbDate Then Exit Function    ' 2-6 are Good Numeric Values
  If i < vbUserDefinedType Then If i > vbDataObject Then Exit Function
IsNum = False
End Function

Function IsMatrix(a) As Boolean 'check if argument is a true matrix array
On Error GoTo EH: IsMatrix = UBound(a, 2) Or True
EH: End Function

Function IsArrayInitialized(a) As Boolean 'does not work on User Defined Types
On Error Resume Next: IsArrayInitialized = UBound(a) Or True
End Function

Function ChkArrayRet(Optional Ret) As Boolean
If xNumInvAppCallFlg Then
  If xNumACRows * xNumACCols < 2 Then Exit Function
  If Not IsMissing(Ret) Then MaxRowOrCol = max_(xNumACRows, xNumACCols)
Else
  If Application.Caller.Count < 2 Then Exit Function
  If Not IsMissing(Ret) Then MaxRowOrCol = max_(Application.Caller.Rows.Count, Application.Caller.Columns.Count)
End If
ChkArrayRet = True
End Function

'vbEmpty             0  Empty (uninitialized)
'vbNull              1  Null (no valid data)
'vbInteger           2  Integer
'vbLong              3  Long integer
'vbSingle            4  Single-precision floating-point number
'vbDouble            5  Double-precision floating-point number
'vbCurrency          6  Currency value
'vbDate              7  Date value
'vbString            8  String
'vbObject            9  Object
'vbError            10  Error value
'vbBoolean          11  Boolean value
'vbVariant          12  Variant (used only with arrays of variants)
'vbDataObject       13  A data access object
'vbDecimal          14  Decimal value
'vbByte             17  Byte value
'vbLongLong         20  8-Byte value
'vbUserDefinedType  36  Variants that contain user-defined types
'vbArray          8192  Array

Function dCStr_(x) As String
Select Case VarType(x)
  Case vbString: dCStr_ = Trim$(x)               ' Strip leading and trailing blanks
    If LenB(dCStr_) <> 0 Then Exit Function
    dCStr_ = vbStr0: Exit Function ' Convert spaces to "0"
  Case Is < vbInteger: dCStr_ = vbStr0: Exit Function ' Convert empty to "0"
  Case Is < vbCurrency:
    If x = Int(x) Then If Abs(x) < 1E+15 Then dCStr_ = x: Exit Function ' Will convert correctly
    Select Case D2StrDgts
      Case 29: dCStr_ = qCStr(x): Exit Function
      Case 0: dCStr_ = x: Exit Function ' User wants VBA's CStr
      Case Is < 30: dCStr_ = CDbl2str(x): Exit Function
      Case Else: xCStr_ x, xDefDgts, uXN(1) ' SigDgts - vExponent(x) - 1
        xRound_ uXN(1), xDefDgts - uXN(1).esp - (uXN(1).ndgt - 1) * xBASE - Len(CStr(uXN(1).dgt(uXN(1).ndgt - 1)))
        dCStr_ = xNum2str(uXN(1)): Exit Function
    End Select
  Case vbDecimal, vbByte, vbCurrency, vbLongLong: dCStr_ = x: Exit Function
'  Case Is > vbArray: dCStr_ = x(1): Exit Function
  Case Else: ErrRaise
End Select
End Function

Sub xCStr_(ByVal x, ByVal DgMx&, xN As xNum)
'This routine exploits the fact that all doubles can be expressed as an integer multiple
'of a "Power of 2"(also the difference between consecutive doubles). We obtain the exact
'string representation of any double. The maximum size is 767 digits.
Dim j%, z As my1double, y As my4ints
DgMx = ((DgMx + SMPadj + xBASE) \ xBASE) * xBASE
z.myDouble = x: LSet y = z
j = (y.myInt3 And &H7FF0) \ &H10 - &H433 ' Get Power of 2 from Double Exponent
If j = -1075 Then Int2xNum xN, z.myDouble / 4.94065645841247E-324: xMult_ xN, xPow95(0), xN, DgMx: Exit Sub
If j = 972 Then ErrRaise: Exit Sub 'INF, IND, sNaN, or qNaN
Pof2_ xN, j, DgMx
y.myInt3 = (y.myInt3 And &H800F) Or &H4330 ' Set Exponent for Integer Mantissa
LSet z = y  ' Int2xNum will Convert Double to accurate Max 16 digit Integer
Int2xNum uXN(0), z.myDouble
xMult_ xN, xN, uXN(0), DgMx 'Mult Pof2 by Integer
End Sub

  #If Win64 Then
Sub Pof2_(y As xNum, ByVal j^, DgMx&)
  #Else
Sub Pof2_(y As xNum, ByVal j#, DgMx&)
  #End If
If j < 96 Then _
  If j >= 0 Then _
    Int2xNum y, 2 ^ j: Exit Sub _
  Else _
    If j > -96 Then _
      Int2xNum y, 2 ^ Abs(j): _
      xDiv_ y, xSpougeX(-1), y, DgMx: Exit Sub _
    Else _
      If j < -978 Then _
        If j < -1074 Then _
          Pof2_ y, Abs(j), DgMx: _
          xDiv_ y, xSpougeX(-1), y, DgMx: Exit Sub _
        Else _
          If j <> -1074 Then _
            Int2xNum y, 2 ^ (j + 1074): _
            xMult_ y, xPow95(0), y, DgMx: _
            xRound_ y, -j: Exit Sub _
          Else _
            y = xPow95(0): Exit Sub _
      Else _
        GoTo UsePof2 ' -978 thru -96
If j < 1111 Then
UsePof2: Dim k%, i%
  #If Win64 Then
    i = CInt(j + 1074)
  #Else
    i = j + 1074
  #End If
  k = i \ 95
  Int2xNum y, 2 ^ (k * -95 + i)
  xMult_ y, xPow95(k), y, DgMx ' Calc # of Increments
  xMult_ y, xPow95(0), y, DgMx ' Mult by 2 ^ -1074
  If j < 0 Then xRound_ y, -j Else xRound_ y, 0
Else
  Pof2Lrg j, DgMx, y
End If
End Sub
  #If Win64 Then
Sub Pof2Lrg(ByVal j^, ByVal DgMx&, y As xNum)
  #Else
Sub Pof2Lrg(ByVal j#, ByVal DgMx&, y As xNum)
  #End If
Dim U(22) As Boolean, i%, uMax%
DgMx = DgMx + Len(CStr(j))
#If Win64 Then
  SetUmax uMax, j \ 1016, U
#Else
  SetUmax uMax, Int(j / 1016), U
#End If
xPow95(25) = xPow95(23): y.ndgt = 1: y.dgt(0) = 1: y.Sign = False: y.esp = 0
xPl: If U(i) Then xMult_ y, xPow95(25), y, DgMx
  If i < uMax Then xMult_ xPow95(25), xPow95(25), xPow95(25), DgMx: i = i + 1: GoTo xPl
#If Win64 Then
  Pof2_ xPow95(25), j Mod 1016, DgMx
#Else
  Pof2_ xPow95(25), j - Int(j / 1016) * 1016, DgMx
#End If
  xMult_ y, y, xPow95(25), DgMx
End Sub

Sub CStr2xNum(x As xNum, StrNum, DgMx&)
' Convert String to xNum
Dim s$, p1&, p2&, p3&, i&, esp#
s = StrNum

'decifra il segno
Select Case Asc(s) 'p1 points to first digit in mantissa
  Case Is > vbKeyMinus: p1 = 1: x.Sign = False
  Case vbKeyMinus: p1 = 2: x.Sign = True
  Case Else: p1 = 2: x.Sign = False '+ sign trap
End Select
'decifra esponente,estrae sero
p2 = InStr(p1, s, DecSep)
If p2 = 0 Then
  p3 = InStr(p1, s, "E")
  If p3 <> 0 Then
    esp = CDbl(Right$(s, Len(s) - p3)): p3 = p3 - 1 'p3 points to last digit in mantissa
  Else
    p3 = InStr(p1, s, "e")
    If p3 = 0 Then p3 = Len(s) Else esp = CDbl(Right$(s, Len(s) - p3)): p3 = p3 - 1
  End If
'elimina eventuali zeri a sinistra
'  While Mid$(s, p1, 1) = vbStr0: p1 = p1 + 1: Wend
'  If p1 > p3 Then GoTo ItIsZero
  While Mid$(s, p1, 1) < vbStr1: p1 = p1 + 1: If p1 > p3 Then GoTo ItIsZero
  Wend
  p3 = p3 - p1 + 1
  s = Mid$(s, p1, p3)
Else
  p3 = InStr(p2, s, "E")
  If p3 <> 0 Then
    esp = CDbl(Right$(s, Len(s) - p3)): p3 = p3 - 1 'p3 points to last digit in mantissa
  Else
    p3 = InStr(p2, s, "e")
    If p3 = 0 Then p3 = Len(s) Else esp = CDbl(Right$(s, Len(s) - p3)): p3 = p3 - 1
  End If
  esp = esp - (p3 - p2)
  Mid$(s, p2, 1) = vbStr0 'replace DecSep
'  While Mid$(s, p1, 1) = vbStr0: p1 = p1 + 1: Wend
  While Mid$(s, p1, 1) < vbStr1: p1 = p1 + 1: If p1 > p3 Then GoTo ItIsZero
  Wend
  If p1 > p2 Then
'    If p1 > p3 Then GoTo ItIsZero
    p3 = p3 - p1 + 1
    s = Mid$(s, p1, p3)
  Else
    s = Mid$(s, p1, p2 - p1) & Mid$(s, p2 + 1, p3 - p2)
    p3 = p3 - p1
End If: End If
'tronca il sero alle prime DgMx cifre
If p3 > DgMx Then
  esp = esp + p3 - DgMx
  p3 = DgMx
  If UseXroundIN Then ' Round the last digit if the next digit is >=5
    If Mid$(s, p3 + 1, 1) >= 5 Then
      On Error GoTo RoundTo1 ' if they are all 9's
      While Mid$(s, p3, 1) = vbStr9: p3 = p3 - 1: Wend
      If p3 < DgMx Then esp = esp + DgMx - p3
      Mid$(s, p3, 1) = Chr$(Asc(Mid$(s, p3, 1)) + 1)
  End If: End If
  s = Left$(s, p3)
End If
'elimina eventuali zeri a destra
i = p3: While Mid$(s, i, 1) = vbStr0: i = i - 1: Wend
If i < p3 Then esp = esp + p3 - i: s = Left$(s, i)
'Check for exponent overflow
SkipTrunc:
If Abs(esp) < 2147483648# Then
  x.esp = esp
ElseIf esp > 0 Then
  OverFlowFlg = True
  x.esp = 2147483647#
  p1 = esp - 2147483648#
  If p1 > (DIGITS_LIMIT - 1) - i Then ErrRaise
  s = s & String$(p1, vbKey0) & vbStr1
  i = i + p1 + 1
ElseIf esp < -2147483648# Then
  OverFlowFlg = True
  If esp > -2147483648# - i Then
    i = i + esp + 2147483648#
    While Mid$(s, i, 1) = vbStr0: i = i - 1: Wend
    x.esp = esp + Len(s) - i
    s = Left$(s, i)
  Else
    x.esp = -2147483648#: s = vbStr1: i = 1
  End If
Else
  x.esp = esp
End If
'suddivisione delle cifre
x.ndgt = (i - 1) \ xBASE + 1: p1 = i + 1: p2 = x.ndgt - 2
For i = 0 To p2: p1 = p1 - xBASE: x.dgt(i) = Mid$(s, p1, xBASE): Next
x.dgt(i) = Left$(s, p1 - 1): Exit Sub
RoundTo1: On Error GoTo 0: esp = esp + DgMx: s = vbStr1: i = 1: Resume SkipTrunc
ItIsZero: x.ndgt = 0
End Sub

Function xNum2str(x As xNum) As String
' Convert xNum to UnFormatted String
If x.ndgt = 0 Then xNum2str = vbStr0: Exit Function
Dim i%, s$, j%, k&
j = x.ndgt - 1
k = xBASE * j + 1 - x.Sign + Len(CStr(x.dgt(j)))
If x.esp Then
  s = x.esp
  xNum2str = String$(k + Len(s), vbKey0)
  Mid$(xNum2str, k, 1) = "E"
  Mid$(xNum2str, k + 1, Len(s)) = s
Else
  xNum2str = String$(k - 1, vbKey0)
End If
For i = 0 To j
  s = x.dgt(i)
  Mid$(xNum2str, k - Len(s), Len(s)) = s
  k = k - xBASE
Next i
If x.Sign Then Mid$(xNum2str, 1, 1) = "-"
End Function

Function xNumMantissa(x As xNum) As String
Dim k%, j%, i%, s$
j = x.ndgt - 1: k = xBASE * j + 1 + Len(CStr(x.dgt(j)))
xNumMantissa = String$(k - 1, vbKey0)
For i = 0 To j
  s = x.dgt(i)
  Mid$(xNumMantissa, k - Len(s), Len(s)) = s
  k = k - xBASE
Next
End Function

Function CvtxNum2str(x As xNum, DgMx) As String
#If RetUnFmtStr Then
  CvtxNum2str = xNum2str(x)
#Else
' Convert Xnum to Formatted String
If x.ndgt = 0 Then CvtxNum2str = vbStr0: Exit Function
Dim Num$, i%, s$, j%, k&
'costruisce la stringa numerica
j = x.ndgt - 1
k = xBASE * j + 1 + Len(CStr(x.dgt(j)))
Num = String$(k - 1, vbKey0)
For i = 0 To j
  s = x.dgt(i)
  Mid$(Num, k - Len(s), Len(s)) = s
  k = k - xBASE
Next i
If x.Sign Then CvtxNum2str = "-"
CvtxNum2str = xFmtStr_(CvtxNum2str, Num, CDbl(x.esp), DgMx)
#End If
End Function

Sub xFmtStrExp(x$, ByVal Sign$, y As xNum, e, Digit_Max)
If VarType(e) <> vbString Then
  On Error GoTo EH
#If RetUnFmtStr Then
  x = xFmtStr_(Sign, xNumMantissa(y), e + y.esp, DIGITS_LIMIT)
#Else
  x = xFmtStr_(Sign, xNumMantissa(y), e + y.esp, Digit_Max)
#End If
  Exit Sub
EH: Resume UseAdd
UseAdd: On Error GoTo 0
End If
Dim e1
#If RetUnFmtStr Then
x = Sign & xNumMantissa(y): e1 = 0
#Else
split_exp_ xNumMantissa(y), x, e1
x = xFmtStr(Sign & x, (Digit_Max))
#End If
Cvt2xNum tXN(3), e, DIGITS_LIMIT
Int2xNum y, y.esp
xAdd_ y, tXN(3), y, DIGITS_LIMIT
If e1 <> 0 Then
  Cvt2xNum tXN(3), e1, DIGITS_LIMIT
  xAdd_ y, y, tXN(3), DIGITS_LIMIT
End If
If y.ndgt <> 0 Then
  If y.Sign Then Sign = "E-" Else Sign = "E+"
  If y.esp = 0 Then
    x = x & Sign & xNumMantissa(y)
  Else
    x = x & Sign
    Sign = xNumMantissa(y)
    If y.esp < 0 Then
      x = x & Left$(Sign, Len(Sign) + y.esp)
    Else
      x = x & Sign & String$(y.esp, vbKey0)
    End If
  End If
End If
If Len(x) > MaxCellLen Then
  e1 = Len(x) - MaxCellLen
  split_exp_ x, x, e
  e = iFmt(e, -1)
  If Asc(e) = vbKeyMinus Then Sign = "E" Else Sign = "E+": e = iFmt(xAddR(e, e1, DIGITS_LIMIT), -1)
  x = Left$(x, Len(x) - e1) & Sign & e
End If
End Sub

Function xFmtStr(s, DgMx) As String
Dim p1&, p2&, p3&, Sign$, esp
#If RetUnFmtStr Then
  xFmtStr = s
#Else
'decifra il segno
If Asc(s) <> vbKeyMinus Then p1 = 1 Else p1 = 2: Sign = "-"
p2 = InStr(p1, s, DecSep)
'decifra esponente
If p2 = 0 Then
  p3 = InStr(p1, s, "E")
  If p3 <> 0 Then
    esp = CDec(Right$(s, Len(s) - p3)): p3 = p3 - 1
  Else
    p3 = InStr(p1, s, "e")
    If p3 = 0 Then p3 = Len(s) Else esp = CDec(Right$(s, Len(s) - p3)): p3 = p3 - 1
  End If
  xFmtStr = xFmtStr_(Sign, Mid$(s, p1, p3 - p1 + 1), esp, DgMx)
Else
  p3 = InStr(p2, s, "E")
  If p3 <> 0 Then
    On Error GoTo EH
    esp = CDec(Right$(s, Len(s) - p3)): p3 = p3 - 1
    On Error GoTo 0
  Else
    p3 = InStr(p2, s, "e")
    If p3 = 0 Then p3 = Len(s) Else esp = CDec(Right$(s, Len(s) - p3)): p3 = p3 - 1
  End If
  esp = esp - (p3 - p2)
  xFmtStr = xFmtStr_(Sign, Mid$(s, p1, p2 - p1) & Mid$(s, p2 + 1, p3 - p2), esp, DgMx)
End If
#End If
Exit Function
EH: On Error GoTo 0
split_exp_ s, xFmtStr, esp
Cvt2xNum tXN(2), xFmtStr, DIGITS_LIMIT
tXN(2).Sign = False
xFmtStrExp xFmtStr, Sign, tXN(2), esp, DgMx
End Function

Function xFmtStr_(Sign$, Num$, Expon, ByVal DgMx&) As String
Dim i%, s$, esp
'elimina eventuali zeri a sinistra
i = 1: While Mid$(Num, i, 1) = vbStr0: i = i + 1: Wend
If i > 1 Then
  If i > Len(Num) Then GoTo SetCXISZ
  Num = Right$(Num, Len(Num) - i + 1)
End If
'tronca il numero alle prime DgMx cifre
TryAgain: i = Len(Num): esp = Expon
If i > DgMx Then
  esp = esp + i - DgMx: i = DgMx
  If UseXroundOUT Then ' Round the last digit if the next digit is >=5
    If Mid$(Num, i + 1, 1) >= 5 Then
      On Error GoTo RoundTo1
      While Mid$(Num, i, 1) = vbStr9: i = i - 1: Wend
      If i < DgMx Then esp = esp + DgMx - i
      Mid$(Num, i, 1) = Chr$(Asc(Mid$(Num, i, 1)) + 1)
  End If: End If
  Num = Left$(Num, i)
End If
'elimina eventuali zeri a destra
While Mid$(Num, i, 1) = vbStr0: i = i - 1: Wend
If i < Len(Num) Then esp = esp + Len(Num) - i: Num = Left$(Num, i)
'inserisce virgola o esponente
SkipTrunc:
If esp > 0 Then
  If i + esp > DgMx Then ' formato 1,234540567E+5
ae: s = Right$(Num, i - 1)
    If Len(s) <> 0 Then
      xFmtStr_ = Sign & Left$(Num, 1) & DecSep & s & "E+" & CStr(i + esp - 1)
    Else
      xFmtStr_ = Sign & Left$(Num, 1) & "E+" & CStr(i + esp - 1)
    End If
  Else    ' formato 123456000
    If esp > TrailZeros Then GoTo ae
    xFmtStr_ = Sign & Num & String$(esp, vbKey0)
  End If
ElseIf esp < 0 Then
  esp = Abs(esp)
  If esp > DgMx Then ' formato 1,234551436E-6
Se: s = Right$(Num, i - 1)
    If Len(s) <> 0 Then
      xFmtStr_ = Sign & Left$(Num, 1) & DecSep & s & "E" & CStr(i - esp - 1)
    Else
      xFmtStr_ = Sign & Left$(Num, 1) & "E" & CStr(i - esp - 1)
    End If
  Else
    If i > esp Then 'formato 123,42526
      s = Right$(Num, esp)
      If Len(s) <> 0 Then
        xFmtStr_ = Sign & Left$(Num, i - esp) & DecSep & s
      Else
        xFmtStr_ = Sign & Left$(Num, i - esp)
      End If
    Else  'formato 0,00023456
      If esp - i > LeadZeros Then GoTo Se
      xFmtStr_ = Sign & vbStr0 & DecSep & String$(esp - i, vbKey0) & Num
    End If
  End If
Else ' esp = 0  inserisce il segno
  xFmtStr_ = Sign & Num
End If
If Len(xFmtStr_) <= MaxCellLen Then Exit Function
DgMx = DgMx - Len(xFmtStr_) + MaxCellLen: GoTo TryAgain
RoundTo1: On Error GoTo 0: esp = esp + DgMx: Num = vbStr1: i = 1: Resume SkipTrunc
SetCXISZ: xFmtStr_ = vbStr0
End Function

Function CvE2Z(a) As String 'Convert empty to zero
CvE2Z = Trim$(a)
If Len(CvE2Z) = 0 Then CvE2Z = vbStr0
End Function

Sub Cvt2xNum(z As xNum, x, DgMx&)
Select Case VarType(x)
  Case vbString: CStr2xNum z, CvE2Z(x), DgMx: Exit Sub
  Case Is < vbInteger     ' Convert empty to "0"
  Case Is < vbCurrency
    If x = Int(x) Then _
      If Abs(x) < DM Then _
        If x <> 0 Then _
          z.ndgt = 1: z.esp = 0: z.Sign = Sgn(x) - 1: z.dgt(0) = Abs(x): Exit Sub _
        Else _
          z.ndgt = 0: Exit Sub
    Select Case D2StrDgts
      Case 29: Real2xNum z, x: Exit Sub
      Case 0: CStr2xNum z, x, DgMx: Exit Sub
      Case Is < 29: CDbl2xNum z, x: Exit Sub
      Case Else: xCStr_ x, xDefDgts, z
          xRound_ z, xDefDgts - z.esp - (z.ndgt - 1) * xBASE - Len(CStr(z.dgt(z.ndgt - 1)))
'        If UseXroundIN Then _
          xRound_ z, xDefDgts - z.esp - (z.ndgt - 1) * xBASE - Len(CStr(z.dgt(z.ndgt - 1))) Else _
          xTrunc_ z, xDefDgts - z.esp - (z.ndgt - 1) * xBASE - Len(CStr(z.dgt(z.ndgt - 1)))
        Exit Sub
    End Select
  Case vbDecimal, vbByte, vbCurrency, vbLongLong: CStr2xNum z, x, DIGITS_LIMIT: Exit Sub
'  Case Is > vbArray: CStr2xNum z, x(1), DgMx: Exit Sub
  Case Else: ErrRaise
End Select
z.ndgt = 0
End Sub

Sub Int2xNum(x As xNum, ByVal y#)
x.esp = 0
Select Case Sgn(y)
  Case 1: x.Sign = False
    If y < DM Then x.dgt(0) = y: x.ndgt = 1: Exit Sub
  Case -1: x.Sign = True: y = Abs(y)
    If y < DM Then x.dgt(0) = y: x.ndgt = 1: Exit Sub
  Case Else: x.ndgt = 0: Exit Sub
End Select

If y < DM2 Then
  x.ndgt = 2
  #If Win64 Then
Dim c As my1lnglng, vd
    #If PacketSize > 9 Then
      If y >= Two_63 Then
        GoSub CreateVDint
        x.dgt(1) = Int(vd / DM)
        x.dgt(0) = vd - x.dgt(1) * CDec(DM): Exit Sub
      End If
    #End If
    vd = CLngLng(y): x.dgt(1) = vd \ DM
    x.dgt(0) = vd - x.dgt(1) * DM: Exit Sub
  #Else 'Not Win64
Dim c As my1cur, vd
    #If PacketSize > 7 Then
      If y < Ten15 Then vd = CDec(y) Else GoSub CreateVDint
    #Else
      vd = CDec(y) '14 digits will convert directly
    #End If
    x.dgt(1) = Int(vd / DM)
    x.dgt(0) = vd - x.dgt(1) * CDec(DM): Exit Sub
  #End If
 #If PacketSize > 9 Then
Else
 #Else
ElseIf y < DM3 Then
 #End If
' #If Win64 Then
'  #If PacketSize > 6 Then
  x.ndgt = 3
  GoSub CreateVD
  x.dgt(2) = Int(vd): vd = (vd - x.dgt(2)) * DM
  x.dgt(1) = Int(vd)
#If Win64 Then
  x.dgt(0) = (vd - x.dgt(1)) * DM: Exit Sub
#Else
  x.dgt(0) = Round((vd - x.dgt(1)) * DM): Exit Sub
#End If
#If PacketSize < 10 Then
 #If PacketSize > 7 Then
Else
 #Else
ElseIf y < DM4 Then
 #End If
  x.ndgt = 4
  GoSub CreateVD
  x.dgt(3) = Int(vd): vd = (vd - x.dgt(3)) * DM
  x.dgt(2) = Int(vd): vd = (vd - x.dgt(2)) * DM
  x.dgt(1) = Int(vd)
#If Win64 Then
  x.dgt(0) = (vd - x.dgt(1)) * DM: Exit Sub
#Else
  x.dgt(0) = Round((vd - x.dgt(1)) * DM): Exit Sub
#End If
#End If
#If PacketSize < 8 Then
 #If PacketSize > 5 Then
Else
 #Else
ElseIf y < DM5 Then
 #End If
  x.ndgt = 5
  GoSub CreateVD
  x.dgt(4) = Int(vd): vd = (vd - x.dgt(4)) * DM
  x.dgt(3) = Int(vd): vd = (vd - x.dgt(3)) * DM
  x.dgt(2) = Int(vd): vd = (vd - x.dgt(2)) * DM
  x.dgt(1) = Int(vd)
#If Win64 Then
  x.dgt(0) = (vd - x.dgt(1)) * DM: Exit Sub
#Else
  x.dgt(0) = Round((vd - x.dgt(1)) * DM): Exit Sub
#End If
#End If
#If PacketSize < 6 Then
Else 'If y < DM6 Then
  x.ndgt = 6
  GoSub CreateVD
  x.dgt(5) = Int(vd): vd = (vd - x.dgt(5)) * DM
  x.dgt(4) = Int(vd): vd = (vd - x.dgt(4)) * DM
  x.dgt(3) = Int(vd): vd = (vd - x.dgt(3)) * DM
  x.dgt(2) = Int(vd): vd = (vd - x.dgt(2)) * DM
  x.dgt(1) = Int(vd)
#If Win64 Then
  x.dgt(0) = (vd - x.dgt(1)) * DM: Exit Sub
#Else
  x.dgt(0) = Round((vd - x.dgt(1)) * DM): Exit Sub
#End If
#End If
'Else
End If

Dim w As my1double, z As my4ints, i%, j%

CreateVD:
  GoSub GetVd
' Now Multiply by stored Power of 2 increment to create up to 29 digit Number
  If j < 0 Then If j > -1024 Then vd = vd / Pof2M(-j) Else _
    j = -j: vd = vd * Pof2M(j) Else vd = vd * Pof2M(j)
  If Int(vd) = vd Then
    i = Sgn(j) * Pof2E(Abs(j)): j = Len(CStr(vd)) - 1 + i
  Else
    i = Len(CStr(vd)) - Len(CStr(Int(vd))) - 1
    x.esp = Sgn(j) * Pof2E(Abs(j)) - i ' Adjust Exponent to Integer
    j = Len(CStr(vd)) - 2
  End If
  vd = vd * 10 ^ (i - (j \ xBASE) * xBASE) ' Adjust Mantissa for most sig packet Int val
  Return

CreateVDint:
  GoSub GetVd
' Now Multiply by stored Power of 2 increment to create 29 digit Integer
If j < 0 Then If j > -1024 Then vd = vd / Pof2M(-j) / 10 ^ Pof2E(-j) Else _
  vd = vd * Pof2M(-j) * 10 ^ Pof2E(-j) Else vd = vd * Pof2M(j) * 10 ^ Pof2E(j)
  Return

GetVd:
w.myDouble = y: LSet z = w
j = (z.myInt3 And &H7FF0) \ &H10 - &H433 ' Get Power of 2 from Double Exponent
If j > -1075 Then
  z.myInt3 = (z.myInt3 And &HF) Or &H10 ' Add in the 53rd bit
Else
  j = -1074
End If
LSet c = z ' Move the Mantissa bits to a Currency data type in 32bit or a LongLong in 64bit
  #If Win64 Then ' Convert into a 16 digit Variant Decimal Integer
vd = CDec(c.mylnglng)
  #Else
vd = CDec(c.myCur) * 10000
  #End If
Return
End Sub

Function CReal2str(y) As String
Real2xNum xPow95(25), y
CReal2str = xNum2str(xPow95(25))
End Function

Sub Real2xNum(x As xNum, y)
Dim w As my1double, z As my4ints, i%, j%, vd, s$
x.esp = 0
Select Case Sgn(y)
  Case 1: w.myDouble = y: x.Sign = False
  Case -1: x.Sign = True: w.myDouble = Abs(y)
  Case Else: x.ndgt = 0: Exit Sub
End Select
If w.myDouble < DM Then If w.myDouble = Int(w.myDouble) Then _
    x.dgt(0) = w.myDouble: x.ndgt = 1: Exit Sub

LSet z = w
j = (z.myInt3 And &H7FF0) \ &H10 - &H433 ' Get Power of 2 from Double Exponent
If j > -1075 Then
  z.myInt3 = (z.myInt3 And &HF) Or &H10 ' Add in the 53rd bit
Else
  j = -1074
End If
  #If Win64 Then ' Convert into a 16 digit Variant Decimal Integer
Dim c As my1lnglng: LSet c = z
vd = CDec(c.mylnglng)
  #Else
Dim c As my1cur: LSet c = z
vd = CDec(c.myCur) * 10000
  #End If
' Now Multiply by stored Power of 2 increment to create 29 digit Number
If j < 0 Then If j > -1024 Then vd = vd / Pof2M(-j): x.esp = -Pof2E(-j) Else _
  vd = vd * Pof2M(-j): x.esp = Pof2E(-j) Else vd = vd * Pof2M(j): x.esp = Pof2E(j)

If vd = Int(vd) Then 'we need to check for 0's at the end
  s = vd: i = Len(s)
  While Mid$(s, i, 1) = vbStr0: i = i - 1: Wend
  j = Len(s) - i
  If j > 0 Then x.esp = x.esp + j: vd = vd / 10 ^ j: j = 0
Else ' Adjust Exponent to Integer
  i = Len(CStr(vd)) - 1: j = i - Len(CStr(Int(vd))): x.esp = x.esp - j
End If
i = (i - 1) \ xBASE ' zero based # of packets
x.ndgt = i + 1

vd = vd * 10 ^ (j - i * xBASE) ' Adjust Mantissa for most sig packet Int val
For j = i To 1 Step -1
  x.dgt(j) = Int(vd): vd = (vd - x.dgt(j)) * DM
Next
x.dgt(0) = Round(vd)
End Sub

Function CDbl2str(y) As String
CDbl2xNum xPow95(25), y
CDbl2str = xNum2str(xPow95(25))
End Function

Sub CDbl2xNum(x As xNum, y)
'Converts a number into an xNum
Dim w As my1double
x.esp = 0
Select Case Sgn(y)
  Case 1: w.myDouble = y: x.Sign = False
  Case -1: x.Sign = True: w.myDouble = Abs(y)
  Case Else: x.ndgt = 0: Exit Sub
End Select
If w.myDouble < DM Then If w.myDouble = Int(w.myDouble) Then _
    x.dgt(0) = w.myDouble: x.ndgt = 1: Exit Sub

Dim i%, v2, j%, z As my4ints, s$, vd

LSet z = w
j = (z.myInt3 And &H7FF0) \ &H10 - &H433 ' Get Power of 2 from Double Exponent
If j > -1075 Then
  z.myInt3 = (z.myInt3 And &HF) Or &H10 ' Add in the 53rd bit
Else
  j = -1074
End If
  #If Win64 Then ' Convert into a 16 digit Variant Decimal Integer
Dim c As my1lnglng: LSet c = z
v2 = CDec(c.mylnglng)
  #Else
Dim c As my1cur: LSet c = z
v2 = CDec(c.myCur) * 10000
  #End If
' Now Multiply by stored Power of 2 increment to create 29 digit Number
If j < 0 Then If j > -1024 Then v2 = v2 / Pof2M(-j): x.esp = -Pof2E(-j) Else _
  v2 = v2 * Pof2M(-j): x.esp = Pof2E(-j) Else v2 = v2 * Pof2M(j): x.esp = Pof2E(j)

vd = Int(v2)
s = CStr(vd)
j = CD2xNdgts - Len(s)
If j > 0 Then
  If vd <> v2 Then
    s = CStr(Round(v2 * 10 ^ j))
    x.esp = x.esp - j
  End If
ElseIf j < 0 Then
  s = CStr(Round(v2 * 10 ^ j))
  x.esp = x.esp - j
Else
  s = Round(v2)
End If
j = Len(s): While Mid$(s, j, 1) = vbStr0: j = j - 1: Wend
If j < Len(s) Then x.esp = x.esp + Len(s) - j
x.ndgt = (j - 1) \ xBASE + 1
j = j + 1
For i = 0 To x.ndgt - 2
  j = j - xBASE
  x.dgt(i) = Mid$(s, j, xBASE)
Next
x.dgt(i) = Left$(s, j - 1)
End Sub

Function CLng_(s) As Long
On Error Resume Next ' Set OverFlow Numeric values to 0
CLng_ = CLng(s)
End Function

Function CInt_(s) As Integer
On Error Resume Next ' Set OverFlow Numeric values to 0
CInt_ = CInt(s)
End Function

Function xCompZ_(c As xNum) As Integer
If c.ndgt = 0 Then Exit Function  ' xCompZ_ = 0
If c.Sign Then xCompZ_ = -1 Else xCompZ_ = 1
End Function

Function CDbl_(s) As Double
On Error GoTo EH ' Set OverFlow Numeric values to Max or Min allowable with sign
  CDbl_ = s: If CDbl_ <> 0 Then Exit Function
  CDbl_ = 4.94065645841247E-324 * xCompZ(s): Exit Function ' Set non-zero Strings to Min with sign
EH: Resume SetMax
SetMax: On Error Resume Next ' Convert non-numeric text to 0, when sgn(m) errors out
Dim m$, esp#: split_exp_ s, m, esp
If esp < 0 Then CDbl_ = Sgn(m) * 4.94065645841247E-324 Else CDbl_ = Sgn(m) * CDbl(VbMax)
End Function

Function xNum2Dbl(x As xNum) As Double
' Convert an xNum into a Double using only doubles
On Error GoTo EH
Dim esp#
Select Case x.ndgt
  Case 1: xNum2Dbl = x.dgt(0) * 10 ^ x.esp
  Case 2: xNum2Dbl = x.dgt(1) * 10 ^ (x.esp + xBASE) + x.dgt(0) * 10 ^ x.esp
  Case 0: Exit Function
#If PacketSize > 9 Then
  Case Else
    esp = (x.ndgt - 3) * xBASE + x.esp
    xNum2Dbl = x.dgt(x.ndgt - 1) * 10 ^ (esp + 2 * xBASE) + (x.dgt(x.ndgt - 2) * 10 ^ (esp + xBASE) + x.dgt(x.ndgt - 3) * 10 ^ esp)
#Else
  Case 3: xNum2Dbl = x.dgt(2) * 10 ^ (x.esp + 2 * xBASE) + (x.dgt(1) * 10 ^ (x.esp + xBASE) + x.dgt(0) * 10 ^ x.esp)
 #If PacketSize > 6 Then
  Case Else
    esp = (x.ndgt - 4) * xBASE + x.esp
    xNum2Dbl = x.dgt(x.ndgt - 1) * 10 ^ (esp + 3 * xBASE) + (x.dgt(x.ndgt - 2) * 10 ^ (esp + 2 * xBASE) + (x.dgt(x.ndgt - 3) * 10 ^ (esp + xBASE) + x.dgt(x.ndgt - 4) * 10 ^ esp))
 #Else ' PacketSize 5 and 6
  Case 4: xNum2Dbl = x.dgt(3) * 10 ^ (x.esp + 3 * xBASE) + (x.dgt(2) * 10 ^ (x.esp + 2 * xBASE) + (x.dgt(1) * 10 ^ (x.esp + xBASE) + x.dgt(0) * 10 ^ x.esp))
  Case Else
    esp = (x.ndgt - 5) * xBASE + x.esp
    xNum2Dbl = x.dgt(x.ndgt - 1) * 10 ^ (esp + 4 * xBASE) + (x.dgt(x.ndgt - 2) * 10 ^ (esp + 3 * xBASE) + (x.dgt(x.ndgt - 3) * 10 ^ (esp + 2 * xBASE) + (x.dgt(x.ndgt - 4) * 10 ^ (esp + xBASE) + x.dgt(x.ndgt - 5) * 10 ^ esp)))
 #End If
#End If
End Select
If xNum2Dbl = 0 Then
EH: If x.esp < 0 Then xNum2Dbl = vbMin343 Else xNum2Dbl = VbMax
End If
If x.Sign Then xNum2Dbl = -xNum2Dbl
End Function

Sub ErrRaise(Optional errno, Optional errdes, Optional flag)
If IsMissing(flag) Then flag = MacroFlag
#If CBool(VBA6 + VBA7) Then
If flag Then On Error Resume Next
#Else
On Error Resume Next
#End If
If IsMissing(errno) Then errno = 1000
If IsMissing(errdes) Then
  Err.Raise errno
Else
  Err.Raise errno, , errdes
End If
End Sub

Sub DispErr(Optional msg2)
Dim Msg As String
    Msg = "Error # " & str$(Err.number) & " was generated by " _
         & Err.Source & vbCr & Err.Description & vbCr
    If Not IsMissing(msg2) Then Msg = Msg & vbCr _
         & "Error Displayed by " & msg2
    MsgBox Msg, vbOKOnly + vbCritical + vbMsgBoxHelpButton, "Error", Err.HelpFile, Err.HelpContext
Err.Clear
End Sub

Sub SetDgMx(DgMx&, Digit_Max)
SetDigit_Max Digit_Max
DgMx = Digit_Max + SMPadj
If DgMx > DIGITS_LIMIT Then DgMx = DIGITS_LIMIT
End Sub

Sub SetDigit_Max(Digit_Max)
If IsMissing(Digit_Max) Then Digit_Max = Digits_Def: Exit Sub
Digit_Max = Int(Digit_Max) ' force it to no longer be an object
If Digit_Max > DIGITS_LIMIT Then Digit_Max = DIGITS_LIMIT: Exit Sub
If Digit_Max < 1 Then Digit_Max = Digits_Def
End Sub

Function xFmtDbl(x) As String
If VarType(x) = vbString Then xFmtDbl = Trim$(x) Else _
  xFmtDbl = xFmtStr(dCStr_(x), xDefDgts)
End Function

#Const CvtUsingDEC = False
#If CvtUsingDEC Then
#Else
#End If

#If CvtUsingDEC Then
Function CxN2logD0(x As xNum)
#Else
Function CxN2logD0(x As xNum) As Double ' Convert xNum to Log adjusted Double with 0 adj
#End If
CxN2logD CxN2logD0, x
If CxN2logD0 = -2147483648# Then CxN2logD0 = 0
End Function

#If CvtUsingDEC Then
Sub CxN2logD(dbl, x As xNum) ' Convert xNum to Log adjusted Double
#Else
Sub CxN2logD(dbl#, x As xNum) ' Convert xNum to Log adjusted Double
#End If
Dim i%, oesp#, oSign As Boolean
    If x.ndgt = 0 Then dbl = -2147483648#: Exit Sub
    oesp = x.esp: oSign = x.Sign
    i = (x.ndgt - 1) * xBASE + Len(CStr(x.dgt(x.ndgt - 1)))
    x.esp = -i: x.Sign = False
    dbl = Log(xNum2Dbl(x)) / qLn10_ + (oesp + i)
    x.esp = oesp: x.Sign = oSign
End Sub

Function xfDgMat(x As xNum, y As xNum, m) As Double
'If x.Sign = y.Sign Then If x.ndgt = y.ndgt Then If x.esp = y.esp Then GoTo ShortMethod
#If CvtUsingDEC Then
Dim a, b, c
#Else
Dim a#, b#, c#
#End If
CxN2logD a, x
CxN2logD b, y
If a = -2147483648# Then
  If b = -2147483648# Then GoTo SetExact
'  xfDgMat = -Abs(b) + m
  xfDgMat = -Abs(b)
'  xfDgMat = -b
  Exit Function
End If
If b = -2147483648# Then
'  xfDgMat = -Abs(a) + m
  xfDgMat = -Abs(a)
'  xfDgMat = -a
  Exit Function
End If
c = Abs(a - b)
If c < 1 Then
  xSub_ xPow95(25), x, y, DIGITS_LIMIT
  CxN2logD c, xPow95(25)
  If c = -2147483648# Then
SetExact: xfDgMat = m: Exit Function
  Else
    If a > b Then xfDgMat = a - c Else xfDgMat = b - c
    Exit Function
'Debug.Print dCStr_(xfDgMat), dCStr_(c)
  End If
Else
  xfDgMat = -c + 1
End If
End Function

Function xDgMat_(x As xNum, y As xNum, m) As Double
Dim a#, b#, c#, s$, t$
CxN2logD a, x
CxN2logD b, y
If a = -2147483648# Then
  If b = -2147483648# Then GoTo SetExact
  xDgMat_ = -Abs(b): Exit Function
End If
If b = -2147483648# Then xDgMat_ = -Abs(a): Exit Function
c = Abs(a - b)
If c < 1 Then
  c = DgtMatch(x, y)
  If c = 20000 Then
SetExact: xDgMat_ = m: Exit Function
  ElseIf c = 0 Then
    Exit Function
  Else
    s = xNumMantissa(x): t = xNumMantissa(y)
    a = Len(s) - c
    If a > 0 Then
      If a > 20 Then a = 20
      a = Mid$(s, c + 1, a) & "E-" & a
    Else
      a = 0
    End If
    b = Len(t) - c
    If b > 0 Then
      If b > 20 Then b = 20
      b = Mid$(t, c + 1, b) & "E-" & b
    Else
      b = 0
    End If
    xDgMat_ = c + 1 - Abs(a - b)
  End If
Else
  xDgMat_ = -c + 1
End If
End Function

Function rDgMat_(x As xNum, y As xNum) As Double
If x.Sign <> y.Sign Then Exit Function
rDgMat_ = xNumOrd(x): If rDgMat_ <> xNumOrd(y) Then Exit Function
xSub_ xPow95(25), x, y, DIGITS_LIMIT
rDgMat_ = rDgMat_ - xNumOrd(xPow95(25))
If rDgMat_ < 20000 Then Exit Function
rDgMat_ = 20000
End Function

Function DgtMatch(x As xNum, y As xNum) As Integer
Dim i%
#If Win64 Then
  Dim a^, b^
#Else
  Dim a#, b#
#End If
If x.Sign <> y.Sign Then Exit Function ' 0 matches
If x.ndgt = y.ndgt Then
 If x.esp = y.esp Then
  i = x.ndgt - 1
    For i = i To 0 Step -1
      If x.dgt(i) <> y.dgt(i) Then
        DgtMatch = (x.ndgt - i - 1) * xBASE + Len(CStr(x.dgt(x.ndgt - 1)))
  #If Win64 Then
        a = x.dgt(i) \ 10^: b = y.dgt(i) \ 10^: i = 1
        While a <> b: a = a \ 10^: b = b \ 10^: i = i + 1: Wend
  #ElseIf PacketSize > 9 Then
        a = Int(x.dgt(i) / 10): b = Int(y.dgt(i) / 10): i = 1
        While a <> b: a = Int(a / 10): b = Int(b / 10): i = i + 1: Wend
  #Else
        a = x.dgt(i) \ 10&: b = y.dgt(i) \ 10&: i = 1
        While a <> b: a = a \ 10&: b = b \ 10&: i = i + 1: Wend
  #End If
        DgtMatch = DgtMatch - i
        If DgtMatch < 0 Then DgtMatch = 0
        Exit Function
      End If
    Next
SetExact: DgtMatch = 20000: Exit Function
End If: End If
If xNumOrd(x) <> xNumOrd(y) Then Exit Function ' 0 matches
Dim s$, t$
s = xNumMantissa(x): t = xNumMantissa(y)
If Len(s) < Len(t) Then
  For i = 1 To Len(s): If Mid$(s, i, 1) <> Mid$(t, i, 1) Then GoTo NotExact
  Next: For i = i To Len(t): If Mid$(t, i, 1) <> vbStr0 Then GoTo NotExact
  Next: GoTo SetExact
Else
  For i = 1 To Len(t): If Mid$(s, i, 1) <> Mid$(t, i, 1) Then GoTo NotExact
  Next: For i = i To Len(s): If Mid$(s, i, 1) <> vbStr0 Then GoTo NotExact
  Next: GoTo SetExact
End If
NotExact: DgtMatch = i - 1
End Function

Function xNumOrd(x As xNum) As Double
  If x.ndgt = 0 Then xNumOrd = -2147483648#: Exit Function
  xNumOrd = CDbl(x.esp) + xBASE * (x.ndgt - 1) + Len(CStr(x.dgt(x.ndgt - 1))) - 1
End Function

Function xNumDigitCount(x As xNum) As Integer 'counts total significant digits of a Xnum
    If x.ndgt <> 0 Then xNumDigitCount = (x.ndgt - 1) * xBASE + Len(CStr(x.dgt(x.ndgt - 1)))
End Function

Function xNumLenInt(x) As Double 'counts total digits of an integer number or string
Dim y$, n#, k%, j%
If VarType(x) = vbString Then
  y = Trim$(x)
  If y <> vbStr0 Then
    k = InStr(y, "E") - 1: If k < 0 Then k = InStr(y, "e") - 1
    If k > 0 Then n = CDbl(Right$(y, Len(y) - k - 1)) Else k = Len(y)
    If Asc(y) = vbKeyMinus Then n = n - 1
    j = InStr(y, DecSep) - 1
    If j > 0 Then xNumLenInt = n + j Else xNumLenInt = n + k
  End If
Else
  If x <> 0 Then xNumLenInt = Int(Log(Abs(x) + 0.5) / dLn10_) + 1
End If
End Function

Function NumLenInt(x) As Integer 'counts total digits of an integer number
If x <> 0 Then NumLenInt = Int(Log(Abs(CDbl_(x)) + 0.5) / dLn10_) + 1
End Function

Function NumberLength(x$) As Double 'counts total length of a number string
CStr2xNum tXN(0), x, DIGITS_LIMIT
NumberLength = xNumberLength(tXN(0))
End Function

Function xNumberLength(x As xNum) As Double 'counts total length of an Xnum
If x.ndgt = 0 Then Exit Function
If x.esp >= 0 Then xNumberLength = (x.ndgt - 1) * xBASE + Len(CStr(x.dgt(x.ndgt - 1))) + CDbl(x.esp): Exit Function
xNumberLength = (x.ndgt - 1) * xBASE + Len(CStr(x.dgt(x.ndgt - 1)))
If -CDbl(x.esp) >= xNumberLength Then xNumberLength = 1 - CDbl(x.esp)
End Function

Sub SxMult_(z As xNum, x1 As xNum, x2 As xNum, DgMx&)
If x1.ndgt < x2.ndgt Then 'Ensure shortest is second param
  xMult_ z, x2, x1, DgMx
Else
  xMult_ z, x1, x2, DgMx
End If
End Sub

Sub xMult_(z As xNum, v1 As xNum, v2 As xNum, DgMx&)
' Should be called with v2 as shortest xNum
If v2.ndgt = 0 Or v1.ndgt = 0 Then z.ndgt = 0: Exit Sub

Dim i%, j%, k%, l%, m%, p%
#If UseVarDec Then
  Dim s, r
#ElseIf Win64 Then
  Dim s^, r^
#Else
  Dim s#, r#
#End If

m = (DgMx + xBASE - 2) \ xBASE
If m > xDgtLim Then m = xDgtLim     ' m = max dgt's to return
l = v1.ndgt + v2.ndgt - 2           ' l = max dgt after mult loop
p = l - m - xMultAdj: If p < 0 Then p = 0  ' p = min dgt req'd for DgMx request

#If Win64 Then
 ReDim tmp^(l - p + 1)  ' xMultAdj extra before and 1 after for remainder
#Else
 ReDim tmp#(l - p + 1)
#End If

Dim n%, o%
If p >= v2.ndgt Then o = v2.ndgt - 1 Else o = p
If p >= v1.ndgt Then n = p - v1.ndgt
For k = p To l
  If k < v2.ndgt Then o = k
  If k >= v1.ndgt Then n = n + 1
  For i = n To o
#If UseVarDec Then
    s = s + CDec(v1.dgt(k - i)) * v2.dgt(i)
#Else
    s = s + v1.dgt(k - i) * v2.dgt(i)
#End If
  Next i
  If s < DM Then
    tmp(k - p) = s: s = 0
  Else
    #If UseVarDec Or (Win64 = False) Then
      r = Int(s / DM)
    #Else
      r = s \ DM
    #End If
    tmp(k - p) = s - r * DM
    s = r                   ' s = remainder for start of next dgt
  End If
Next k
' save the final remainder(the most sig dgts), k = last dgt used
If s > 0 Then k = k - p: tmp(k) = s Else k = k - p - 1

i = k - m: If i < 0 Then i = 0    ' i = first dgt for possible return
While tmp(i) = 0: i = i + 1: Wend ' Find first non-zero dgt(packet) to return

z.Sign = v1.Sign Xor v2.Sign
s = CDbl(v1.esp) + v2.esp + (p + i) * xBASE ' p + i = all dgt's lost

If Abs(s) < 2147483648# Then
  z.esp = CLng(s)
ElseIf s > 0 Then
  OverFlowFlg = True
  j = (xBASE + s - 2147483648#) \ xBASE
  z.esp = CLng(s - xBASE * j)
  i = i - j
  If i < 0 Then
    ReDim Preserve tmp(xDgtLim + xMultAdj + 1)
    For j = k To 0 Step -1: tmp(j - i) = tmp(j): Next
    For j = 0 To -i - 1: tmp(j) = 0: Next
    k = k - i
    If k = NumOfPackets Then
      m = Len(CStr(tmp(k))) ' # of digits in most sig packet
      If m < xBASE Then
        z.esp = z.esp + m
        p = xBASE - m: i = 1: GoTo DoShift
      End If
    End If
    i = 0
  End If
  If tmp(i) = 0 Then tmp(i) = 1
ElseIf s < -2147483648# Then
  OverFlowFlg = True
  r = Int((xBASE - s - 2147483649#) / xBASE)
  If r > i Then GoTo ReturnMinNum Else j = CInt(r)
  i = i - j
  While tmp(i) = 0: i = i - 1: j = j + 1
    If i < 0 Then
ReturnMinNum: z.ndgt = 1: z.esp = -2147483648#: z.dgt(0) = 1: Exit Sub
    End If
  Wend
  z.esp = CLng(s + xBASE * j)
Else
  z.esp = CLng(s)
End If
k = k - i
If k < xDgtLim Then  ' Are we attempting to return full # of packets?
SkipShift:
  For j = 0 To k: z.dgt(j) = tmp(i + j): Next j
  z.ndgt = j: Exit Sub
End If
If i = 0 Then GoTo SkipShift
If tmp(i - 1) = 0 Then GoTo SkipShift ' Nothing to shift
m = Len(CStr(tmp(i + xDgtLim))) ' # of digits in most sig packet
If m = xBASE Then GoTo SkipShift ' First packet is already full
#If Win64 Then
  Dim q^, CR^
#Else
  Dim q#, CR#
#End If
p = xBASE - m
z.esp = z.esp - p
DoShift:
q = 10 ^ p: r = 10 ^ m
CR = Int(tmp(i - 1) / r)
For j = 0 To xDgtLim
  s = Int(tmp(i + j) / r)
  z.dgt(j) = CR + (tmp(i + j) - s * r) * q
  CR = s
Next j
z.ndgt = j
End Sub

Sub xSub_(z As xNum, x As xNum, y As xNum, DgMx&)
  y.Sign = Not y.Sign: xAdd_ z, x, y, DgMx
  If VarPtr(z) <> VarPtr(y) Then y.Sign = Not y.Sign
End Sub

Sub xAdd_(z As xNum, x1 As xNum, x2 As xNum, DgMx&)
Dim NegFlg As Boolean, c1%, c2%, MaxFlg As Boolean
Dim nMax%, max1&, Min1&, max2&, Min2&, oMax%, zSign As Boolean
Dim i%, j%, k%, ndgt1%, ndgt2%, esp1&, esp2&
#If Win64 Then
  Dim v1^(NumOfPackets), v2^(NumOfPackets), q^, CR^
#Else
  Dim v1#(NumOfPackets), v2#(NumOfPackets), q#, CR#
#End If
#If UseVarDec Then
  Dim r, d
  r = CDec(0)
#ElseIf Win64 Then
  Dim r^, d^
#Else
  Dim r#, d#
#End If

' Check for adding 0
If x1.ndgt = 0 Then z = x2: Exit Sub
If x2.ndgt = 0 Then z = x1: Exit Sub

' See if the numbers are too far separated for the code
If Abs(CDbl(x1.esp) - x2.esp) > DIGITS_LIMIT * 2& Then
  If x1.Sign = x2.Sign Then 'not subtracting, return the largest number
    If x1.esp > x2.esp Then z = x1 Else z = x2
  Else 'return the (larger exponent number minus a very small value)
    If x1.esp > x2.esp Then
      zSign = x2.Sign
      CStr2xNum xPow95(25), "1E" & CStr(CDbl(x1.esp) - DIGITS_LIMIT), DgMx
      xPow95(25).Sign = zSign
      xAdd_ xPow95(25), x1, xPow95(25), DgMx
      If xPow95(25).ndgt = 0 Then z = x1 Else z = xPow95(25)
    Else
      zSign = x1.Sign
      CStr2xNum xPow95(25), "1E" & CStr(CDbl(x2.esp) - DIGITS_LIMIT), DgMx
      xPow95(25).Sign = zSign
      xAdd_ xPow95(25), x2, xPow95(25), DgMx
      If xPow95(25).ndgt = 0 Then z = x2 Else z = xPow95(25)
    End If
  End If
  Exit Sub
End If

' See if we have to shift one of the numbers
ndgt1 = x1.ndgt - 1: ndgt2 = x2.ndgt - 1
k = x1.esp - Int(x1.esp / xBASE) * xBASE - x2.esp + Int(x2.esp / xBASE) * xBASE
If k > 0 Then
  If x2.ndgt < x1.ndgt Then k = xBASE - k:  GoTo ShiftX2
ShiftX1:
  esp1 = x1.esp - k
  esp2 = x2.esp
  If x1.Sign Then
    If x2.Sign Then zSign = True: GoTo SP2
    NegFlg = True
    For i = 0 To ndgt1
      d = r + x1.dgt(i) * 10 ^ k
    #If UseVarDec Or (Win64 = False) Then
      r = Int(d / DM)
    #Else
      r = d \ DM
    #End If
      If r <> 0 Then v1(i) = r * DM - d Else v1(i) = -d
    Next
    If r > 0 Then
      ndgt1 = i + 1: v1(i) = -r
    Else
      ndgt1 = i
    End If
  Else ' x1.sign=false
SP2: For i = 0 To ndgt1
      d = r + x1.dgt(i) * 10 ^ k
    #If UseVarDec Or (Win64 = False) Then
      r = Int(d / DM)
    #Else
      r = d \ DM
    #End If
      If r <> 0 Then v1(i) = d - r * DM Else v1(i) = d
    Next
    If r > 0 Then
      ndgt1 = i + 1: v1(i) = r
    Else
      ndgt1 = i
    End If
  End If
  If x2.Sign Then
    If zSign Then GoTo SP1
    NegFlg = True
    For i = 0 To ndgt2: v2(i) = -x2.dgt(i): Next
  Else
SP1: For i = 0 To ndgt2: v2(i) = x2.dgt(i): Next
  End If
  ndgt2 = i

ElseIf k < 0 Then
  If x1.ndgt < x2.ndgt Then k = xBASE + k:  GoTo ShiftX1
  k = Abs(k)
ShiftX2:
  esp2 = x2.esp - k
  esp1 = x1.esp
  If x2.Sign Then
    If x1.Sign Then zSign = True: GoTo SP3
    NegFlg = True
    For i = 0 To ndgt2
      d = r + x2.dgt(i) * 10 ^ k
    #If UseVarDec Or (Win64 = False) Then
      r = Int(d / DM)
    #Else
      r = d \ DM
    #End If
      If r <> 0 Then v2(i) = r * DM - d Else v2(i) = -d
    Next
    If r > 0 Then
      ndgt2 = i + 1: v2(i) = -r
    Else
      ndgt2 = i
    End If
  Else
SP3: For i = 0 To ndgt2
      d = r + x2.dgt(i) * 10 ^ k
    #If UseVarDec Or (Win64 = False) Then
      r = Int(d / DM)
    #Else
      r = d \ DM
    #End If
      If r <> 0 Then v2(i) = d - r * DM Else v2(i) = d
    Next
    If r > 0 Then
      ndgt2 = i + 1: v2(i) = r
    Else
      ndgt2 = i
    End If
  End If
  If x1.Sign Then
    If zSign Then GoTo SP4
    NegFlg = True
    For i = 0 To ndgt1: v1(i) = -x1.dgt(i): Next
  Else
SP4: For i = 0 To ndgt1: v1(i) = x1.dgt(i): Next
  End If
  ndgt1 = i

Else ' k = 0
  If x1.Sign Then
    If x2.Sign Then zSign = True: GoTo SP5
    NegFlg = True
    For i = 0 To ndgt1: v1(i) = -x1.dgt(i): Next
  Else
SP5: For i = 0 To ndgt1: v1(i) = x1.dgt(i): Next
  End If
  ndgt1 = i
  esp1 = x1.esp
  If x2.Sign Then
    If zSign Then GoTo SP6
    NegFlg = True
    For i = 0 To ndgt2: v2(i) = -x2.dgt(i): Next
  Else
SP6: For i = 0 To ndgt2: v2(i) = x2.dgt(i): Next
  End If
  ndgt2 = i
  esp2 = x2.esp
End If

' Figure out maximum packets required for DgMx request
nMax = (DgMx + xAddAdj) \ xBASE  ' 0 based max packet to return
If nMax >= xDgtLim Then nMax = xDgtLim: MaxFlg = True

Min1 = Int(esp1 / xBASE)  'Calculate the Min's and Max's
max1 = Min1 + ndgt1 - 1   'for both numbers to see if
Min2 = Int(esp2 / xBASE)  'they overlap or are separated
max2 = Min2 + ndgt2 - 1
If esp1 > esp2 Then esp1 = esp2
r = 0: q = 0
If max1 > max2 Then             ' First num max highest
  If Min1 > Min2 Then           ' Second num min lowest
    If max1 - Min2 > nMax Then  ' it won't all fit
      d = max1 - Min2 - nMax    ' calc how many will not fit
      Min2 = Min2 + CLng(d)     ' chop those off the lower one, #2
      If Min2 > max2 Then
       If NegFlg Then
        If Min1 < Min2 Then
          c1 = Min2 - Min1: Min1 = Min2 ' calc how many to chop off #1
          If v1(ndgt1 - 1) < 0 Then q = v1(c1 - 1) + 1 Else q = v1(c1 - 1) - 1
        ElseIf Min2 - max2 = 1 Then
          q = v2(ndgt2 - 1)
        Else
          If v1(ndgt1 - 1) < 0 Then q = 1 Else q = -1
        End If
FinishAddQ:
#If Win64 And Not UseVarDec Then
      esp1 = CDbl(esp1) + d * xBASE ' adj exponent for the chop
#Else
      esp1 = esp1 + d * xBASE
#End If
'        i = nMax - (Max1 - Min1) - C1
        k = nMax - (max1 - Min1) - 1
        If k < 0 Then i = nMax - (max1 - Min1) - c1: GoTo FinishNeg1a
        i = 0
        GoTo FinishNeg1
       Else 'Not NegFlg
        If MaxFlg Then
          If Min2 - max2 = 1 Then
            If Min1 < Min2 Then c1 = Min2 - Min1: Min1 = Min2 ' calc how many to chop off #1
            q = v2(ndgt2 - 1): GoTo FinishAddQ
          End If
        End If
        z = x1: Exit Sub      ' none of the lower is useful so return the original higher #
       End If
      End If
      c2 = CInt(d)              ' Save how many to chop off #2
      If Min1 < Min2 Then c1 = Min2 - Min1: Min1 = Min2 ' calc how many to chop off #1
#If Win64 And Not UseVarDec Then
      esp1 = CDbl(esp1) + d * xBASE ' adj exponent for the chop
#Else
      esp1 = esp1 + d * xBASE
#End If
    End If
  Else ' Min1 <= Min2, #2 overlaps #1 completly
    If max1 - Min1 > nMax Then  ' it won't all fit
      d = max1 - Min1 - nMax    ' calc how many will not fit
      Min1 = Min1 + CLng(d)     ' chop those off the lower one, #1
      If Min2 < Min1 Then c2 = Min1 - Min2: Min2 = Min1 ' if we have to chop #2 also
      If Min2 > max2 Then z = x1: Exit Sub         ' we chopped all of #2
      c1 = CInt(d)
      esp1 = esp1 + c1 * xBASE ' adj exponent for the chop
    End If
  End If
  If Min1 > max2 Then ' complete separation
    If MaxFlg Or NegFlg Then
      If c2 > 0 Then q = v2(c2 - 1)
    End If
    j = max2 - Min2
    For i = 0 To j: z.dgt(i) = v2(i + c2): Next
'    i = i + Min1 - Max2 - 1
    k = i + Min1 - max2 - 2 + c1
    If k < 0 Then i = i + Min1 - max2 - 1: GoTo FinishNeg1a
FinishNeg1:
    For i = i To k: z.dgt(i) = 0: Next ' Zero out area between incase something was there
FinishNeg1a:
    k = ndgt1 - 1
    For j = c1 To k: z.dgt(i + j) = v1(j): Next
FinishNoAdds:
    z.ndgt = i + j
    If Not NegFlg Then i = z.ndgt - 1: GoTo FinishCkQzero
FinishCkOvrFlow:
    If q <> 0 Then
      r = Int(q / DM)
      If r <> 0 Then q = q - r * DM
    End If
    k = z.ndgt - 1
    For i = 0 To k
      d = r + z.dgt(i)
      r = Int(d / DM)
      If r <> 0 Then z.dgt(i) = d - r * DM Else z.dgt(i) = d
    Next
    If r > 0 Then
      If i > xDgtLim Then GoSub ShiftFull: GoTo FinishCkEndZero
      z.ndgt = i + 1: z.dgt(i) = r
FinishCkQzero:
      If q = 0 Then GoTo FinishCkEndZero
      If i < xDgtLim Then GoTo FinishCkEndZero
      GoSub ShiftPart: GoTo FinishCkEndZero
    Else ' R <= 0
FinishCkRzero:
      If r = 0 Then
FinishCkShift:
        If q <> 0 Then
            If z.ndgt > xDgtLim Then GoSub ShiftPart
        End If
        k = z.ndgt - 1
        For i = k To 0 Step -1
TryAgain: If z.dgt(i) <> 0 Then Exit For
          If q > 0 Then
            For j = i To 1 Step -1: z.dgt(j) = z.dgt(j - 1): Next
            z.dgt(0) = q: q = 0: esp1 = esp1 - xBASE: GoTo TryAgain
          End If
        Next
        z.ndgt = i + 1
        If z.ndgt = 0 Then Exit Sub
FinishCkEndZero: z.Sign = zSign: z.esp = esp1
        If z.dgt(0) <> 0 Then Exit Sub
        k = z.ndgt - 1
        For i = 1 To k
          If z.dgt(i) <> 0 Then Exit For
        Next
        z.esp = z.esp + i * xBASE
        For j = i To k
          z.dgt(j - i) = z.dgt(j)
        Next
        z.ndgt = j - i: Exit Sub
      End If
      j = z.ndgt - 1
      If q <> 0 Then
        k = -1: q = DM - q: GoTo Finish5
      End If
      For k = 0 To j ' R < 0
        If z.dgt(k) <> 0 Then
          z.dgt(k) = DM - z.dgt(k)
Finish5:  For i = k + 1 To j
            z.dgt(i) = DM_1 - z.dgt(i)
          Next
          zSign = True: GoTo FinishCkShift
        End If
      Next
    End If
  ElseIf Min2 < Min1 Then ' partial overlap
    If MaxFlg Or NegFlg Then
      If c2 > 0 Then q = v2(c2 - 1)
    End If
    j = Min1 - Min2 - 1: For i = 0 To j: z.dgt(i) = v2(i + c2): Next
    k = i + max2 - Min1: For j = i To k: z.dgt(j) = v2(j + c2) + v1(j - i): Next
    oMax = j + max1 - max2 - 1: For k = j To oMax: z.dgt(k) = v1(k - i): Next
    z.ndgt = k: GoTo FinishCkOvrFlow
  ElseIf Min1 < Min2 Then ' complete overlap in the middle(v2)
    If MaxFlg Or NegFlg Then
      If c1 > 0 Then q = v1(c1 - 1)
    End If
    j = Min2 - Min1 - 1: For i = 0 To j: z.dgt(i) = v1(i + c1): Next
    k = i + max2 - Min2: For j = i To k: z.dgt(j) = v2(j - i) + v1(j + c1): Next
    oMax = j + max1 - max2 - 1: For k = j To oMax: z.dgt(k) = v1(k + c1): Next
    z.ndgt = k: GoTo FinishCkOvrFlow
  Else                    ' complete overlap at bottom(Min1 = Min2)
    oMax = max2 - Min2
    If MaxFlg Or NegFlg Then
      If c1 > 0 Then
        If c2 > 0 Then
          q = v1(c1 - 1) + v2(c2 - 1)
        Else
          q = v1(c1 - 1)
        End If
      ElseIf c2 > 0 Then
        q = v2(c2 - 1)
      End If
      If q <> 0 Then
        d = v1(c1) + v2(c2)
        k = 0: GoTo NotZ01
      End If
    End If
    For k = 0 To oMax
      d = v1(k + c1) + v2(k + c2)
      If d <> 0 Then GoTo NotZ0
    Next
    j = ndgt1 - 1
    For k = k To j
      If v1(k + c1) <> 0 Then GoTo NotZ4
    Next
    z.ndgt = 0: Exit Sub
NotZ4: esp1 = esp1 + k * xBASE
    For i = k To j: z.dgt(i - k) = v1(i + c1): Next
    j = -k: GoTo FinishNoAdds
NotZ0:
    If k > 0 Then esp1 = esp1 + k * xBASE
NotZ01:
    z.dgt(0) = d
    For i = k + 1 To oMax: z.dgt(i - k) = v1(i + c1) + v2(i + c2): Next
    j = ndgt1 - 1 - c1: For i = i To j: z.dgt(i - k) = v1(i + c1): Next
    z.ndgt = i - k: GoTo FinishCkOvrFlow
  End If
ElseIf max2 > max1 Then ' Second num max highest
  If Min2 > Min1 Then
    If max2 - Min1 > nMax Then
      d = max2 - Min1 - nMax
      Min1 = Min1 + CLng(d)
      If Min1 > max1 Then
       If NegFlg Then
        If Min2 < Min1 Then
          c2 = Min1 - Min2: Min2 = Min1
          If v2(ndgt2 - 1) < 0 Then q = v2(c2 - 1) + 1 Else q = v2(c2 - 1) - 1
        ElseIf Min1 - max1 = 1 Then
          q = v1(ndgt1 - 1)
        Else
          If v2(ndgt2 - 1) < 0 Then q = 1 Else q = -1
        End If
FinishAddQ2:
#If Win64 And Not UseVarDec Then
      esp1 = CDbl(esp1) + d * xBASE ' adj exponent for the chop
#Else
      esp1 = esp1 + d * xBASE
#End If
'        i = nMax - (Max2 - Min2) - C2
        k = nMax - (max2 - Min2) - 1
        If k < 0 Then i = nMax - (max2 - Min2) - c2: GoTo FinishNeg2a
        i = 0
        GoTo FinishNeg2
       Else 'Not NegFlg
        If MaxFlg Then
          If Min1 - max1 = 1 Then
            If Min2 < Min1 Then c2 = Min1 - Min2: Min2 = Min1
            q = v1(ndgt1 - 1): GoTo FinishAddQ2
          End If
        End If
        z = x2: Exit Sub
       End If
      End If
      c1 = CInt(d)
      If Min2 < Min1 Then c2 = Min1 - Min2: Min2 = Min1
#If Win64 And Not UseVarDec Then
      esp1 = CDbl(esp1) + d * xBASE ' adj exponent for the chop
#Else
      esp1 = esp1 + d * xBASE
#End If
    End If
  Else
    If max2 - Min2 > nMax Then
      d = max2 - Min2 - nMax
      Min2 = Min2 + CLng(d)
      If Min1 < Min2 Then c1 = Min2 - Min1: Min1 = Min2
      If Min1 > max1 Then z = x2: Exit Sub
      c2 = CInt(d)
      esp1 = esp1 + c2 * xBASE
    End If
  End If
  If Min2 > max1 Then     ' complete separation
    If MaxFlg Or NegFlg Then
      If c1 > 0 Then q = v1(c1 - 1)
    End If
    j = max1 - Min1: For i = 0 To j: z.dgt(i) = v1(i + c1): Next
'    i = i + Min2 - Max1 - 1
    k = i + Min2 - max1 - 2 + c2
    If k < 0 Then i = i + Min2 - max1 - 1: GoTo FinishNeg2a
FinishNeg2:
    For i = i To k: z.dgt(i) = 0: Next ' Zero out area between incase something was there
FinishNeg2a:
    k = ndgt2 - 1: For j = c2 To k: z.dgt(i + j) = v2(j): Next
    GoTo FinishNoAdds
  ElseIf Min1 < Min2 Then ' partial overlap
    If MaxFlg Or NegFlg Then
      If c1 > 0 Then q = v1(c1 - 1)
    End If
    j = Min2 - Min1 - 1: For i = 0 To j: z.dgt(i) = v1(i + c1): Next
    k = i + max1 - Min2: For j = i To k: z.dgt(j) = v1(j + c1) + v2(j - i): Next
    oMax = j + max2 - max1 - 1: For k = j To oMax: z.dgt(k) = v2(k - i): Next
    z.ndgt = k: GoTo FinishCkOvrFlow
  ElseIf Min2 < Min1 Then ' complete overlap in the middle(v1)
    If MaxFlg Or NegFlg Then
      If c2 > 0 Then q = v2(c2 - 1)
    End If
    j = Min1 - Min2 - 1: For i = 0 To j: z.dgt(i) = v2(i + c2): Next
    k = i + max1 - Min1: For j = i To k: z.dgt(j) = v1(j - i) + v2(j + c2): Next
    oMax = j + max2 - max1 - 1: For k = j To oMax: z.dgt(k) = v2(k + c2): Next
    z.ndgt = k: GoTo FinishCkOvrFlow
  Else                    ' complete overlap at bottom(Min1 = Min2)
    oMax = max1 - Min1
    If MaxFlg Or NegFlg Then
      If c1 > 0 Then
        If c2 > 0 Then
          q = v1(c1 - 1) + v2(c2 - 1)
        Else
          q = v1(c1 - 1)
        End If
      ElseIf c2 > 0 Then
        q = v2(c2 - 1)
      End If
      If q <> 0 Then
        d = v1(c1) + v2(c2)
        k = 0: GoTo NotZ11
      End If
    End If
    For k = 0 To oMax
      d = v2(k + c2) + v1(k + c1)
      If d <> 0 Then GoTo NotZ1
    Next
    j = ndgt2 - 1
    For k = k To j
      If v2(k + c2) <> 0 Then GoTo NotZ3
    Next
    z.ndgt = 0: Exit Sub
NotZ3: esp1 = esp1 + k * xBASE
    For i = k To j: z.dgt(i - k) = v2(i + c2): Next
    j = -k: GoTo FinishNoAdds
NotZ1:
    If k > 0 Then esp1 = esp1 + k * xBASE
NotZ11:
    z.dgt(0) = d
    For i = k + 1 To oMax: z.dgt(i - k) = v2(i + c2) + v1(i + c1): Next
    j = ndgt2 - 1 - c2: For i = i To j: z.dgt(i - k) = v2(i + c2): Next
    z.ndgt = i - k: GoTo FinishCkOvrFlow
  End If
Else 'Max1 = Max2
  If Min1 > Min2 Then     ' complete overlap at top(v1)
    oMax = Min1 - Min2
    For k = max1 - Min1 To 0 Step -1
      If v1(k) + v2(k + oMax) <> 0 Then GoTo NotZ5
    Next
    oMax = oMax - 1: For i = 0 To oMax: z.dgt(i) = v2(i): Next
    GoTo FinishNoAdds ' j=0
NotZ5:
    If k > nMax Then
      c2 = oMax + k - nMax
      esp1 = esp1 + xBASE * c2
      c1 = k - nMax: GoTo FinishChopBoth
    ElseIf oMax + k > nMax Then
      c2 = oMax + k - nMax
      If MaxFlg Or NegFlg Then q = v2(c2 - 1)
      j = oMax - 1 - c2: For i = 0 To j: z.dgt(i) = v2(i + c2): Next
      esp1 = esp1 + xBASE * c2
    Else
      oMax = oMax - 1: For i = 0 To oMax: z.dgt(i) = v2(i): Next
    End If
    k = k + i: For j = i To k: z.dgt(j) = v1(j - i) + v2(j + c2): Next
    z.ndgt = j: GoTo FinishCkOvrFlow
  ElseIf Min2 > Min1 Then ' complete overlap at top(v2)
    oMax = Min2 - Min1
    For k = max2 - Min2 To 0 Step -1
      If v2(k) + v1(k + oMax) <> 0 Then GoTo NotZ6
    Next
    oMax = oMax - 1: For i = 0 To oMax: z.dgt(i) = v1(i): Next
    GoTo FinishNoAdds ' j=0
NotZ6:
    If k > nMax Then
      c1 = oMax + k - nMax
      esp1 = esp1 + xBASE * c1
      c2 = k - nMax
FinishChopBoth:
      q = v1(c1 - 1) + v2(c2 - 1)
      For j = 0 To nMax: z.dgt(j) = v2(j + c2) + v1(j + c1): Next
      z.ndgt = j: GoTo FinishCkOvrFlow
    ElseIf oMax + k > nMax Then
      c1 = oMax + k - nMax
      If MaxFlg Or NegFlg Then q = v1(c1 - 1)
      j = oMax - 1 - c1: For i = 0 To j: z.dgt(i) = v1(i + c1): Next
      esp1 = esp1 + xBASE * c1
    Else
      oMax = oMax - 1: For i = 0 To oMax: z.dgt(i) = v1(i): Next
    End If
    k = k + i: For j = i To k: z.dgt(j) = v2(j - i) + v1(j + c1): Next
    z.ndgt = j: GoTo FinishCkOvrFlow
  Else                    ' complete overlap(Min2 = Min1 and Max1 = Max2)
    For k = max1 - Min1 To 0 Step -1
      If v1(k) + v2(k) <> 0 Then Exit For
    Next
    For j = 0 To k
      d = v1(j) + v2(j)
      If d <> 0 Then GoTo NotZ2
    Next j
    z.ndgt = 0: Exit Sub
NotZ2:
    If k - j > nMax Then
      j = k - j - nMax
      d = v1(j) + v2(j)
      If MaxFlg Or NegFlg Then
        q = v1(j - 1) + v2(j - 1)
        r = Int(q / DM)
        If r <> 0 Then d = d + r: q = q - r * DM
      End If
    End If
    If j > 0 Then esp1 = esp1 + j * xBASE
    r = Int(d / DM)
    If r <> 0 Then z.dgt(0) = d - r * DM Else z.dgt(0) = d
    For i = j + 1 To k
      d = r + v1(i) + v2(i)
      r = Int(d / DM)
      If r <> 0 Then z.dgt(i - j) = d - r * DM Else z.dgt(i - j) = d
    Next i
    If r > 0 Then
      i = i - j
      If i > xDgtLim Then z.ndgt = i: GoSub ShiftFull: GoTo FinishCkEndZero
      z.ndgt = i + 1: z.dgt(i) = r: GoTo FinishCkEndZero
    Else
      z.ndgt = i - j: GoTo FinishCkRzero
    End If
  End If
End If
ShiftFull:
Const DM1 = 10 ^ (xBASE - 1)
For i = xDgtLim To 0 Step -1
  q = z.dgt(i)
    #If UseVarDec Or (Win64 = False) Then
      d = Int(q / 10)
    #Else
      d = q \ 10
    #End If
  z.dgt(i) = d + r * DM1
  r = q - d * 10
Next i
esp1 = esp1 + 1
Return

ShiftPart: ' Enter with Q having extra digits
d = z.dgt(xDgtLim)
If d < 0 Then Debug.Print "ShiftPart Problem": Return
If d = 0 Then
  For i = xDgtLim To 1 Step -1: z.dgt(i) = z.dgt(i - 1): Next i
  esp1 = esp1 - xBASE: z.dgt(0) = q: GoTo SkipShift
End If
i = Len(CStr(d)) ' # of digits in most sig packet
If i = xBASE Then GoTo SkipShift ' First packet is already full
j = xBASE - i
esp1 = esp1 - j
r = 10 ^ i
#If UseVarDec Or (Win64 = False) Then
  CR = Int(q / r)
#Else
  CR = q \ r
#End If
q = 10 ^ j
For j = 0 To xDgtLim
    #If UseVarDec Or (Win64 = False) Then
      d = Int(z.dgt(j) / r)
    #Else
      d = z.dgt(j) \ r
    #End If
  z.dgt(j) = CR + (z.dgt(j) - d * r) * q
  CR = d
Next j
SkipShift: q = 0: r = 0: Return
End Sub

Sub xIncr_(x As xNum)
If x.ndgt = 0 Then x.ndgt = 1: x.dgt(0) = 1: x.Sign = False: x.esp = 0: Exit Sub
If x.Sign Then x.Sign = False: xDecr_ x: x.Sign = Not x.Sign: Exit Sub
#If Win64 Then
  Dim k&, i%, CR^
#Else
  Dim k&, i%, CR#
#End If

On Sgn(x.esp) + 1 GoTo Esp0, EspGT0

'EspLT0: 'If x.esp < 0 Then
  k = -(x.esp \ xBASE) 'Calc Packet # that has DecSep
  If k < NumOfPackets Then
    CR = 10 ^ (-x.esp Mod xBASE) ' Calc Value to add
    If k < x.ndgt Then
      x.dgt(k) = x.dgt(k) + CR
      If x.dgt(k) < DM Then Exit Sub
      x.dgt(k) = x.dgt(k) - DM
      For i = k + 1 To x.ndgt - 1
        If x.dgt(i) <> DM_1 Then x.dgt(i) = x.dgt(i) + 1: Exit Sub
        x.dgt(i) = 0
      Next
      x.dgt(i) = 1: x.ndgt = i + 1
    Else 'number is < 1 , add 0's if necessary
      For i = k - 1 To x.ndgt Step -1: x.dgt(i) = 0: Next
      x.ndgt = k + 1: x.dgt(k) = CR
    End If
  Else
UsexAdd: xAdd_ x, x, xSpougeX(-1), DIGITS_LIMIT
  End If
  Exit Sub

EspGT0: 'ElseIf x.esp > 0 Then
  k = x.esp \ xBASE + 1
  If x.ndgt + k > NumOfPackets Then GoTo UsexAdd
  CR = 10 ^ (xBASE - x.esp Mod xBASE) ' Calc Value to add
  If CR = DM Then CR = 1: k = k - 1
  x.esp = x.esp - k * xBASE
  For i = x.ndgt - 1 To 0 Step -1: x.dgt(i + k) = x.dgt(i): Next
  x.ndgt = x.ndgt + k: x.dgt(0) = CR 'add 0's if necessary
  For i = k - 1 To 1 Step -1: x.dgt(i) = 0: Next: Exit Sub

Esp0: 'Else 'x.esp = 0
  x.dgt(0) = x.dgt(0) + 1
  If x.dgt(0) <> DM Then Exit Sub
  For k = 1 To x.ndgt - 1
    If x.dgt(k) <> DM_1 Then x.dgt(0) = x.dgt(k) + 1: GoTo SetEsp
  Next: x.dgt(0) = 1
SetEsp: x.esp = k * xBASE
  For i = k + 1 To x.ndgt - 1: x.dgt(i - k) = x.dgt(i): Next
  x.ndgt = i - k
End Sub

Sub xDecr_(x As xNum)
#If Win64 Then
  Dim k&, i%, CR^
#Else
  Dim k&, i%, CR#
#End If
If x.ndgt = 0 Then x.esp = 0: x.ndgt = 1: x.dgt(0) = 1: x.Sign = True: Exit Sub
If x.Sign Then x.Sign = False: xIncr_ x: x.Sign = True: Exit Sub

On Sgn(x.esp) + 1 GoTo Esp0, EspGT0

'EspLT0: 'If x.esp < 0 Then
  k = -(x.esp \ xBASE) 'Calc location of DecSep
  If k > xDgtLim Then GoTo UsexSub
  CR = 10 ^ (-x.esp Mod xBASE)
  
  On Sgn(k - x.ndgt + 1) + 1 GoTo EQ, GT

LT: 'DecSep before last Packet, or = Last Packet with x.dgt(k) > CR
  i = k: k = x.ndgt - 1
  If x.dgt(i) < CR Then
    x.dgt(i) = x.dgt(i) - CR + DM
    For i = i + 1 To k: If x.dgt(i) <> 0 Then Exit For
      x.dgt(i) = DM_1: Next: CR = 1
  End If
  x.dgt(i) = x.dgt(i) - CR
  For i = k To 0 Step -1: If x.dgt(i) <> 0 Then Exit For
  Next: x.ndgt = i + 1: Exit Sub
GT: 'DecSep past last Packet
  x.dgt(0) = DM - x.dgt(0)
  For i = 1 To x.ndgt - 1: x.dgt(i) = DM_1 - x.dgt(i): Next
  k = k - 1: For i = i To k: x.dgt(i) = DM_1: Next
  x.dgt(i) = CR - 1
  For i = i To 0 Step -1: If x.dgt(i) <> 0 Then Exit For
  Next: x.ndgt = i + 1: x.Sign = True: Exit Sub
EQ: 'DecSep in last Packet, (x.ndgt - 1 = k)
  On Sgn(x.dgt(k) - CR) + 1 GoTo EQU, LT
  
'x.dgt(k) < CR
  x.Sign = True
  If k > 0 Then
    x.dgt(k) = CR - x.dgt(k) - 1
    x.dgt(0) = DM - x.dgt(0)
    For i = k - 1 To 1 Step -1: x.dgt(i) = DM_1 - x.dgt(i): Next
    For i = k To 0 Step -1: If x.dgt(i) <> 0 Then Exit For
    Next: x.ndgt = i + 1
  Else
    x.dgt(0) = CR - x.dgt(0): x.ndgt = 1
  End If
  Exit Sub
EQU: 'x.dgt(x.ndgt - 1) = CR
  For i = k - 1 To 0 Step -1: If x.dgt(i) <> 0 Then Exit For
  Next: x.ndgt = i + 1: Exit Sub

EspGT0: 'ElseIf x.esp > 0 Then
  k = x.esp \ xBASE + 1
  If x.ndgt + k <= NumOfPackets Then
    CR = DM - 10 ^ (xBASE - x.esp Mod xBASE)
    If CR = 0 Then CR = DM_1: k = k - 1
    For i = x.ndgt - 1 To 1 Step -1: x.dgt(i + k) = x.dgt(i): Next
    x.dgt(k) = x.dgt(0) - 1 'orig x.dgt(0) cannot be 0
    x.dgt(0) = CR: x.esp = x.esp - k * xBASE
    For i = k - 1 To 1 Step -1: x.dgt(i) = DM_1: Next
    For i = x.ndgt + k - 1 To 0 Step -1: If x.dgt(i) <> 0 Then Exit For
    Next: x.ndgt = i + 1: Exit Sub
  Else
UsexSub: xSub_ x, x, xSpougeX(-1), DIGITS_LIMIT: Exit Sub
  End If

Esp0: 'Else 'esp=0
  x.dgt(0) = x.dgt(0) - 1
  On Sgn(x.dgt(0)) + 1 GoTo L1, L2
L0: 'x.dgt(0) was =0
  x.dgt(i) = DM_1: i = i + 1: If x.dgt(i) = 0 Then GoTo L0
  x.dgt(i) = x.dgt(i) - 1
  For i = x.ndgt - 1 To 0 Step -1: If x.dgt(i) <> 0 Then Exit For
  Next: x.ndgt = i + 1: Exit Sub
L1: 'x.dgt(0) was = 1
  k = k + 1: If k = x.ndgt Then x.ndgt = 0: Exit Sub Else If x.dgt(k) = 0 Then GoTo L1
  x.esp = k * xBASE
  For i = 0 To x.ndgt - k - 1: x.dgt(i) = x.dgt(i + k): Next
  x.ndgt = i
L2: 'x.dgt(0) was > 1
End Sub

Sub xDiv_(z As xNum, v1 As xNum, v2 As xNum, DgMx&)
#If Win64 Then
  Dim QZ^(), V2d0^
  Const DM_2^ = DM \ 2
#Else
  Dim QZ#(), V2d0#
  #If PacketSize < 10 Then
    Const DM_2& = DM \ 2
  #Else
    Const DM_2# = DM / 2
  #End If
#End If
Dim ContaD%, ContaQ%, Qmax%
Dim i%, j%, n1%, n2%, Ndv%, esp#, fq%
#If UseVarDec Then
  Dim CR, q, x, r#, Dv1(), Dv2(), rst()
  CR = CDec(0)
#ElseIf Win64 Then
  Dim CR^, q^, x#, r^, Dv1^(), Dv2^(), rst^()
#Else
  Dim CR#, q#, x#, r#, Dv1#(), Dv2#(), rst#()
#End If
'check fast end
Ndv = v2.ndgt
If Ndv = 0 Then ErrRaise xlErrDiv0, "Divide by Zero": Exit Sub
If v1.ndgt = 0 Then z.ndgt = 0: Exit Sub
z.Sign = v1.Sign Xor v2.Sign

If Ndv = 1 Then
 V2d0 = v2.dgt(0)
 If V2d0 = 1 Then
  If VarPtr(z) <> VarPtr(v1) Then For i = v1.ndgt - 1 To 0 Step -1: z.dgt(i) = v1.dgt(i): Next: z.ndgt = v1.ndgt
  GoTo SetEsp
 ElseIf V2d0 = 2 Then
#If Win64 Or (PacketSize < 10) Then
  If v1.dgt(0) And 1 Then
    If VarPtr(z) = VarPtr(v1) Then GoTo UsePacketDiv
    If v1.ndgt = NumOfPackets Then GoTo UsePacketDiv
    j = 1: z.dgt(0) = DM_2: esp = -xBASE
  End If
  For i = 0 To v1.ndgt - 2
    z.dgt(i + j) = DM_2 * (v1.dgt(i + 1) And 1) + v1.dgt(i) \ 2
  Next
  If v1.dgt(v1.ndgt - 1) > 1 Then _
    z.dgt(v1.ndgt - 1 + j) = v1.dgt(v1.ndgt - 1) \ 2: z.ndgt = v1.ndgt + j Else _
    z.ndgt = v1.ndgt + j - 1
#Else
  If v1.dgt(v1.ndgt - 1) > 1 Then fq = v1.ndgt Else fq = v1.ndgt - 1: CR = DM
  If fq > xDgtLim Then GoTo UsePacketDiv
  If v1.dgt(0) / 2 <> Int(v1.dgt(0) / 2) Then j = 1: z.dgt(0) = DM_2: esp = -xBASE
  For i = fq - 1 To 0 Step -1
    x = (CR + v1.dgt(i)) / 2
    z.dgt(i + j) = Int(x)
    If z.dgt(i + j) = x Then CR = 0 Else CR = DM
  Next
  z.ndgt = fq + j
#End If
SetEsp:
  esp = esp + v1.esp - v2.esp
  If Abs(esp) < 2147483648# Then
    z.esp = esp: Exit Sub
  ElseIf esp > 0 Then
    OverFlowFlg = True
    j = (xBASE + esp - 2147483648#) \ xBASE
    z.esp = esp - xBASE * j
    For i = z.ndgt - 1 To 0 Step -1
      z.dgt(i + j) = z.dgt(i)
    Next
    z.ndgt = z.ndgt + j
    z.dgt(0) = 1
  ElseIf esp < -2147483648# Then
    OverFlowFlg = True
    q = Int((xBASE - esp - 2147483649#) / xBASE)
    On Error GoTo ReturnMinNum: j = CInt(q)
'    If q < 0 Then GoTo ReturnMinNum Else j = CInt(q)
    While z.dgt(j) = 0: j = j + 1: Wend
    For i = j To z.ndgt - 1
      z.dgt(i - j) = z.dgt(i)
    Next
    z.ndgt = z.ndgt - j
    z.esp = esp + xBASE * j
  Else
    z.esp = esp
  End If
  Exit Sub
 Else ' V2d0 > 2
UsePacketDiv:
  fq = (DgMx + xDivAdj) \ xBASE   '1 based # of packets to return
  If fq > xDgtLim Then
    fq = NumOfPackets
    If V2d0 < v1.dgt(v1.ndgt - 1) Then Qmax = fq Else Qmax = fq + 1 ' 1 more if returning 0.#
  Else
    If V2d0 < v1.dgt(v1.ndgt - 1) Then Qmax = fq - 1 Else Qmax = fq ' 1 more if returning 0.#
  End If
If Qmax > v1.ndgt Then ReDim Preserve QZ(Qmax) Else ReDim Preserve QZ(v1.ndgt)
#If UseVarDec Then
  x = CDec(V2d0)
#Else
  x = V2d0
#End If
  For i = v1.ndgt - 1 To 0 Step -1
    q = CR + v1.dgt(i)
    QZ(j) = Int(q / x)
    CR = DM * (q - x * QZ(j))
    j = j + 1
  Next i
  For ContaQ = j To Qmax
    If CR = 0 Then Exit For
    QZ(ContaQ) = Int(CR / x)
    CR = DM * (CR - x * QZ(ContaQ))
    esp = esp - xBASE
  Next
  GoTo finishQZ
 End If
End If

n1 = v1.ndgt - 1: n2 = Ndv - 1
fq = (DgMx + xDivAdj) \ xBASE  '1 based # of packets to return
If fq > xDgtLim Then
  fq = NumOfPackets
  If v2.dgt(n2) < v1.dgt(n1) Then Qmax = fq Else Qmax = fq + 1 ' 1 more if returning 0.#
Else
  If v2.dgt(n2) < v1.dgt(n1) Then Qmax = fq - 1 Else Qmax = fq ' 1 more if returning 0.#
End If
If v1.ndgt - Ndv > Qmax Then esp = (v1.ndgt - Ndv - Qmax) * xBASE
ReDim Preserve QZ(Qmax)
ReDim Preserve rst(Ndv)
ReDim Preserve Dv1(Ndv)
ReDim Preserve Dv2(Ndv)

For i = n2 To 0 Step -1
  Dv2(i) = v2.dgt(i) 'caricamento iniziale del vettore DV (divisore)
  j = n1 - n2 + i 'Initial load vector DV (divisor)
  If j < 0 Then esp = esp - xBASE Else Dv1(i) = v1.dgt(j)
Next
ContaD = j
#If UseVarDec Then
  x = CDec(Dv2(n2)) + Dv2(n2 - 1) / DM
#ElseIf PacketSize > 7 Then
  x = Dv2(n2) + (Dv2(n2 - 1) - 2) / DM ' Calc Divisor for estimate
#Else
  x = Dv2(n2) + (Dv2(n2 - 1) - 1) / DM
#End If

Do
#If UseVarDec Then
  q = Int((CDec(1) + Dv1(Ndv) * DM + Dv1(n2)) / x)
#ElseIf PacketSize > 7 Then
  q = Int((Dv1(Ndv) * DM + Dv1(n2) + 2) / x) ' quotient estimation
#Else
  q = Int((Dv1(Ndv) * DM + Dv1(n2) + 1) / x)
#End If
  If q > 0 Then
TryAgain:
    For i = 0 To Ndv 'calculate the remainder = dividend - divisor x quotient
      rst(i) = Dv1(i) - Dv2(i) * q + CR
      If rst(i) < 0 Then
#If Win64 And UseVarDec = False Then
        CR = Int(CDec(rst(i)) / DM) ' CDec required for integers < - 2^53
#Else
        CR = Int(rst(i) / DM)
#End If
        rst(i) = rst(i) - DM * CR
      Else
        CR = 0
      End If
    Next  'if Q is too large, repeat the division with lower Q
    If CR < 0 Then q = q - 1: CR = 0: GoTo TryAgain
  Else
    For i = 0 To Ndv: rst(i) = Dv1(i): Next ' save the current remainder from Dv1
  End If
  QZ(ContaQ) = q 'save the next packet value of the quotient
  ContaQ = ContaQ + 1: If ContaQ > Qmax Then Exit Do
  
  If ContaD > 0 Then
    ContaD = ContaD - 1 'load the new divisor from the current remainder
    For i = n2 To 0 Step -1: Dv1(i + 1) = rst(i): Next
    Dv1(0) = v1.dgt(ContaD)
  Else ' we also need to check for 0 remainder
Chk40: i = i - 1: If rst(i - 1) = 0 Then Dv1(i) = 0: If i > 1 Then GoTo Chk40 Else Exit Do
FinishLoad: Dv1(i) = rst(i - 1): i = i - 1: If i > 0 Then GoTo FinishLoad
    Dv1(0) = 0: esp = esp - xBASE
  End If
Loop
finishQZ:
While QZ(ContaQ - 1) = 0: ContaQ = ContaQ - 1: esp = esp + xBASE: Wend
' travaso quoziente in z
If ContaQ > fq Then
  If QZ(0) = 0 Then
    esp = esp + (ContaQ - fq - 1) * xBASE
    ContaQ = fq
  Else
    esp = esp + (ContaQ - fq) * xBASE
    ContaQ = fq - 1
  End If
Else
  If QZ(0) = 0 Then fq = ContaQ - 1 Else fq = ContaQ
  ContaQ = ContaQ - 1
End If
esp = esp + v1.esp - v2.esp
If Abs(esp) < 2147483648# Then
  z.esp = esp
  z.ndgt = fq
ElseIf esp > 0 Then
  OverFlowFlg = True
  j = (xBASE + esp - 2147483648#) \ xBASE
  z.esp = esp - xBASE * j
  ContaQ = ContaQ + j
  z.ndgt = fq + j
  If QZ(ContaQ) = 0 Then QZ(ContaQ) = 1
ElseIf esp < -2147483648# Then
  OverFlowFlg = True
  q = Int((xBASE - esp - 2147483649#) / xBASE)
  If q > ContaQ Then GoTo ReturnMinNum Else j = CInt(q)
  ContaQ = ContaQ - j
  While QZ(ContaQ) = 0: ContaQ = ContaQ - 1: j = j + 1
    If ContaQ < 0 Then
ReturnMinNum: z.ndgt = 1: z.esp = -2147483648#: z.dgt(0) = 1: Exit Sub
    End If
  Wend
  z.ndgt = fq - j
  z.esp = esp + xBASE * j
Else
  z.esp = esp
  z.ndgt = fq
End If
If z.ndgt <= xDgtLim Then ' Are we attempting to return full # of packets?
SkipShift: j = z.ndgt - 1
  For i = 0 To j: z.dgt(i) = QZ(ContaQ - i): Next: Exit Sub
End If
If QZ(ContaQ + 1) = 0 Then GoTo SkipShift ' Nothing to shift
i = Len(CStr(QZ(ContaQ - xDgtLim))) ' # of digits in most sig packet
If i = xBASE Then GoTo SkipShift ' First packet is already full
j = xBASE - i
z.esp = z.esp - j
q = 10 ^ j: r = 10 ^ i
CR = Int(QZ(ContaQ + 1) / r)
For i = 0 To xDgtLim
  x = Int(QZ(ContaQ - i) / r)
  z.dgt(i) = CR + (QZ(ContaQ - i) - x * r) * q
  CR = x
Next
End Sub

Sub xDivQr(n, d, q, r, Optional Is_Exact As Boolean)
'v. 14.12.2004  integer division
    Cvt2xNum tXN(0), n, DIGITS_LIMIT
    Cvt2xNum tXN(1), d, DIGITS_LIMIT
    xDivQr_ tXN(0), tXN(1), tXN(2), tXN(3)
    Is_Exact = Not CBool(tXN(3).ndgt)
    q = CvtxNum2str(tXN(2), DIGITS_LIMIT)
    r = CvtxNum2str(tXN(3), DIGITS_LIMIT)
End Sub

Sub xDivQr_(Num As xNum, Den As xNum, Quoz As xNum, Rest As xNum)
'v. 8.9.2007  integer division
#If Win64 Then
  Dim QZ^(xDgtLim + 3)
#Else
  Dim QZ#(xDgtLim + 3)
#End If
Dim ContaD%, ContaQ%
Dim i%, j%, n1%, n2%, Ndv%, esp#
#If UseVarDec Then
  Dim CR, rst(NumOfPackets), q
  Dim Dv1(NumOfPackets), Dv2(NumOfPackets), x, r#
  CR = CDec(0)
#ElseIf Win64 Then
  Dim CR^, rst^(NumOfPackets), q^
  Dim Dv1^(NumOfPackets), Dv2^(NumOfPackets), x#, r^
#Else
  Dim CR#, rst#(NumOfPackets), q#
  Dim Dv1#(NumOfPackets), Dv2#(NumOfPackets), x#, r#
#End If
'rende interi i numeri
uXN(3) = Num
Quoz.Sign = uXN(3).Sign Xor Den.Sign
Rest.Sign = uXN(3).Sign
If uXN(3).ndgt = 0 Then Quoz.ndgt = 0: Rest.ndgt = 0: Exit Sub
uXN(4) = Den: Rest.esp = uXN(4).esp
If uXN(4).esp <> 0 Then
  esp = CDbl(uXN(3).esp) - uXN(4).esp
  If Abs(esp) > 2147483646 Then GoTo LongWay
  uXN(3).esp = esp: uXN(4).esp = 0: esp = 0
End If
If uXN(3).esp < 0 Then
  Rest.esp = Rest.esp + uXN(3).esp: uXN(4).esp = -uXN(3).esp: uXN(3).esp = 0
  xNumLShift uXN(4), uXN(4).esp ' modifica uXN(4) to integer
  If uXN(4).ndgt = 0 Then GoTo SetZeroQ 'denom is larger than numerator
ElseIf uXN(3).esp > 0 Then
  xNumLShift uXN(3), uXN(3).esp, Dv1(uXN(4).ndgt) ' modifica uXN(3) to integer
  If uXN(3).ndgt = 0 Then 'numerator too large, do it the long way
LongWay: xDiv_ Quoz, Num, Den, DIGITS_LIMIT
    xFix_ Quoz
    xMult_ Rest, Quoz, Den, DIGITS_LIMIT
    xSub_ Rest, Num, Rest, DIGITS_LIMIT: Exit Sub
  End If
End If

If uXN(3).ndgt < uXN(4).ndgt Then
SetZeroQ: Quoz.ndgt = 0: Rest = Num: Exit Sub
End If

n1 = uXN(3).ndgt - 1: n2 = uXN(4).ndgt - 1

Ndv = uXN(4).ndgt
For i = n2 To 0 Step -1
  Dv2(i) = uXN(4).dgt(i)
  j = n1 - n2 + i
  Dv1(i) = uXN(3).dgt(j)
Next
ContaD = j

#If UseVarDec Then
  If n2 > 0 Then x = CDec(Dv2(n2)) + Dv2(n2 - 1) / DM Else x = CDec(Dv2(0))
#ElseIf PacketSize > 7 Then
  If n2 > 0 Then x = Dv2(n2) + (Dv2(n2 - 1) - 2) / DM Else x = Dv2(0)
#Else
  If n2 > 0 Then x = Dv2(n2) + (Dv2(n2 - 1) - 1) / DM Else x = Dv2(0)
#End If

Do ' quotient estimation
#If UseVarDec Then
  q = Int((CDec(1) + Dv1(Ndv) * DM + Dv1(n2)) / x)
#ElseIf PacketSize > 7 Then
  q = Int((Dv1(Ndv) * DM + Dv1(n2) + 2) / x)
#Else
  q = Int((Dv1(Ndv) * DM + Dv1(n2) + 1) / x)
#End If
  If q > 0 Then
TryAgain:
    For i = 0 To Ndv 'calculate the remainder = dividend - divisor x quotient
      rst(i) = Dv1(i) - Dv2(i) * q + CR
      If rst(i) < 0 Then
#If Win64 And UseVarDec = False Then
        CR = Int(CDec(rst(i)) / DM)
#Else
        CR = Int(rst(i) / DM)
#End If
        rst(i) = rst(i) - DM * CR
      Else
        CR = 0
      End If
    Next  'if Q is too large, repeat the division with lower Q
    If CR < 0 Then q = q - 1: CR = 0: GoTo TryAgain
  Else ' q = 0 , save the current remainder from Dv1,also make sure we have something left
    j = 0: For i = 0 To Ndv: rst(i) = Dv1(i): If rst(i) > 0 Then j = 1
    Next: If j = 0 Then esp = esp + ContaD * xBASE: Rest.ndgt = 0: GoTo NoRemainder 'GoTo SetNoRemain
  End If
  QZ(ContaQ) = q 'save the next packet value of the quotient
  ContaD = ContaD - 1
  If ContaD < 0 Then Exit Do
  
  For i = n2 To 0 Step -1: Dv1(i + 1) = rst(i): Next 'load the new divisor from the current remainder
  Dv1(0) = uXN(3).dgt(ContaD)
  ContaQ = ContaQ + 1
Loop
' travaso resto in rest
For j = n2 To 0 Step -1: If rst(j) <> 0 Then Exit For
Next: Rest.ndgt = j + 1: For i = 0 To j: Rest.dgt(i) = rst(i): Next
NoRemainder:
If ContaQ > 0 Then While QZ(ContaQ) = 0: ContaQ = ContaQ - 1: esp = esp + xBASE: Wend
' travaso quoziente in quoz
If QZ(0) = 0 Then Quoz.ndgt = ContaQ Else Quoz.ndgt = ContaQ + 1
Quoz.esp = esp
If Quoz.ndgt <= xDgtLim Then ' Are we attempting to return full # of packets?
SkipShift:
  For i = 0 To Quoz.ndgt - 1: Quoz.dgt(i) = QZ(ContaQ - i): Next
  Exit Sub
End If
If QZ(ContaQ + 1) = 0 Then GoTo SkipShift ' Nothing to shift
i = Len(CStr(QZ(ContaQ - xDgtLim))) ' # of digits in most sig packet
If i = xBASE Then GoTo SkipShift ' First packet is already full
j = xBASE - i
Quoz.esp = Quoz.esp - j
q = 10 ^ j: r = 10 ^ i
CR = Int(QZ(ContaQ + 1) / r)
For i = 0 To xDgtLim
  x = Int(QZ(ContaQ - i) / r)
  Quoz.dgt(i) = CR + (QZ(ContaQ - i) - x * r) * q
  CR = x
Next
End Sub

#If UseVarDec Then
  Private Sub xNumLShift(x As xNum, ByVal n&, Optional Extra = -1)
#ElseIf Win64 Then
  Private Sub xNumLShift(x As xNum, ByVal n&, Optional Extra^ = -1)
#Else
  Private Sub xNumLShift(x As xNum, ByVal n&, Optional Extra# = -1)
#End If
Dim w&, s$, i%, Num$, j%, k%
x.esp = x.esp - n
w = Int(n / xBASE) ' Calc # of whole groups to shift
If n - w * xBASE > 0 Then ' Its not an even multiple of groups
  j = x.ndgt - 1
  k = xBASE * j + 1 + Len(CStr(x.dgt(j)))
  If Extra = -1 Then
    If k - 1 + n > DIGITS_LIMIT Then x.ndgt = 0: Exit Sub
  Else
    If k - 1 + n > DIGITS_LIMIT + xBASE Then x.ndgt = 0: Exit Sub
  End If
  Num = String$(k - 1 + n, vbKey0)
  For i = 0 To x.ndgt - 1
    s = CStr(x.dgt(i)): j = Len(s)
    Mid$(Num, k - j, j) = s
    k = k - xBASE
  Next i

  x.ndgt = (Len(Num) - 1) \ xBASE + 1
  For i = 0 To w - 1: x.dgt(i) = 0: Next
  j = Len(Num) + 1 - w * xBASE
  For i = w To x.ndgt - 2
    j = j - xBASE
    x.dgt(i) = Mid$(Num, j, xBASE)
  Next i
  If i > xDgtLim Then Extra = Left$(Num, j - 1): x.ndgt = x.ndgt - 1 Else x.dgt(i) = Left$(Num, j - 1)
Else ' It is an even multiple of groups
  x.ndgt = x.ndgt + w
  If Extra = -1 Then
    If x.ndgt > NumOfPackets Then x.ndgt = 0: Exit Sub
  Else
    If x.ndgt > NumOfPackets Then
      x.ndgt = x.ndgt - 1
      If x.ndgt > NumOfPackets Then x.ndgt = 0: Exit Sub
      Extra = x.dgt(x.ndgt - w)
    End If
  End If
  For i = x.ndgt - 1 To w Step -1: x.dgt(i) = x.dgt(i - w): Next
  For i = i To 0 Step -1: x.dgt(i) = 0: Next
End If
End Sub

Sub xInt_(x As xNum)
If x.esp >= 0 Then Exit Sub
If x.ndgt = 0 Then Exit Sub
Dim k&, d&, i%
k = -(x.esp \ xBASE) ' Calc Packet Location of DecSep
If k < x.ndgt Then
  d = -x.esp - k * xBASE ' Calc position of DecSep in x.Dgt(k)
#If Win64 Then ' Calc Integer portion of dgt(k)
  Dim z^, p^: p = 10^ ^ d: If d > 0 Then z = (x.dgt(k) \ p) * p Else z = x.dgt(k)
#ElseIf PacketSize < 10 Then
  Dim z#, p#: p = 10# ^ d: If d > 0 Then z = (x.dgt(k) \ p) * p Else z = x.dgt(k)
#Else
  Dim z#, p#: p = 10# ^ d: If d > 0 Then z = Int(x.dgt(k) / p) * p Else z = x.dgt(k)
#End If
  If x.Sign Then ' Neg nums might require adjustment by -1
    If z = x.dgt(k) Then ' dgt(k) was already an Integer
      For i = 0 To k - 1 ' see if the previous ones are not 0
        If x.dgt(i) <> 0 Then GoTo NegAdd
      Next: GoTo CheckZero 'All previous were 0
    End If
NegAdd:
    z = z + p 'Add 1 to Integer portion of dgt(k)
    If z <> DM Then GoTo ChkShift 'No OverFlow
    For k = k + 1 To x.ndgt - 1 'Find the first digit we can add 1 to
      If x.dgt(k) <> DM_1 Then z = x.dgt(k) + 1: GoTo ChkShift
    Next 'they were all 9's
    x.dgt(0) = 1: x.ndgt = 1: x.esp = x.esp + k * xBASE: Exit Sub
  End If
CheckZero:
  If z = 0 Then ' Find the first non-zero dgt
    If k < x.ndgt - 1 Then
      For k = k + 1 To x.ndgt - 1
        If x.dgt(k) <> 0 Then GoTo NotZero
      Next k
    End If
    x.ndgt = 0: Exit Sub 'they were all 0's
NotZero: z = x.dgt(k)
  End If
ChkShift: x.dgt(0) = z: If k = 0 Then Exit Sub 'Else Shift the digits down
  x.ndgt = x.ndgt - k: x.esp = x.esp + k * xBASE
  For i = 1 To x.ndgt - 1: x.dgt(i) = x.dgt(i + k): Next
Else ' no digits to the left of DecSep, 0 for Positive, -1 for Negative
  If x.Sign Then x.dgt(0) = 1: x.ndgt = 1: x.esp = 0 Else x.ndgt = 0
End If
End Sub

Sub xIntSplit_(x As xNum, d As xNum, i As xNum)
If VarPtr(i) <> VarPtr(x) Then i = x
If VarPtr(d) <> VarPtr(x) Then d = x
xInt_ i: xDec_ d
End Sub

Sub xDec_(x As xNum)
Dim k&, j&
If x.esp < 0 Then
  If x.esp < -DIGITS_LIMIT Then Exit Sub 'no integer portion
  k = (-1 - x.esp) \ xBASE ' Calc Packet Location of first digit after the DecSep
  If k >= x.ndgt Then Exit Sub  'no integer portion
  x.ndgt = k + 1
  j = (-x.esp - k * xBASE) ' Calc position of DecSep in x.Dgt(k)
  If j < xBASE Then x.dgt(k) = Right$(CStr(x.dgt(k)), j)
Else 'if esp >= 0, all digits to the left of DecSep, return 0
  x.ndgt = 0
End If
End Sub

Sub xRound_(x As xNum, ByVal DecMax#)
'arrotonda  cifre di un numero esteso
Dim r#, Sign As Boolean
r = x.esp + DecMax 'Calc new esp
If r < 0 Then ' if new esp >= 0, all digits to the left of adjusted DecSep
  x.esp = r 'move the DecSep
  Sign = x.Sign: x.Sign = False ' assume truncate
  r = Int((-1 - r) / xBASE) ' Calc Packet Location of first digit after the DecSep
  If r < x.ndgt Then ' k must be a valid packet,Calc position of DecSep in x.Dgt(r)
    r = x.dgt(r) / 10# ^ (-x.esp - r * xBASE) ' if the first digit after the DecSep > 4 then
    If Int((r - Int(r)) * 10) > 4 Then x.Sign = True ' force a negative add in xInt_
  End If
  xInt_ x
  x.Sign = Sign
  x.esp = x.esp - DecMax
End If
End Sub

Sub xTrunc_(x As xNum, ByVal DecMax#)
'arrotonda  cifre di un numero esteso
Dim r#, Sign As Boolean
r = x.esp + DecMax 'Calc new esp
If r < 0 Then ' if new esp >= 0, all digits to the left of adjusted DecSep
  x.esp = r
  Sign = x.Sign: x.Sign = False
  xInt_ x
  x.Sign = Sign
  x.esp = x.esp - DecMax
End If
End Sub

Sub xFix_(x As xNum)
If x.esp < 0 Then _
  If x.Sign Then _
    x.Sign = False: xInt_ x: x.Sign = True _
  Else _
    xInt_ x
End Sub

Function xComp1_2(x As xNum) As Boolean
'Test if Decimal portion of xNum is exactly 1/2
If x.ndgt <> 0 Then
  If x.esp < 0 Then 'if esp >= 0, all digits to the left of DecSep, return False
    If x.esp > -xBASE Then
     If Right$(CStr(x.dgt(0)), -x.esp) = 5 * 10 ^ (-1 - x.esp) Then xComp1_2 = True
    ElseIf x.esp = -xBASE Then 'DecSep between 1st & 2nd packet
      If x.dgt(0) = DM / 2# Then xComp1_2 = True
End If: End If: End If
End Function

Function xComp1_(x As xNum) As Integer
' Test if xNum is between -1 and 1
If x.ndgt = 0 Then xComp1_ = -1: Exit Function ', it is between
Dim k&
If x.esp < 0 Then
  k = -(x.esp \ xBASE)
  If k >= x.ndgt Then xComp1_ = -1: Exit Function
  If k = x.ndgt - 1 Then
    If x.dgt(k) / 10 ^ (-x.esp Mod xBASE) < 1 Then xComp1_ = -1: Exit Function
  End If
ElseIf x.esp = 0 Then
  If x.ndgt = 1 Then If x.dgt(0) = 1 Then Exit Function   'it is 1 or -1, exit with xComp1_ = 0
End If
xComp1_ = 1 ' <-1 or > 1
End Function

Function xComp_(a As xNum, b As xNum) As Integer
If a.ndgt <> 0 Then
  If b.ndgt <> 0 Then
    If a.Sign = b.Sign Then
      Select Case xNumOrd(a) - xNumOrd(b)
        Case Is > 0: If a.Sign Then xComp_ = -1: Exit Function
          xComp_ = 1: Exit Function
        Case Is < 0: If a.Sign Then xComp_ = 1: Exit Function
          xComp_ = -1: Exit Function
        Case Else
          xSub_ xPow95(25), a, b, DIGITS_LIMIT
          If xPow95(25).ndgt = 0 Then Exit Function ' xComp_ = 0
          If xPow95(25).Sign Then xComp_ = -1 Else xComp_ = 1
          Exit Function
      End Select
  End If: End If
  If a.Sign Then xComp_ = -1 Else xComp_ = 1
  Exit Function
End If
If b.ndgt = 0 Then Exit Function
If b.Sign Then xComp_ = 1 Else xComp_ = -1
End Function

Function min_(a, b) As Double
    If a > b Then min_ = b Else min_ = a
End Function

Function max_(a, b) As Double
    If a > b Then max_ = a Else max_ = b
End Function

Sub Swap_(a, b)
Dim tmp
tmp = a: a = b: b = tmp
End Sub

Function Pari(x) As Boolean
' check if x is even. (1.3 uS)
Dim q As Double
q = x / 2
If q = Int(q) Then Pari = True
End Function

Function MCD_2(a, b) As Double
'Find the Maximun Common Divisor between two numbers
'by the Euclid method
'mod. 8/12/07 'curiously this method works also for decimal numbers !
'es a=2151.04, b=806.64  gcd => 268.88
Dim y#, x#, r#
y = Abs(b): x = Abs(a)
If x = 1 Or y = 1 Then MCD_2 = 1: Exit Function
Do Until x = 0
    r = y - x * Int(CDbl(y / x))
    y = x: x = r
Loop
MCD_2 = y
End Function

Function MCM_2(a, b) As Double
'Find the Minimun Common Multiple between two numbers
    MCM_2 = Abs(a * b / MCD_2(a, b))
End Function

Function xMCM_2(a, b) As String
'Find the Minimun Common Multiple between two extended numbers
Dim t(1) As xNum
Cvt2xNum t(1), a, DIGITS_LIMIT
Cvt2xNum t(0), b, DIGITS_LIMIT
xMCM_2_ t(1), t(0)
xMCM_2 = CvtxNum2str(tXN(0), DIGITS_LIMIT)
End Function

Sub xMCM_2_(a As xNum, b As xNum)
'Returns Minimun Common Multiple in tXN(0)
Dim DgMx&
If xComp1_(a) = 0 Then tXN(0) = b: GoTo xMCMx
If xComp1_(b) = 0 Then tXN(0) = a: GoTo xMCMx

tXN(0) = a: tXN(1) = b

Do Until tXN(1).ndgt = 0
  xDivQr_ tXN(0), tXN(1), tXN(2), tXN(3)
  tXN(0) = tXN(1): tXN(1) = tXN(3)
Loop
DgMx = (max3(tXN(0).ndgt, a.ndgt, b.ndgt) + 1) * xBASE
If DgMx < 28 Then DgMx = 28
xDiv_ tXN(0), a, tXN(0), DgMx
xMult_ tXN(0), tXN(0), b, DIGITS_LIMIT
xMCMx:: tXN(0).Sign = False
End Sub

Private Function max3(a, b, c) As Long
If a > b Then _
  If a > c Then max3 = a Else max3 = c _
Else _
  If b > c Then max3 = b Else max3 = c
End Function

Function max4(a, b, c, d)
If a > b Then _
  If a > c Then _
    If a > d Then max4 = a Else max4 = d _
  Else _
    If c > d Then max4 = c Else max4 = d _
Else _
  If b > c Then _
    If b > d Then max4 = b Else max4 = d _
  Else _
    If c > d Then max4 = c Else max4 = d
End Function

Function min4(a, b, c, d)
If a < b Then _
  If a < c Then _
    If a < d Then min4 = a Else min4 = d _
  Else _
    If c < d Then min4 = c Else min4 = d _
Else _
  If b < c Then _
    If b < d Then min4 = b Else min4 = d _
  Else _
    If c < d Then min4 = c Else min4 = d
End Function

Sub xSqr_(y As xNum, x As xNum, DgMx&)
'estrae la radice quadrata di x
If x.ndgt = 0 Then y.ndgt = 0: Exit Sub    'sqr(0)=0
If x.Sign Then ErrRaise: Exit Sub
Dim d&, p#, Lp#, z, w
uXN(1) = x
p = Int((uXN(1).esp - 15# + xNumDigitCount(uXN(1))) / 2#)
uXN(1).esp = uXN(1).esp - p * 2 'exponent reduction
w = CDec(xNum2str(uXN(1))): z = CDec(Sqr(w)) 'valore iniziale in double precision
CStr2xNum y, (z + w / z) / 2, DgMx  'now iniziale in quad precision
uXN(2).ndgt = 1: uXN(2).dgt(0) = 2: uXN(2).Sign = False: uXN(2).esp = 0 'Set divisor to 2
If DgMx > 60 Then d = 60 Else d = DgMx 'Limit initial estimate
TryAgain: uXN(3) = y ' Save the prev estimate
GoSub CalcEstimate: Lp = xfDgMat(y, uXN(3), DgMx) ' Calc initial # of matching digits
If Lp > 29 Then If d < DgMx Then d = DgMx: GoTo TryAgain 'Input is near a perfect square
w = DgMx / 2 + 0.5
If Lp > w Then If Lp >= DgMx Then GoTo DoneLoop Else If d = DgMx Then GoTo FinalEstimate
  d = Lp * 4 ' Skip if d is too large
  Do While d < w: GoSub CalcEstimate: d = d * 2: Loop ' Double d for expected correct # of digits
  d = DgMx: GoSub CalcEstimate ' Do the first one @ DgMx
FinalEstimate: GoSub CalcEstimate ' Now do the final one
DoneLoop: y.esp = y.esp + p ' Correct exponent reduction
Exit Sub

CalcEstimate: ' Calc the new estimate
  xDiv_ uXN(0), uXN(1), y, d: xAdd_ uXN(0), y, uXN(0), d: xDiv_ y, uXN(0), uXN(2), d
  Return
End Sub

Sub xExp_(y As xNum, x As xNum, DgMx&)
Dim e
SubExp y, x, e, DgMx
y.esp = y.esp + e
End Sub

Sub SubExp(y As xNum, x As xNum, Expon, Digit_Max&)
Dim i&, m&, n#, z#, DgMx&, xSign As Boolean
If x.ndgt = 0 Then y.dgt(0) = 1: y.ndgt = 1: y.Sign = False: y.esp = 0: Expon = 0: Exit Sub ' exp(0)=1
DgMx = Digit_Max + 1
z = Abs(xNum2Dbl(x)): xSign = x.Sign
If z >= dLn10_ Then
  xBC_ uXN(0), xLn10_, DgMx + Len(CStr(Round(z / dLn10_)))
  xDivQr_ x, uXN(0), uXN(1), uXN(2)
  uXN(2).Sign = False: z = xNum2Dbl(uXN(2))
  Expon = xNum2str(uXN(1))
  On Error Resume Next 'return exponent as Dec or String if too large
  Expon = CDec(Expon)
  On Error GoTo 0
Else
  uXN(2) = x: uXN(2).Sign = False: Expon = 0
End If

If z >= dLn2_ Then
  xBC_ y, xLn2_, DgMx + Len(CStr(Round(z / dLn2_)))
  xDivQr_ uXN(2), y, uXN(1), uXN(2)
  n = xNum2Dbl(uXN(1)): z = xNum2Dbl(uXN(2))
End If

Do Until z < 0.1: z = z / 2: m = m + 1: Loop
uXN(3).ndgt = 1: uXN(3).Sign = False: uXN(3).esp = 0
If m > 0 Then uXN(3).dgt(0) = 2 ^ m: xDiv_ uXN(2), uXN(2), uXN(3), DIGITS_LIMIT
DgMx = DgMx + m + n + 1
'start Taylor's sum
uXN(1) = uXN(2): y = uXN(2): xIncr_ y
For i = 2 To DIGITS_LIMIT * 2&
    uXN(3).dgt(0) = i
    xDiv_ uXN(0), uXN(2), uXN(3), DgMx
    xMult_ uXN(1), uXN(1), uXN(0), DgMx
    xAdd_ y, y, uXN(1), DgMx
    If xNumOrd(uXN(1)) < -Digit_Max Then Exit For
Next

For i = 1 To m: xMult_ y, y, y, DgMx: Next
If n > 0 Then uXN(3).dgt(0) = 2 ^ n: xMult_ y, y, uXN(3), DgMx
If xSign Then xDiv_ y, xSpougeX(-1), y, DgMx
End Sub

Sub xLn_(z As xNum, x As xNum, Digit_Max&)
Dim m%, n#, k&, s$, DgMx&
If x.Sign Or x.ndgt = 0 Then ErrRaise: Exit Sub       ' if x<=0 then error
DgMx = Digit_Max + 1
If x.ndgt = 1 Then If Abs(x.esp) < xBASE Then If ChkLnFast(z, x, DgMx) Then Exit Sub
s = CStr(x.dgt(x.ndgt - 1))
n = (x.ndgt - 1) * xBASE + Len(s)
uXN(3) = x: uXN(3).esp = -n: n = n + x.esp 'Make it 0.xxxx in uXN(3)
uXN(4).ndgt = 1: uXN(4).Sign = False: uXN(4).esp = 0
If Asc(s) = vbKey1 Then
  If xNum2Dbl(uXN(3)) > 0.112092689333156 Then GoTo SkipTrap
  n = n - 1: uXN(3).esp = uXN(3).esp + 1: m = 0 'Make it 1.xxx instead of 0.1xxx
Else
SkipTrap: m = Abs(Round(Log(DecSep & CStr(uXN(3).dgt(uXN(3).ndgt - 1))) / dLn2_)) ' always 0 to 3
  If m <> 0 Then uXN(4).dgt(0) = 2 ^ m: xMult_ uXN(3), uXN(3), uXN(4), DgMx
End If
uXN(2) = uXN(3): xIncr_ uXN(2): xDecr_ uXN(3)
xDiv_ uXN(2), uXN(3), uXN(2), DgMx
uXN(1) = uXN(2)
xMult_ uXN(0), uXN(2), uXN(2), DgMx
For k = 3 To DIGITS_LIMIT * 2& Step 2
  uXN(4).dgt(0) = k
  xMult_ uXN(1), uXN(1), uXN(0), DgMx
  xDiv_ uXN(3), uXN(1), uXN(4), DgMx
  xAdd_ uXN(2), uXN(2), uXN(3), DgMx
  If xNumOrd(uXN(3)) < -Digit_Max Then Exit For
Next k
DgMx = DgMx + Len(CStr(Round(n * dLn10_ + m * dLn2_))) + 1
uXN(4).dgt(0) = 2
xMult_ z, uXN(2), uXN(4), DgMx
If m <> 0 Then
  uXN(4).Sign = True: uXN(4).dgt(0) = m
  xBC_ uXN(0), xLn2_, DgMx
  xMult_ uXN(0), uXN(0), uXN(4), DgMx
  xAdd_ z, z, uXN(0), DgMx
End If
If n <> 0 Then
  xBC_ uXN(0), xLn10_, DgMx
  Int2xNum uXN(1), n
  xMult_ uXN(0), uXN(0), uXN(1), DgMx
  xAdd_ z, z, uXN(0), DgMx
End If
End Sub
Private Function ChkLnFast(z As xNum, x As xNum, DgMx&) As Boolean
  Select Case x.dgt(0) * 10 ^ x.esp
    Case 10: xBC_ z, xLn10_, DgMx
    Case 2: xBC_ z, xLn2_, DgMx
    Case 1: z.ndgt = 0 'if x=1 then xLn=0
    Case Else: Exit Function
  End Select
  ChkLnFast = True
End Function

Function BC(Num$, ByVal dgts%) As String
' Tests the UseXroundOUT flag to deturmine if Rounding or Truncating
' Works without converting to an xNum for strings > DIGITS_LIMIT
If dgts >= Len(Num) Then BC = Left$(Num, 1) & DecSep & Mid$(Num, 2): Exit Function
If UseXroundOUT Then ' Round the last digit if the next digit is >=5
  If Mid$(Num, dgts + 1, 1) > 4 Then
    While Mid$(Num, dgts, 1) = vbStr9: dgts = dgts - 1: Wend
    If dgts > 2 Then BC = Left$(Num, 1) & DecSep & Mid$(Num, 2, dgts - 2) & Chr$(Asc(Mid$(Num, dgts, 1)) + 1): Exit Function
    If dgts = 2 Then BC = Left$(Num, 1) & DecSep & Chr$(Asc(Mid$(Num, dgts, 1)) + 1): Exit Function
    BC = Chr$(Asc(Num) + 1): Exit Function
  End If
End If
If dgts > 1 Then
'  While Mid$(num, dgts, 1) = vbStr0: dgts = dgts - 1: Wend
  BC = Left$(Num, 1) & DecSep & Mid$(Num, 2, dgts - 1): Exit Function
Else
  BC = Left$(Num, 1)
End If
End Function

Sub xBC_(x As xNum, Num$, dgts&)
' Converts a string like "xyz" to an xNum as "x.yz" no sign, decimal points or exponents allowed!
' Calculates the next even multiple of xBASE + 1 and fills the xNum completely
Dim i%: x.ndgt = 1 + (dgts + xBASE - 1) \ xBASE
If x.ndgt > NumOfPackets Then x.ndgt = NumOfPackets
If Asc(Num) = vbKey0 Then x.esp = 2 Else x.esp = 1
For i = x.ndgt - 1 To 0 Step -1
  x.dgt(i) = Mid$(Num, x.esp, xBASE)
  x.esp = x.esp + xBASE
Next
x.esp = 2 - x.esp: x.Sign = False
End Sub

Sub xAngleReduction_(q%, Digit_Max, Cplmnt As Boolean)
'Reduces angle tXN(0) to range [>0, <=45) in Radians
'   tXN(0) = angle input, destroyed on exit if not too small
'   tXN(1) = angle reduced output
'   Q = quadrante output, 0=too small
'   Cplmnt = True if complemented angle
Dim d#, i%, dgts%, Q4isODD As Boolean
d = xNumOrd(tXN(0)): If d < q Then q = 0: Exit Sub ' x is too small
If d < 0 Then d = 0
d = (((Digit_Max + SMPadj) * 2 + d + xBASE - 1) \ xBASE) * xBASE + xBASE
If d > DIGITS_LIMIT Then d = DIGITS_LIMIT
tXN(3).esp = -d: tXN(3).Sign = False
tXN(3).ndgt = d \ xBASE
dgts = d + 2
For i = 0 To tXN(3).ndgt - 1
  dgts = dgts - xBASE
  tXN(3).dgt(i) = Mid$(xPi4_, dgts, xBASE)
Next
xDivQr_ tXN(0), tXN(3), tXN(2), tXN(1) ' x Mod Pi/4
If xNumOrd(tXN(2)) > DIGITS_LIMIT Then ErrRaise: Exit Sub ' x is too large
Q4isODD = xIsOdd_(tXN(2))
If Q4isODD Then ' We need the Complement
  tXN(1).Sign = True
  xAdd_ tXN(1), tXN(1), tXN(3), DIGITS_LIMIT
  If d = DIGITS_LIMIT Then
    tXN(0) = tXN(2): tXN(0).Sign = False: xIncr_ tXN(0)
    xMult_ tXN(0), xPow95(24), tXN(0), DIGITS_LIMIT
    xAdd_ tXN(1), tXN(1), tXN(0), DIGITS_LIMIT
  End If
ElseIf d = DIGITS_LIMIT Then
  If tXN(2).ndgt <> 0 Then
    xMult_ tXN(3), xPow95(24), tXN(2), DIGITS_LIMIT: xSub_ tXN(1), tXN(1), tXN(3), DIGITS_LIMIT
    If tXN(1).Sign <> tXN(2).Sign Then 'txn(2) is too big by one
      tXN(2).Sign = False: xDecr_ tXN(2): tXN(2).Sign = tXN(0).Sign
      Q4isODD = Not Q4isODD
    End If
  End If
End If
tXN(1).Sign = False
tXN(0).dgt(0) = 2: tXN(0).ndgt = 1: tXN(0).Sign = False: tXN(0).esp = 0
xDiv_ tXN(3), tXN(2), tXN(0), (d): tXN(3).Sign = tXN(2).Sign '/2 , maintain correct sign for 0
Cplmnt = Q4isODD Xor xIsOdd_(tXN(3)) ' Set complemented flag
tXN(0).dgt(0) = 4
xDivQr_ tXN(3), tXN(0), tXN(2), tXN(0) ' mod 4
q = Fix(xNum2Dbl(tXN(0))) ' Set Quadrant
If tXN(0).Sign Then q = q + 4 Else q = q + 1
End Sub

Sub xSin_rid(DgMx&)     'tXN(1) input, tXN(0) output
If tXN(1).ndgt = 0 Then tXN(0).ndgt = 0: Exit Sub ' sin 0=0
Dim i&, xNoY#
tXN(0) = tXN(1): xMult_ tXN(1), tXN(1), tXN(1), DgMx
tXN(3).ndgt = 1: tXN(3).dgt(0) = 6: tXN(3).esp = 0: tXN(3).Sign = False
xMult_ tXN(2), tXN(1), tXN(0), DgMx
xDiv_ tXN(2), tXN(2), tXN(3), DgMx: tXN(2).Sign = True
xAdd_ tXN(0), tXN(0), tXN(2), DgMx * 2: xNoY = xNumOrd(tXN(0))
For i = 5 To DIGITS_LIMIT * 2& Step 2
  If xNumOrd(tXN(2)) - xNoY <= -DgMx Then Exit Sub
  tXN(3).dgt(0) = i * (i - 1)
  xMult_ tXN(2), tXN(2), tXN(1), DgMx: xDiv_ tXN(2), tXN(2), tXN(3), DgMx
  tXN(2).Sign = Not tXN(2).Sign: xAdd_ tXN(0), tXN(0), tXN(2), DgMx
Next
End Sub

Sub xCos_rid(DgMx&)     'tXN(1) input, tXN(0) output
If tXN(1).ndgt = 0 Then tXN(0).Sign = False: tXN(0).ndgt = 1: tXN(0).dgt(0) = 1: tXN(0).esp = 0: Exit Sub ' cos 0=1
Dim i&
xMult_ tXN(1), tXN(1), tXN(1), DgMx
tXN(3).ndgt = 1: tXN(3).dgt(0) = 2: tXN(3).esp = 0: tXN(3).Sign = False
xDiv_ tXN(2), tXN(1), tXN(3), DgMx: tXN(2).Sign = True
tXN(0) = tXN(2): xIncr_ tXN(0)
For i = 4 To DIGITS_LIMIT * 2& Step 2
  tXN(3).dgt(0) = i * (i - 1)
  xMult_ tXN(2), tXN(2), tXN(1), DgMx: xDiv_ tXN(2), tXN(2), tXN(3), DgMx
  tXN(2).Sign = Not tXN(2).Sign: xAdd_ tXN(0), tXN(0), tXN(2), DgMx
  If xNumOrd(tXN(2)) <= -DgMx Then Exit Sub
Next
End Sub

Sub xTan_rid(DgMx&)  'tXN(1) input, tXN(0) output
If tXN(1).ndgt = 0 Then tXN(0).Sign = False: tXN(0).ndgt = 1: tXN(0).dgt(0) = 1: tXN(0).esp = 0: Exit Sub 'tan 0=1
Dim i&
xMult_ uXN(2), tXN(1), tXN(1), DgMx
uXN(1).ndgt = 1: uXN(1).dgt(0) = 2: uXN(1).Sign = False: uXN(1).esp = 0
xDiv_ uXN(0), uXN(2), uXN(1), DgMx
uXN(0).Sign = True: tXN(0) = uXN(0): xIncr_ tXN(0)
uXN(1).dgt(0) = 3
xDiv_ tXN(2), uXN(0), uXN(1), DgMx
xIncr_ tXN(2)
For i = 4 To DIGITS_LIMIT * 2& Step 2
  uXN(1).dgt(0) = i * (i - 1)
  xMult_ uXN(0), uXN(0), uXN(2), DgMx
  xDiv_ uXN(0), uXN(0), uXN(1), DgMx
  uXN(0).Sign = Not uXN(0).Sign
  xAdd_ tXN(0), tXN(0), uXN(0), DgMx
  uXN(1).dgt(0) = i + 1
  xDiv_ tXN(3), uXN(0), uXN(1), DgMx
  xAdd_ tXN(2), tXN(2), tXN(3), DgMx
  If xNumOrd(uXN(0)) <= -DgMx Then Exit For
Next
xMult_ tXN(2), tXN(2), tXN(1), DgMx
xDiv_ tXN(0), tXN(2), tXN(0), DgMx
End Sub

Sub xAtan_(x As xNum, DgMx&)
If x.ndgt = 0 Then Exit Sub
Dim i&, x_abs#, z_abs#, x_s As Boolean, xNoY#
x_s = x.Sign: z_abs = xNumDigitCount(x) + x.esp
If z_abs > DgMx Then xBC_ x, xPi2_, DgMx: x.Sign = x_s: Exit Sub
If z_abs < DgMx / -2 Then
  uXN(0).Sign = Not x.Sign: uXN(0).ndgt = 1: uXN(0).dgt(0) = 1: uXN(0).esp = -2147483648#
  xAdd_ x, x, uXN(0), DgMx: Exit Sub
End If
x.Sign = False: x_abs = xNum2Dbl(x)
If x_abs > 1 Then xDiv_ x, xSpougeX(-1), x, DgMx: z_abs = xNum2Dbl(x) Else z_abs = x_abs
If z_abs > 0.4 Then
  uXN(3) = x: xIncr_ uXN(3): xDecr_ x
  xDiv_ x, x, uXN(3), DgMx
End If
xNoY = xNumOrd(x)
uXN(3) = x: xMult_ uXN(0), x, x, DgMx
uXN(1).ndgt = 1: uXN(1).Sign = False: uXN(1).esp = 0
For i = 3 To DIGITS_LIMIT * 2& Step 2
  uXN(1).dgt(0) = i
  xMult_ uXN(3), uXN(3), uXN(0), DgMx: uXN(3).Sign = Not uXN(3).Sign
  xDiv_ uXN(2), uXN(3), uXN(1), DgMx
  xAdd_ x, x, uXN(2), DgMx
  If xNumOrd(uXN(2)) - xNoY <= -DgMx Then Exit For
Next
If z_abs > 0.4 Then xBC_ uXN(2), xPi4_, DgMx: xAdd_ x, x, uXN(2), DgMx
If x_abs > 1 Then xBC_ uXN(2), xPi2_, DgMx: xSub_ x, uXN(2), x, DgMx
If x_s Then x.Sign = Not x.Sign
End Sub

Sub SubSub1_(z As xNum, x As xNum, y As xNum, DgMx&)
  y.Sign = Not x.Sign: y.ndgt = 1: y.dgt(0) = 1: y.esp = -2147483648#
  xAdd_ z, x, y, DgMx
End Sub

Sub xAtan2_(y As xNum, x As xNum, DgMx&)
Dim xSign As Boolean
If x.ndgt <> 0 Then
  xSign = x.Sign
  xDiv_ x, y, x, DgMx
  xAtan_ x, DgMx
  If Not xSign Then Exit Sub
  If y.Sign Then
    xBC_ xPow95(25), xPi_, DgMx
    xSub_ x, x, xPow95(25), DgMx
  ElseIf y.ndgt = 0 Then
    xBC_ x, xPi_, DgMx
  Else 'y>0
    xBC_ xPow95(25), xPi_, DgMx
    xAdd_ x, x, xPow95(25), DgMx
  End If
Else 'x=0
  xBC_ x, xPi2_, DgMx: x.Sign = y.Sign
  If y.ndgt = 0 Then ErrRaise
End If
End Sub

Sub xERF_(x As xNum, Digit_Max&)
'returns the integral of Gauss' standard error function
Const maxloop& = 50000
Dim i&, DgMx&, t(1 To 5) As xNum
DgMx = Digit_Max + 2 + Int(SMPadj / 2)
xMult_ t(5), x, x, DgMx
t(1).ndgt = 1: t(1).dgt(0) = 2
xMult_ t(4), t(5), t(1), DgMx
t(3).ndgt = 1: t(3).dgt(0) = 3
xDiv_ t(1), t(4), t(3), DgMx
t(2) = t(1): xIncr_ t(2)
For i = 5 To maxloop Step 2
  t(3).dgt(0) = i
  xMult_ t(1), t(1), t(4), DgMx
  xDiv_ t(1), t(1), t(3), DgMx
  xAdd_ t(2), t(2), t(1), DgMx
  If xNumOrd(t(1)) < -Digit_Max Then Exit For
Next
t(3).dgt(0) = 2: t(5).Sign = True
xMult_ t(2), t(2), t(3), DgMx
xMult_ t(2), t(2), x, DgMx
xExp_ t(5), t(5), DgMx
xMult_ t(2), t(2), t(5), DgMx
xBC_ t(1), xSqPi_, DgMx
xDiv_ x, t(2), t(1), DgMx
End Sub

Sub xErfC_(x As xNum, Digit_Max&)
Const maxloop& = 50000
Dim a(6) As xNum, i&, DgMx&, pLp#, Lp#, Lp3sec#
DgMx = Digit_Max + 1 + Int(SMPadj / 2)
a(0).ndgt = 1: a(0).dgt(0) = 1
a(4).ndgt = 1: a(4).dgt(0) = 1
a(6).ndgt = 1
Lp = -CDbl(VbMax)
Lp3sec = Round((2081.53529036657 * DgMx ^ -1.71644376471666) * SpeedIndex): If Lp3sec > maxloop Then Lp3sec = maxloop
For i = 1 To maxloop
  a(6).dgt(0) = i
  Int2xNum a(2), 2 - i Mod 2
  xMult_ a(2), x, a(2), DgMx
  xMult_ a(5), a(3), a(6), DgMx
  xAdd_ a(5), a(2), a(5), DgMx
  xMult_ a(2), a(2), a(1), DgMx
  xMult_ a(0), a(0), a(6), DgMx
  xAdd_ a(2), a(2), a(0), DgMx
  xDiv_ a(2), a(2), a(5), DgMx
'      If DgtMatch(a(2), a(1)) >= Digit_Max Then Exit For
  
  pLp = Lp ' Save the previous matching digits
  Lp = xfDgMat(a(2), a(1), DgMx) ' See how many matching digits
  If Lp > Digit_Max Or Lp <= pLp Then Exit For
  
  xDiv_ a(0), a(1), a(5), DgMx
  xDiv_ a(3), a(4), a(5), DgMx
  a(1) = a(2)
  If i Mod Lp3sec = 0 Then DoEvents ' try and prevent "Not Responding" condition
Next
xMult_ a(0), x, x, DgMx: a(0).Sign = True
a(6).dgt(0) = 2
xMult_ x, x, a(6), DgMx
xExp_ a(0), a(0), DgMx
xMult_ a(6), a(0), a(6), DgMx
xAdd_ x, x, a(2), DgMx
xDiv_ x, a(6), x, DgMx
xBC_ a(6), xSqPi_, DgMx
xDiv_ x, x, a(6), DgMx
If x.ndgt = 0 Then x.esp = -2147483648#: x.ndgt = 1: x.Sign = False: x.dgt(0) = 1
End Sub

Function xGammaHalf(x$, d&) As String
Dim i, n, y
Const str17$ = "4831436058626442432403564453125E-17"
n = Abs(x): xBC_ tXN(0), xSqPi_, d
If n < 17 Then
  y = CDec(1)
  Do While n > 0.5: n = n - 1: y = y * n: Loop
  CStr2xNum tXN(1), y, d
  xMult_ tXN(0), tXN(0), tXN(1), d
Else
  CStr2xNum tXN(1), str17, d
  xMult_ tXN(0), tXN(0), tXN(1), d
  tXN(1).esp = -1: tXN(1).ndgt = 1
  For i = 175 To 10 * n - 10 Step 10
#If PacketSize > 7 Then
    tXN(1).dgt(0) = i
#Else
    If i < DM Then tXN(1).dgt(0) = i Else xIncr_ tXN(1)
#End If
    xMult_ tXN(0), tXN(0), tXN(1), d
  Next
End If
If x < 0 Then xGH_ x, d   'negative value transformation
xGammaHalf = xNum2str(tXN(0))
End Function
Private Sub xGH_(x$, d&)
Dim w(2) As xNum
w(2) = tXN(0)
xBC_ w(1), xPi_, d
CStr2xNum w(0), x, d: w(0).Sign = False: w(2).Sign = Not w(2).Sign
xMult_ tXN(1), w(1), w(0), d
CStr2xNum tXN(1), xSin(xNum2str(tXN(1)), d), d
xMult_ tXN(1), w(0), tXN(1), d
xMult_ tXN(1), w(2), tXN(1), d
xDiv_ tXN(0), w(1), tXN(1), d
End Sub
VBA Filename InitPrivate.bas Extracted Macro
Option Explicit
Option Private Module

'Debugging use only ---------------------
Sub Addin_Make_Visible()
  ThisWorkbook.IsAddin = False
End Sub
Sub Addin_Hide()
  ThisWorkbook.IsAddin = True
End Sub
'------------

Sub AutoCheck(Status)
Dim i&
If Status = False Then
  ThisWorkbook.BuiltinDocumentProperties(16) = 0
ElseIf Status = True Then
  i = ThisWorkbook.CustomDocumentProperties.Count
  If i = 0 Then
    ThisWorkbook.BuiltinDocumentProperties(16) = -1
  Else
    With ThisWorkbook.CustomDocumentProperties(i)
      Application.OnTime Now, .Value
      .Delete
    End With
  End If
Else
  ThisWorkbook.BuiltinDocumentProperties(16) = 0
  With ThisWorkbook.CustomDocumentProperties
    .Add Name:=CStr(.Count + 1), LinkToContent:=False, _
      Type:=msoPropertyTypeString, Value:=ThisWorkbook.Name & Status
  End With
End If
End Sub

Sub ReCompile()
On Error Resume Next
Application.VBE.MainWindow.Visible = False
AutoCheck "!InitPrivate.SetWeAreCompiled" 'last in is first out
'With Application.VBE.CommandBars.FindControl(id:=752)
' If .Enabled Then .Execute 'Close VBE
'End With
ThisWorkbook.VBProject.VBComponents("XnumbPrivate").Activate
With Application.VBE.CommandBars.FindControl(id:=578)
 If .Enabled Then .Execute 'Compile Xnumbers60
End With
With Application.VBE.CommandBars.FindControl(id:=106)
 If .Enabled Then .Execute 'Switch back to Excel
End With
AutoCheck True
End Sub

Sub SetWeAreCompiled()
WeAreCompiled = True
AutoCheck True
End Sub

Sub fixUnformattedStrings(ByVal NewRetUnFmtStr As Boolean)
Const SearchStr$ = "#Const RetUnFmtStr = "
If NewRetUnFmtStr <> CurRetUnFmtStr Then
  ReplaceModuleLine "XnumbPrivate", SearchStr, CStr(NewRetUnFmtStr)
  ReplaceModuleLine "Xnumb", SearchStr, CStr(NewRetUnFmtStr)
Else
  If Not AlreadyInstalled Then If ThisWorkbook.CustomDocumentProperties.Count = 0 Then AutoCheck True
End If
End Sub

Sub SetNewDigitsLimit(NewDigitsLimit&, Optional ReConfig)
'this can NOT be called from XnumbPrivate
'NewDigitsLimit is returned rounded to even # of packets
Dim NewPacketSize&, NewNumOfPackets& ', s$
Const rl$ = "#Const PacketSize = "
Const sl$ = "Const NumOfPackets& = "
ReConfig = CheckNewDigitsLimit(NewDigitsLimit, NewPacketSize, NewNumOfPackets)
If ReConfig Then
  ReplaceModuleLine "XnumbPrivate", rl, CStr(NewPacketSize)
  ReplaceModuleLine "XnumbPrivate", sl, CStr(NewNumOfPackets)
Else 'if No pending events and if not checking then start checking
  If Not AlreadyInstalled Then If ThisWorkbook.CustomDocumentProperties.Count = 0 Then AutoCheck True
End If
End Sub

Sub ReplaceModuleLine(Module$, SearchStr$, StrValue$)
Dim StartLine&, StartCol&, EndLine&, EndCol&
On Error GoTo EH
With ThisWorkbook.VBProject.VBComponents(Module).CodeModule
  StartLine = 1: EndLine = -1
  .Find SearchStr, StartLine, StartCol, EndLine, EndCol
  .ReplaceLine StartLine, SearchStr & StrValue
End With
Exit Sub
EH: DisplayVBPerr "ReplaceModuleLine."
End Sub

Sub DisplayVBPerr(s$)
If Foglio13.Range("E14") Then Exit Sub
Foglio13.Range("E14") = True ' Display error message only once
DispErr s & vbCr & "Xnumbers can NOT be properly configured." & vbCr & _
      "Hit Help for correction proceedures."
End Sub

Function CheckHasVBProject() As Boolean
Const vbext_ct_Document = 100
If AppVer < 12 Then
  Dim v
  On Error GoTo EH
  For Each v In ActiveWorkbook.VBProject.VBComponents
    If v.CodeModule.CountOfLines > 2 Or v.Type <> vbext_ct_Document Then
      CheckHasVBProject = True: Exit Function
    End If
  Next
Else
  CheckHasVBProject = ActiveWorkbook.HasVBProject
End If
Exit Function
EH: DisplayVBPerr "CheckHasVBProject."
End Function

Sub CreateCopy()
On Error GoTo EH
Const vbext_ct_ClassModule = 2
Const vbext_ct_Document = 100
Const vbext_ct_MSForm = 3
Const vbext_ct_StdModule = 1
Dim FName, s$, FolderName$, v, ModuleName$, SavedStatus() As Boolean, wbc&, tmpName$
Dim OrigCalcStatus%, OrigEnableEvents As Boolean, tmpWorkBook As Workbook, FileForm%
FName = Foglio13.Range("C4")
ShowFormXN "Creating " & FName & "..."
DoEvents
OrigEnableEvents = Application.EnableEvents
Application.ScreenUpdating = False
Application.EnableEvents = False ' Must stop Workbook_Open in new TmpWorkbook
wbc = Workbooks.Count
If wbc <> 0 Then
  ReDim SavedStatus(wbc - 1): v = 0
  For Each tmpWorkBook In Workbooks: SavedStatus(v) = tmpWorkBook.Saved: v = v + 1: Next
Else
  Workbooks.Add
End If
OrigCalcStatus = Application.Calculation
FolderName = ThisWorkbook.Path & "\xnModules\"
On Error Resume Next 'Incase FolderName exists with no files
If Len(Dir(FolderName & "*.*")) <> 0 Then Kill FolderName & "*.*" Else MkDir FolderName
On Error GoTo EH
tmpName = FName: Mid$(tmpName, InStrRev(tmpName, "."), 1) = "_"
s = tmpName & "Cfg.ini"
If Len(Dir(s)) <> 0 Then Kill s
If Right$(FName, 1) = "m" Then
  If AppVer < 12 Then FileForm = xlAddIn Else FileForm = 55 'xlOpenXMLAddIn
Else
  FileForm = xlAddIn
End If
tmpName = tmpName & ".xl"
If Len(Dir(tmpName)) <> 0 Then Kill tmpName
Application.Calculation = xlCalculationAutomatic
ThisWorkbook.SaveCopyAs tmpName
Set tmpWorkBook = Workbooks.Add(tmpName)
Kill tmpName

SetNewLabels tmpWorkBook, FixFullPath(FName)
With tmpWorkBook
  .BuiltinDocumentProperties(16) = 0
  .BuiltinDocumentProperties(20) = xNumTitle & ", " & Right$(.BuiltinDocumentProperties(1), _
    Len(.BuiltinDocumentProperties(1)) - 9) 'Write this to Configuration file
  For Each v In .CustomDocumentProperties: v.Delete: Next
On Error Resume Next
  .VBProject.Description = .BuiltinDocumentProperties(1)
End With
If Err Then DisplayVBPerr "Save Copy As.": GoTo CloseFile
On Error GoTo EH

For Each v In ThisWorkbook.VBProject.VBComponents
  If v.Type <> vbext_ct_Document Then
    Select Case v.Type
      Case vbext_ct_StdModule: s = ".bas"
      Case vbext_ct_MSForm: s = ".frm"
      Case vbext_ct_ClassModule: s = ".cls"
      Case Else: s = ".bas"
    End Select
    ModuleName = FolderName & v.Name & s
    v.Export FileName:=ModuleName
    With tmpWorkBook.VBProject.VBComponents
      .Remove .item(v.Name)
      .Import FileName:=ModuleName
    End With
  ElseIf v.CodeModule.CountOfLines <> 0 Then
    s = v.CodeModule.Lines(1, v.CodeModule.CountOfLines)
    With tmpWorkBook.VBProject.VBComponents(v.Name).CodeModule
      .DeleteLines 1, v.CodeModule.CountOfLines
      .InsertLines 1, s
    End With
  End If
Next v
Kill FolderName & "*.*": RmDir FolderName 'comment out line to retain all modules

Application.Calculation = xlCalculationManual
tmpWorkBook.Sheets("setting").Range("C4").Clear 'Not ReStarting
Application.Calculation = xlCalculationAutomatic

tmpWorkBook.SaveAs FileName:=tmpName, FileFormat:=FileForm
CloseFile:
tmpWorkBook.Saved = True
tmpWorkBook.Close
On Error Resume Next
If Len(Dir(FName)) <> 0 Then Kill FName
If Err Then MsgBox "Error Replacing Currently loaded Add-In" & vbLf & "New Add-in is named " & tmpName: GoTo EHexit
On Error GoTo EH
Name tmpName As FName
EHexit:
If Application.Calculation <> OrigCalcStatus Then Application.Calculation = OrigCalcStatus
If wbc <> 0 Then
  v = 0: For Each tmpWorkBook In Workbooks: tmpWorkBook.Saved = SavedStatus(v): v = v + 1: Next
Else
  ActiveWorkbook.Saved = True
  ActiveWorkbook.Close
End If
UnloadFormXN
Application.ScreenUpdating = True
AutoCheck True
Application.EnableEvents = OrigEnableEvents
Exit Sub

EH: DispErr "Save Copy As"
If Not tmpWorkBook Is Nothing Then
  tmpWorkBook.Saved = True
  tmpWorkBook.Close
End If
Resume EHexit
End Sub

Function CheckNewDigitsLimit(NewDigitsLimit&, NewPacketSize&, NewNumOfPackets&) As Boolean
If NewDigitsLimit > 32765 Then NewDigitsLimit = 32765
  #If Win64 Then
If AutoPacketSize Then
  If NewDigitsLimit > 8 * 922 Then
    NewPacketSize = 7
  Else
    NewPacketSize = 8
  End If
Else 'Custom PacketSize
  NewPacketSize = xBASE
  Select Case xBASE
    Case 8: If NewDigitsLimit > 8 * 922 Then NewDigitsLimit = 8 * 922
    Case 9: If NewDigitsLimit > 9 * 9 Then NewDigitsLimit = 9 * 9
    Case 13: If NewDigitsLimit > 13 * 792 Then NewDigitsLimit = 13 * 792
    Case 14: If NewDigitsLimit > 14 * 7 Then NewDigitsLimit = 14 * 7
  End Select
End If
  #Else '32 bit
If AutoPacketSize Then
  If NewDigitsLimit > 7 * 90 Then
    NewPacketSize = 6
  Else
    NewPacketSize = 7
  End If
Else
  NewPacketSize = xBASE
  Select Case xBASE
    Case 7: If NewDigitsLimit > 7 * 90 Then NewDigitsLimit = 7 * 90
    Case 13: If NewDigitsLimit > 13 * 792 Then NewDigitsLimit = 13 * 792
    Case 14: If NewDigitsLimit > 14 * 7 Then NewDigitsLimit = 14 * 7
  End Select
End If
  #End If
NewNumOfPackets = (NewDigitsLimit + NewPacketSize - 1) \ NewPacketSize
NewDigitsLimit = NewPacketSize * NewNumOfPackets
If NewDigitsLimit > 32765 Then
  NewNumOfPackets = NewNumOfPackets - 1
  NewDigitsLimit = NewPacketSize * NewNumOfPackets
End If
If NewDigitsLimit = DIGITS_LIMIT Then If NewPacketSize = xBASE Then Exit Function
CheckNewDigitsLimit = True
End Function

Sub SetXnCfgFile()
XnCfgFile = ThisWorkbook.Name
Mid$(XnCfgFile, InStrRev(XnCfgFile, "."), 1) = "_"
XnCfgFile = ThisWorkbook.Path & "\" & XnCfgFile & "Cfg.ini"
End Sub
VBA Filename FrmFunctionBook.frm Extracted Macro

Option Explicit

'Public Variables only avail to this Module
Dim MyArray()        'Matrice contenente i valori
Dim Categ()
Dim ncol, nrow, CategMax
Dim MyNameWB$, File_Name$
Dim ws As Worksheet

Const RowOffset = 2

Private Sub ComboBox1_Change()
    LoadListMacro
End Sub

Private Sub CommandButton1_Click()
    'search s
    If Len(TextBox1.Value) <> 0 Then
        SearchMacro TextBox1.Value
    Else
        LoadListMacro
    End If
End Sub

Private Sub CommandButton2_Click()
Dim id, r, MyCell
      If ListBox1.ListCount >= 1 Then
        id = ListBox1.ListIndex
        If id = -1 Then Exit Sub
        r = ListBox1.List(id, 4)
        If Len(r) = 0 Then Exit Sub
        Me.Hide
        DoEvents
        MyCell = RefEdit1.Value
        If Len(MyCell) = 0 Then Exit Sub
        MacroActivate r, MyCell
    End If
    Setting_Save
    Unload Me
End Sub

Private Sub CommandButton3_Click()
    Unload Me
End Sub

Private Sub CommandButton4_Click()
'mod 28-7-02
Dim id, r
If ListBox1.ListCount >= 1 Then
    id = ListBox1.ListIndex
    If id = -1 Then
        Application.Help XHelpFile, 70
    Else
        r = ListBox1.List(id, 4)
        If Len(r) = 0 Then Exit Sub
        HelpCaller ws, r
    End If
End If
End Sub


Private Sub ListBox1_Click()
Dim id, r&, k&
If ListBox1.ListCount >= 1 Then
    id = ListBox1.ListIndex
    r = ListBox1.List(id, 4)
    If Len(r) = 0 Then Exit Sub
    If id >= 0 And Len(r) <> 0 Then
        Label1.Caption = ws.Cells(r, 4)
        If ListBox1.List(id, 3) <> File_Name Then GoTo UseRealName
        If ListBox1.List(id, 0) <> "Sub" Then GoTo UseRealName
        With shToolbarGen
        For k = 2 To MenuMax
          If .Cells(k, 5) = ListBox1.List(id, 1) Then
            If .Cells(k, 4) <> vbNullString Then _
              Label2.Caption = .Cells(k, 2) & " > " & .Cells(k, 3) & " > " & .Cells(k, 4) Else _
              Label2.Caption = .Cells(k, 2) & " > " & .Cells(k, 3)
            Exit Sub
          End If
        Next
        End With
UseRealName: Label2.Caption = ws.Cells(r, 2) & ws.Cells(r, 3)
    Else
        Label1.Caption = vbNullString
        Label2.Caption = vbNullString
    End If
End If
End Sub

Private Sub OpB1_Click()
LoadListMacro
End Sub

Private Sub OpB2_Click()
LoadListMacro
End Sub

Private Sub OpB3_Click()
LoadListMacro
End Sub

Private Sub UserForm_Initialize()
    MyNameWB = ThisWorkbook.Name
    File_Name = Left$(MyNameWB, InStr(MyNameWB, ".") - 1)
    Set ws = Workbooks(MyNameWB).Worksheets("FunctionsBook")
    Me.Label1 = vbNullString
    LoadListCategory
    Setting_Restore
    If ActiveCell Is Nothing Then Exit Sub
    RefEdit1.Value = ActiveCell.Address
End Sub

Sub LoadListMacro()
'mod. 28-7-02
Dim MacroTable, MacroType, Category, last_row&, j&, i&
    If Frame1.OpB1 = True Then MacroType = "all"
    If Frame1.OpB2 = True Then MacroType = "Sub"
    If Frame1.OpB3 = True Then MacroType = "Function"
    Category = ComboBox1.Value
    'load functions table
    With ws
      last_row = .Range("A1").CurrentRegion.Rows.Count
      MacroTable = .Range(.Cells(2, 1), .Cells(last_row, 10))
    End With
    ncol = 5
    nrow = UBound(MacroTable)
    If nrow > 0 Then
        ReDim MyArray(nrow - 1, ncol)
        ListBox1.ColumnCount = ncol    'Casella di riepilogo
        j = 0
        'Carica valori interi in MyArray
        For i = 1 To nrow
            If MacroType = "all" Or _
               MacroType = MacroTable(i, 1) Then
                If Category = "(all)" Or _
                   Category = MacroTable(i, 5) Then
                    MyArray(j, 0) = MacroTable(i, 1) 'macro type
                    MyArray(j, 1) = MacroTable(i, 2) 'name
                    MyArray(j, 2) = MacroTable(i, 6) 'title
                    MyArray(j, 3) = MacroTable(i, 8) 'addin
                    MyArray(j, 4) = i + RowOffset - 1      'Index row
                    j = j + 1
                End If
            End If
        Next i
        RedimArray MyArray
        'Carica ListBox1
        ListBox1.List() = MyArray
    End If
    ListBox1.ListIndex = -1
    Label1.Caption = vbNullString
    Label2.Caption = vbNullString
End Sub

Sub LoadListCategory()
    Dim Ws2 As Worksheet, k&
    ReDim Categ(100)
    ComboBox1.ColumnCount = 1
    Categ(0) = "(all)"
    k = 1
    Set Ws2 = Workbooks(MyNameWB).Worksheets("FunctionCategory")
    While Ws2.Cells(k + RowOffset - 1, 1) <> vbNullString
        Categ(k) = Ws2.Cells(k + RowOffset - 1, 1)
        k = k + 1
    Wend
    CategMax = k
    ReDim Preserve Categ(CategMax - 1)
    ComboBox1.List = Categ
    ComboBox1.ListIndex = 0
End Sub

Sub SearchMacro(SearchString)
'mod. 28-7-02
Dim MacroTable, MacroType, Category, last_row&, j&, i&, x
Dim myRange As Range
If Frame1.OpB1 = True Then MacroType = "all"
If Frame1.OpB2 = True Then MacroType = "Sub"
If Frame1.OpB3 = True Then MacroType = "Function"
Category = ComboBox1.Value
'load functions table
With ws
  last_row = .Range("A1").CurrentRegion.Rows.Count
  MacroTable = .Range(.Cells(2, 1), .Cells(last_row, 10))
End With
ncol = 5
nrow = UBound(MacroTable)
If nrow > 0 Then
    ReDim MyArray(nrow - 1, ncol)
    ListBox1.ColumnCount = ncol    'Casella di riepilogo
    j = 0
    'Carica valori interi in MyArray
    For i = 1 To nrow
        If MacroType = "all" Or _
            MacroType = MacroTable(i, 1) Then
            If Category = "(all)" Or _
               Category = MacroTable(i, 5) Then
                'begin find
                Call FindMultiText(MacroTable, i, SearchString, x)
                If x > 0 Then
                    MyArray(j, 0) = MacroTable(i, 1)
                    MyArray(j, 1) = MacroTable(i, 2)
                    MyArray(j, 2) = MacroTable(i, 6)
                    MyArray(j, 3) = MacroTable(i, 8)
                    MyArray(j, 4) = i + RowOffset - 1
                    j = j + 1
                End If
            End If
        End If
    Next i
    RedimArray MyArray
    'Carica ListBox1
    ListBox1.List() = MyArray
End If
ListBox1.ListIndex = -1
Label1.Caption = vbNullString
Set myRange = Nothing
End Sub

Sub FindMultiText(MacroTable, i_row, SearchString, Ret)
'rev. 28-7-02
Dim SubStr(1 To 20), MaxSubStr, SepChar, p1, p2, i&, j&, Ris1, cv
If Len(SearchString) = 0 Then Ret = 1: Exit Sub
'extract sep char
SepChar = ","  'OR
If InStr(SearchString, "+") > 0 Then SepChar = "+"  'AND
p1 = 1: i = 0
Do
    p2 = InStr(p1, SearchString, SepChar)
    If p2 = 0 Then p2 = Len(SearchString) + 1
    i = i + 1
    SubStr(i) = LCase$(Trim$(Mid$(SearchString, p1, p2 - p1)))
    p1 = p2 + 1
Loop Until p1 > Len(SearchString)

MaxSubStr = i: Ret = 0

For i = 1 To MaxSubStr
    Ris1 = 0
    For j = 1 To UBound(MacroTable, 2)
        cv = LCase$(MacroTable(i_row, j))
        If cv Like "*" & SubStr(i) & "*" Then
            Ris1 = 1:  Exit For
        End If
    Next
    If Ris1 = 0 Then
        Ret = 0
        If SepChar = "+" Then Exit For
    Else
        Ret = 1
        If SepChar = "," Then Exit For
    End If
Next
End Sub

'Private Function SetWbName(WbName)
''sceglie xla or xls in base al tipo di file correntemente aperto
'Dim newname, p&
'p = InStr(WbName, ".")
'
'If p > 0 Then
'    newname = Left$(WbName, p - 1)
'Else
'    newname = WbName
'End If
'
'If ThisWorkbook.IsAddin Then
'    newname = newname & ".xla"
'Else
'    newname = newname & ".xls"
'End If
'SetWbName = newname
'End Function

Private Sub RedimArray(MyArray)
Dim n1&, n2&, a(), i&, j&
'Redim MrArray to the correct size
n1 = UBound(MyArray, 1)
n2 = UBound(MyArray, 2)
ReDim a(n1, n2)
For i = 0 To n1    'bug 28-7-02
    If Len(MyArray(i, 0)) = 0 Then Exit For
    For j = 0 To n2  'bug 28-7-02
        a(i, j) = MyArray(i, j)
    Next j
Next i
If i > 0 Then
    ReDim MyArray(i - 1, n2) 'clear all MyArray
    For i = 0 To i - 1
        For j = 0 To n2  'bug 28-7-02
            MyArray(i, j) = a(i, j)
        Next j
    Next i
Else
   ReDim MyArray(0, n2) 'clear all MyArray
End If
End Sub

Private Sub Setting_Save()
Dim ws As Worksheet
Dim OrigCalcStatus As Integer
On Error Resume Next
OrigCalcStatus = Application.Calculation
Application.Calculation = xlCalculationManual
Set ws = ThisWorkbook.Sheets("setting")
ws.Cells(1, 1) = Me.OpB1.Value  'Both
ws.Cells(2, 1) = Me.OpB2.Value  'Sub
ws.Cells(3, 1) = Me.OpB3.Value  'Function
ws.Cells(4, 1) = Me.ComboBox1.Value 'Category
Application.Calculation = OrigCalcStatus

End Sub

Private Sub Setting_Restore()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("setting")

If ws.Cells(1, 1) <> vbNullString Then Me.OpB1.Value = ws.Cells(1, 1)
If ws.Cells(2, 1) <> vbNullString Then Me.OpB2.Value = ws.Cells(2, 1)
If ws.Cells(3, 1) <> vbNullString Then Me.OpB3.Value = ws.Cells(3, 1)
If ws.Cells(4, 1) <> vbNullString Then Me.ComboBox1.Value = ws.Cells(4, 1)

End Sub

VBA Filename frmPresentation.frm Extracted Macro

Option Explicit

Private Sub CommandButton1_Click()
'    macro_help = ThisWorkbook.VBProject.HelpFile
'    Application.Help macro_help, 1   'bug in EXCEL 2000 22-3-2002
xNumHelpShow
End Sub

Private Sub CommandButton2_Click()
  Unload Me
End Sub

Private Sub CommandButton3_Click()
  Unload Me
  FunctionBook_Clear
End Sub

Private Sub UserForm_Initialize()
Dim s$
Me.Label_ver = ThisWorkbook.BuiltinDocumentProperties(1)
Me.Label_ver = Right$(Me.Label_ver, Len(Me.Label_ver) - InStr(Me.Label_ver, " "))
If ThisWorkbook.Sheets("FunctionsBook").Range("A5") = vbNullString Then CommandButton3.Enabled = False
#If VBA7 Then
'  Code is running in the new VBA7 editor
    #If Win64 Then '  Code is running in 64-bit version of Microsoft Office
      s = " 64bit"
    #Else '  Code is running in 32-bit version of Microsoft Office
      s = " 32bit"
    #End If
  Select Case CInt(Val(Application.Version))
    Case 15: Me.LabelModified = "Using Excel 2013" & s
    Case 14: Me.LabelModified = "Using Excel 2010" & s
    Case Else: Me.LabelModified = "Using Excel Unkn" & s
  End Select
#Else
'  Code is running in VBA version 6 or earlier
  s = "Using Old Excel "
  Select Case CInt(Val(Application.Version))
    Case 12: Me.LabelModified = s & "2007"
    Case 11: Me.LabelModified = s & "2003"
    Case 10: Me.LabelModified = s & "2002"
    Case 9: Me.LabelModified = s & "2000"
    Case 8: Me.LabelModified = s & "97"
    Case Else: Me.LabelModified = s & "95"
  End Select
#End If

End Sub
VBA Filename functionHandBook.bas Extracted Macro
Option Private Module
Option Explicit

Sub Functions_HandBook()
Attribute Functions_HandBook.VB_Description = "Call the function handbook"
Attribute Functions_HandBook.VB_HelpID = 70
Attribute Functions_HandBook.VB_ProcData.VB_Invoke_Func = " \n14"
    LoadIfEmpty 'initialize Handbook
    FrmFunctionBook.Show
End Sub

Sub EditFunctionBook()
Attribute EditFunctionBook.VB_Description = "Edit Function Handbook (that's me!)"
Attribute EditFunctionBook.VB_HelpID = 4
Attribute EditFunctionBook.VB_ProcData.VB_Invoke_Func = " \n14"
    Workbooks(ThisWorkbook.Name).Sheets("FunctionsBook").ShowDataForm
End Sub

Sub MacroActivate(r, Optional CellInto)
    Dim WbName$, Msg$, MyNameWB$, ws3 As Worksheet, Formula$
    Dim FullFileName$, FullMacroName$
    If IsMissing(CellInto) Then CellInto = ActiveCell.Address
    MyNameWB = ThisWorkbook.Name
    Set ws3 = Workbooks(MyNameWB).Worksheets("FunctionsBook")
    Formula = ws3.Cells(r, 2)
    If Len(ws3.Cells(r, 8)) = 0 Then
        WbName = ThisWorkbook.Name
    Else
        WbName = ws3.Cells(r, 8) & ".xlam"
        If Not xlaIsLoaded(WbName) Then WbName = ws3.Cells(r, 8) & ".xla"
    End If
    
    If Not xlaIsLoaded(WbName) Then
        If LCase$(Left$(WbName, 1)) = "x" Then
            FullFileName = ThisWorkbook.Path & "\" & WbName
            If Len(Dir(FullFileName)) <> 0 Then Workbooks.Open FullFileName
        End If
        If Not xlaIsLoaded(WbName) Then GoSub AddinMissing
    End If
    If ws3.Cells(r, 1) = "Function" Then
        ActiveSheet.Range(CellInto).Activate
'        v = ActiveCell
        ActiveCell.FormulaLocal = "=" & WbName & "!" & Formula & "()"
'        x = True
        Application.SendKeys "+{F3}"
        'sometime calling Dialogs(xlDialogFunctionWizard) we get error
        'x = Application.Dialogs(xlDialogFunctionWizard).Show 'bug 6.1.2002
        'If x = False Then ActiveCell = v
    ElseIf ws3.Cells(r, 1) = "Sub" Then
        FullMacroName = WbName & "!" & Formula
        Application.Run FullMacroName
    End If
    Set ws3 = Nothing
Exit Sub

AddinMissing:
    Msg = "Macro: " & Formula & vbCr & "needs the add-in: " & WbName
    Msg = Msg & vbCr & "But it is not loaded. You should load it manually"
    MsgBox Msg, vbCritical
End Sub

'Function ChkIfInstalled() As Boolean
'Dim ad As AddIn ', OrigEnableEvents As Boolean
'If ThisWorkbook.IsAddin Then
'  For Each ad In Application.AddIns
'    If ad.FullName = ThisWorkbook.FullName Then GoTo FoundIt
'  Next
'  Set ad = Application.AddIns.Add(ThisWorkbook.FullName)
'FoundIt: ChkIfInstalled = ad.Installed
''  OrigEnableEvents = Application.EnableEvents
''  Application.EnableEvents = False
''  ad.Installed = True
''  Application.EnableEvents = OrigEnableEvents
'End If
'End Function

Sub XNsave(Msg$) 'Called by Workbook_BeforeSave and XNsetup
Dim OrigCalcStatus$, OrigEnableEvents As Boolean
Dim item, SavedStatus() As Boolean, i%, wbc%
AutoCheck False
ShowFormXN Msg
DoEvents
wbc = Workbooks.Count
If wbc > 0 Then
  ReDim SavedStatus(wbc - 1)
  For Each item In Workbooks: SavedStatus(i) = item.Saved: i = i + 1: Next
End If
OrigEnableEvents = Application.EnableEvents
Application.EnableEvents = False
On Error Resume Next
OrigCalcStatus = Application.Calculation
Application.Calculation = xlCalculationManual
Foglio13.Range("A24") = DIGITS_LIMIT  'Current DIGITS_LIMIT
Foglio13.Range("A25") = CurRetUnFmtStr   'Unformatted Strings
For Each item In ThisWorkbook.CustomDocumentProperties: item.Delete: Next
SetNewLabels ThisWorkbook, FixFullPath(ThisWorkbook.FullName)
ThisWorkbook.BuiltinDocumentProperties(20) = xNumTitle & ", " & Right$(ThisWorkbook.BuiltinDocumentProperties(1), Len(ThisWorkbook.BuiltinDocumentProperties(1)) - 9) 'Write this to Configuration file
Application.Calculation = xlCalculationAutomatic
  ThisWorkbook.Save
Application.Calculation = OrigCalcStatus
If wbc > 0 Then
  i = 0: For Each item In Workbooks: item.Saved = SavedStatus(i): i = i + 1: Next
End If
UnloadFormXN
AutoCheck True
Application.EnableEvents = OrigEnableEvents
End Sub

Private Sub MacroOptionUpdate_1()
Dim i%, k%, macro_file$, macro_name$, macro_desc$, macro_help$, macro_helpID
i = 2
On Error Resume Next
With ThisWorkbook.Sheets("FunctionsBook")
  Do While .Cells(i, 1) <> vbNullString
    If .Cells(i, 8) = vbNullString Then
      macro_file = ThisWorkbook.Name
    Else
     macro_file = .Cells(i, 8) & ".xlam"
     If Not xlaIsLoaded(macro_file) Then macro_file = .Cells(i, 8) & ".xla"
    End If
    macro_name = macro_file & "!" & .Cells(i, 2)
    macro_desc = .Cells(i, 4)
    If .Cells(i, 9) = vbNullString Then macro_help = XHelpFile Else macro_help = .Cells(i, 9)
    macro_helpID = .Cells(i, 10)
    GoSub Update_Macro
    i = i + 1
  Loop
End With
Exit Sub

Update_Macro:
On Error Resume Next
For k = 1 To 2
    Application.MacroOptions Macro:=macro_name, Description:=macro_desc, _
                HelpFile:=macro_help, HelpContextID:=macro_helpID
    If Err.number <> 0 Then Debug.Print Err.Description, macro_name: Err.Clear
Next
Return
End Sub

Private Sub MacroOptionUpdate_2()
Dim i%, macro_file$, macro_name$, macro_desc$, macro_help$, macro_helpID, full_macro_name$
'ripetere due volte
For i = 1 To 2
    macro_name = "XNsetup"
    macro_file = ThisWorkbook.Name
    full_macro_name = macro_file & "!" & macro_name
    macro_desc = "Set new Macro/Function Definitions, then Save Add-in."
    macro_help = XHelpFile
    macro_helpID = 1

    On Error Resume Next
    Application.MacroOptions Macro:=full_macro_name, Description:=macro_desc, _
            HelpFile:=macro_help, HelpContextID:=macro_helpID
    If Err.number <> 0 Then Debug.Print Err.Description, macro_name: Err.Clear
Next
End Sub

'Private Function AATrueName(c As Range)
'AATrueName = c.Formula
'End Function

Private Function xlaIsLoaded(xla_file) As Boolean
    On Error GoTo EH
    If Len(Workbooks(xla_file).Name) <> 0 Then xlaIsLoaded = True
EH:
End Function

Sub HelpCaller(ws As Worksheet, r)
Dim macro_help$, WbName$, macro_helpID$, Msg$, j%
If ws.Cells(r, 9) = vbNullString Then
    If ws.Cells(r, 8) = vbNullString Then
      macro_help = XHelpFile
    Else
      GoSub chk4addin
On Error Resume Next
      macro_help = Workbooks(WbName).Path & "\" & ws.Cells(r, 8) & ".chm"
      j = GetAttr(macro_help)
      If Err Then macro_help = Workbooks(WbName).Path & "\" & ws.Cells(r, 8) & ".hlp"
On Error GoTo 0
    End If
Else
    If ws.Cells(r, 8) = vbNullString Then
      macro_help = ThisWorkbook.Path & "\" & ws.Cells(r, 9)
    Else
      GoSub chk4addin
      macro_help = Workbooks(WbName).Path & "\" & ws.Cells(r, 9)
    End If
End If
macro_helpID = ws.Cells(r, 10)
If macro_helpID = vbNullString Then macro_helpID = vbStr1
Application.Help macro_help, macro_helpID
Exit Sub

chk4addin:
  WbName = ws.Cells(r, 8) & ".xla"
  If Not xlaIsLoaded(WbName) Then
      WbName = ws.Cells(r, 8) & ".xlam"
      If Not xlaIsLoaded(WbName) Then GoSub AddinMissing
  End If
Return

AddinMissing:
    Msg = "Macro: " & ws.Cells(r, 2) & vbCr & "needs the add-in: " & WbName
    Msg = Msg & vbCr & "But it is not loaded. You should load it manually"
    MsgBox Msg, vbCritical
End Sub

Sub FunctionBook_Clear()
Dim OrigCalcStatus As Integer
On Error Resume Next
OrigCalcStatus = Application.Calculation
Application.Calculation = xlCalculationManual
With ThisWorkbook
  .Sheets("FunctionCategory").UsedRange.Delete
  .Sheets("FunctionsBook").Range("A2:J2000").Delete
  With .Sheets("setting")
    .Cells(1, 1) = True  'Both
    .Cells(2, 1) = False  'Sub
    .Cells(3, 1) = False  'Function
    .Cells(4, 1) = "(all)" 'Category
    .Range("A26:Z999").Delete
  End With
End With
Application.Calculation = OrigCalcStatus
End Sub

'Private Sub LoadTable_Test()
'FullFileName = ThisWorkbook.Path & "\Xnumbers.csv"
'
'Import_Table FullFileName, "FunctionsBook", , 10, NRec
'
'End Sub
'

Sub Import_Table(FileName$, SheetName$, Optional Start, Optional ncol, Optional NRec)
'import a table file into a sheet.
'start=0 from the last row
Dim i&, j%, s, MaxCol%, rec_count&, FF%
On Error Resume Next

If IsMissing(Start) Then Start = 0  'append from the last row

If Start < 1 Then
    With ThisWorkbook.Sheets(SheetName)
        Start = .Range("A1").CurrentRegion.Rows.Count
        If .Cells(Start, 1) <> vbNullString Then Start = Start + 1
    End With
End If
''open file for count how many column
FF = FreeFile
If IsMissing(ncol) Then
    Open FileName For Input As #FF
    Line Input #FF, s
    'search for columns
    MaxCol = 0
    i = 0
    Do
        i = InStr(i + 1, s, """,")
        MaxCol = MaxCol + 1
    Loop Until i = 0
    Close #FF    ' Chiude il file.
Else
    MaxCol = ncol
End If
'open file to read data
Open FileName For Input As #FF
With ThisWorkbook.Sheets(SheetName)
    i = Start
    rec_count = 0
    Do While Not eof(1)    ' Ripete fino alla fine del file.
        For j = 1 To MaxCol
            Input #1, s
            .Cells(i, j) = s
        Next j
        i = i + 1
        rec_count = rec_count + 1
    Loop
End With
Close #FF    ' Chiude il file.
NRec = rec_count
End Sub

Function HandbookIsEmpty() As Boolean
HandbookIsEmpty = CBool(ThisWorkbook.Sheets("FunctionsBook").Range("A5") = vbNullString)
End Function

Sub LoadIfEmpty()
If ThisWorkbook.Sheets("FunctionsBook").Range("A5") <> vbNullString Then Exit Sub
If Len(Dir(ThisWorkbook.Path & "\*.csv")) = 0 Then Exit Sub
FrmInit.Show
End Sub

Sub SortHandbook()
Dim a, n&, m As Integer
With ThisWorkbook.Sheets("FunctionsBook")
    n = .Range("A1").CurrentRegion.Rows.Count
    m = .Range("A1").CurrentRegion.Columns.Count
    a = .Range(.Cells(2, 1), .Cells(n, m))
    MatrixSort a, 2
    .Range(.Cells(2, 1), .Cells(n, m)) = a
End With
End Sub
VBA Filename FrmInit.frm Extracted Macro

Option Explicit

Private Sub UserForm_Activate()
'On Error GoTo Error_Handler
Me.Caption = "XNUMBERS"
Me.Label1 = "Functions definition loading... please wait"
DoEvents
FunctionsBook_Load
Me.Label1 = "loading end"
DoEvents
Unload Me
'Exit Sub
'
'Error_Handler:
'Me.Label1 = "general failure during loading"
End Sub

Sub FunctionsBook_Load()
On Error Resume Next
Dim j&, FilePattern$, File_Name$, FullFileName$, Start%, NRec
Dim OrigCalcStatus As Integer
On Error Resume Next
OrigCalcStatus = Application.Calculation
Application.Calculation = xlCalculationManual
'this routine load all macros definition from external csv files
FilePattern = ThisWorkbook.Path & "\*.csv"
File_Name = Dir(FilePattern)  ' Recupera la prima voce.
Do While File_Name <> vbNullString
    FullFileName = ThisWorkbook.Path & "\" & File_Name
    Start = 0  'append from the last row
    Import_Table FullFileName, "FunctionsBook", Start, 10, NRec
    'Debug.Print ThisWorkbook.Path & "\" & file_name
    Me.ListBox1.AddItem File_Name & "  " & str$(NRec)
    DoEvents
    With Workbooks(ThisWorkbook.Name).Sheets("FunctionsBook")
      File_Name = Left$(File_Name, InStr(File_Name, ".") - 1)
      For j = Start To (Start + NRec)
       If .Cells(j, 10) <> vbNullString Then
        If .Cells(j, 8) = vbNullString Then .Cells(j, 8) = File_Name
       End If
      Next j
    End With
    File_Name = Dir    ' next file
Loop
'sort for type and macro name
SortHandbook
'create the category list
CreateCategory
Application.Calculation = OrigCalcStatus

End Sub


Private Sub CreateCategory()
'Workbooks(ThisWorkbook.Name).Activate
'Description: List all categories from user macro
Dim Categ(), Cat_Max, r, b, i%, j%
ReDim Categ(1 To 200)
    With Workbooks(ThisWorkbook.Name).Sheets("FunctionsBook")
        r = 2: Cat_Max = 0
        Do
            If .Cells(r, 5) <> vbNullString Then
                b = .Cells(r, 5)
                For i = 1 To Cat_Max
                    If b = Categ(i) Then
                        Exit For
                    ElseIf b < Categ(i) Then
                        'shift and get
                        For j = Cat_Max To i Step -1
                            Categ(j + 1) = Categ(j)
                        Next
                        Categ(i) = b
                        Cat_Max = Cat_Max + 1
                        Exit For
                    ElseIf b > Categ(i) Then
                        'avanza
                    End If
                Next i
                If i > Cat_Max Then
                    'bottom of the list
                        Categ(i) = b
                        Cat_Max = Cat_Max + 1
                End If
            End If
            r = r + 1
        Loop While .Cells(r, 1) <> vbNullString
    End With
    'Sheets("FunctionCategory").Select
If Cat_Max > 0 Then ReDim Preserve Categ(1 To Cat_Max)
With Workbooks(ThisWorkbook.Name).Sheets("FunctionCategory")
    .Range("A2:A200").ClearContents
    For i = 1 To Cat_Max
        .Cells(i + 1, 1) = Categ(i)
    Next
End With
End Sub
VBA Filename Initialize.bas Extracted Macro
Option Explicit

Private Sub xNum_MenuBar_Switch()
Attribute xNum_MenuBar_Switch.VB_ProcData.VB_Invoke_Func = "e\n14"
  Dim xNumButton As CommandBarButton
'  Application.ScreenUpdating = False
  CheckMemVars
  On Error Resume Next
  Application.CommandBars(MyBar).Visible = Not (Application.CommandBars(MyBar).Visible)
  If Err Then
      CommmandBar_Create
  End If
  Set xNumButton = Application.CommandBars("Standard").FindControl(Tag:=Foglio13.Range("A5"))
  If Application.CommandBars(MyBar).Visible Then
     If AppVer < 12 Then xNumButton.FaceId = 353 Else xNumButton.FaceId = 9432
  Else
     If AppVer < 12 Then xNumButton.FaceId = 983 Else xNumButton.FaceId = 9433
  End If
'  Application.ScreenUpdating = True
End Sub

Sub xNumHelpShow()
If Right$(XHelpFile, 1) = "p" Then ' it is .hlp
  Application.Help XHelpFile, 1
Else ' it is .chm
  Shell "hh " & XHelpFile, vbNormalFocus
End If
End Sub

'Sub XtutorialShow()
'    tmp = ThisWorkbook.Path & "\Xnumber*.pdf"
'    myfile = Dir(tmp)
'    If myfile = vbNullString Then
'        MsgBox "Xnumbers Tutorial not found in" & ThisWorkbook.Path & vbCr _
'        & "Download the tutorial and put it in the same directory as the Xnumbers Add-In", vbInformation
'        Exit Sub
'    End If
'    fullfilepdf = ThisWorkbook.Path & "\" & myfile
'End Sub

Sub xNumPresentationShow()
    frmPresentation.Show
End Sub

Sub SetHelpFile() 'If not already set
On Error GoTo EH
Dim n&, j%, Msg$
n = Workbooks.Count
If Len(XHelpFile) = 0 Then
  XHelpFile = ThisWorkbook.Name
#If VBA6 Or VBA7 Then
  XHelpFile = ThisWorkbook.Path & "\" & Left$(XHelpFile, InStrRev(XHelpFile, ".") - 1) & ".chm"
  ExtPgmCfgFile = Left$(XHelpFile, InStrRev(XHelpFile, ".") - 1) & "ExtPgm.ini"
  On Error Resume Next
  j = GetAttr(XHelpFile): If j = 0 Then XHelpFile = Left$(XHelpFile, InStrRev(XHelpFile, ".") - 1) & ".hlp" Else GoTo FoundHelp
  j = GetAttr(XHelpFile): If j = 0 Then XHelpFile = ThisWorkbook.Path & "\xn.chm" Else GoTo FoundHelp
  j = GetAttr(XHelpFile): If j = 0 Then XHelpFile = ThisWorkbook.Path & "\xnumbers.hlp" Else GoTo FoundHelp
  j = GetAttr(XHelpFile): If j = 0 Then XHelpFile = ThisWorkbook.Path & "\xn*.chm" Else GoTo FoundHelp
  XHelpFile = Dir(XHelpFile): If Len(XHelpFile) = 0 Then XHelpFile = ThisWorkbook.Path & "\xn*.hlp" Else GoTo AddPath
#Else
  XHelpFile = ThisWorkbook.Path & "\" & Left$(XHelpFile, InStrRev(XHelpFile, ".") - 1) & ".hlp"
  ExtPgmCfgFile = Left$(XHelpFile, InStrRev(XHelpFile, ".") - 1) & "ExtPgm.ini"
  On Error Resume Next
  j = GetAttr(XHelpFile): If j = 0 Then XHelpFile = ThisWorkbook.Path & "\xnumbers.hlp" Else GoTo FoundHelp
  j = GetAttr(XHelpFile): If j = 0 Then XHelpFile = ThisWorkbook.Path & "\xn*.hlp" Else GoTo FoundHelp
  XHelpFile = Dir(XHelpFile): If Len(XHelpFile) = 0 Then XHelpFile = ThisWorkbook.Path & "\xn*.chm" Else GoTo FoundHelp
#End If
  XHelpFile = Dir(XHelpFile)
AddPath: If Len(XHelpFile) <> 0 Then XHelpFile = ThisWorkbook.Path & "\" & XHelpFile
FoundHelp: On Error GoTo EH: If Err Then Err.Clear
  'TIPS: Installa il file di Help assegnandolo ad una qualunque macro
  If n = 0 Then
    Application.ScreenUpdating = False
#If CBool(VBA6 + VBA7) Then
    ThisWorkbook.IsAddin = False
#Else
    Workbooks.Add
#End If
  End If
  'Excel si arrabbia se non trova almeno un workbook attivo !!!
  Application.MacroOptions Macro:=ThisWorkbook.Name & "!Dummy", _
          HelpFile:=XHelpFile, HelpContextID:=0
  If n = 0 Then
#If CBool(VBA6 + VBA7) Then
    ThisWorkbook.IsAddin = True
#Else
    ActiveWorkbook.Close
#End If
    Application.ScreenUpdating = True
  End If
End If
If Not MemVarsGood Then Exit Sub
If n <> 0 Then If DoFullCalc Then xnCalculateFull
ReSetCalcStatus
Exit Sub
EH: DispErr "SetHelpFile"
End Sub

Sub xnCalculateFull()
DoFullCalc = False
If Workbooks.Count = 0 Then Exit Sub
Dim wb As Workbook, ws As Worksheet
If ThisWorkbook.BuiltinDocumentProperties(14) = 0 Then ThisWorkbook.BuiltinDocumentProperties(14) = Application.Calculation
Application.Calculation = xlCalculationManual
For Each wb In Application.Workbooks
  For Each ws In wb.Worksheets
    If ws.EnableCalculation Then
      ws.EnableCalculation = False
      ws.EnableCalculation = True
    End If
  Next ws
Next wb
If ThisWorkbook.BuiltinDocumentProperties(14) <> xlCalculationAutomatic Then _
  If Foglio13.Range("A17") Then Application.Calculate
End Sub

Sub Dummy()
Attribute Dummy.VB_ProcData.VB_Invoke_Func = " \n14"
 'questa macro non fa niente. Serve solo per il file di help
End Sub

Sub XNsetup()
Dim i%, macro_file$, macro_name$, macro_desc$, macro_helpID, k%
On Error Resume Next
If ActiveSheet.Cells(1, 1) = "Type" Then k = 2 Else k = 1
i = k
macro_file = ThisWorkbook.Name
With ActiveSheet
  Do While .Cells(i, 1) <> vbNullString
    macro_name = macro_file & "!" & .Cells(i, 2)
    macro_desc = .Cells(i, 4)
    macro_helpID = .Cells(i, 10)
    Application.MacroOptions Macro:=macro_name, Description:=macro_desc, _
      HelpFile:=XHelpFile, HelpContextID:=macro_helpID
    If Err.number <> 0 Then Debug.Print Err.Description, macro_name: Err.Clear
    i = i + 1
  Loop
End With
If i > k Then XNsave "Saving " & CStr(i - k) & " Updated Definitions..."
End Sub

Function sCStr() As String
Attribute sCStr.VB_Description = "Returns current Configuration# setting for 'Default Dbl 2 Str'\nIf # is 0 returns 'vCStr'          If 29 returns 'qCStr(29)'\nIf 15 thru 28 returns 'dCStr(Config#)'\nIf greater than 29 returns 'xCStr(Config#)'"
Attribute sCStr.VB_HelpID = 500
Attribute sCStr.VB_ProcData.VB_Invoke_Func = " \n14"
 Select Case D2StrDgts
  Case 0: sCStr = "vCStr(" & CStr(xDefDgts) & ")"
  Case 29: sCStr = "qCStr(" & CStr(xDefDgts) & ")"
  Case Is > 29: sCStr = "xCStr(" & CStr(xDefDgts) & ")"
  Case Else: sCStr = "dCStr(" & CStr(xDefDgts) & ")"
 End Select
End Function

Function GetXnVersion() As String
Attribute GetXnVersion.VB_Description = "Returns the Configured version of Xnumbers"
Attribute GetXnVersion.VB_HelpID = 500
Attribute GetXnVersion.VB_ProcData.VB_Invoke_Func = " \n14"
GetXnVersion = ThisWorkbook.BuiltinDocumentProperties(1) & " PktSz " & xBASE & " MaxDigits " & DIGITS_LIMIT
End Function

Function GetExcelAppVer#()
Attribute GetExcelAppVer.VB_Description = "Returns Excel Version of Office. 14=2010, 12=2007, 11=2003, 10=2002, 9=2000, 8=97"
Attribute GetExcelAppVer.VB_HelpID = 500
Attribute GetExcelAppVer.VB_ProcData.VB_Invoke_Func = " \n14"
GetExcelAppVer = AppVer
End Function

Function GetXnDecSep() As String
Attribute GetXnDecSep.VB_Description = "Returns the decimal separator being used in VBA"
Attribute GetXnDecSep.VB_HelpID = 505
Attribute GetXnDecSep.VB_ProcData.VB_Invoke_Func = " \n14"
GetXnDecSep = DecSep
End Function

Function GetXnArgSep() As String
Attribute GetXnArgSep.VB_Description = "Returns the argument separator being used in VBA"
Attribute GetXnArgSep.VB_HelpID = 505
Attribute GetXnArgSep.VB_ProcData.VB_Invoke_Func = " \n14"
GetXnArgSep = ArgSep
End Function

Function GetXnMilSep() As String
Attribute GetXnMilSep.VB_Description = "Returns the thousands separator being used in VBA"
Attribute GetXnMilSep.VB_HelpID = 505
Attribute GetXnMilSep.VB_ProcData.VB_Invoke_Func = " \n14"
GetXnMilSep = MilSep
End Function

Function GetXnDefCStr() As Integer
Attribute GetXnDefCStr.VB_Description = "Returns the current Configuration setting for 'Default Dbl 2 Str Digits' .\n0=vCStr, 15-28=dCStr, 29-DigitsLimit=xCStr"
Attribute GetXnDefCStr.VB_HelpID = 500
Attribute GetXnDefCStr.VB_ProcData.VB_Invoke_Func = " \n14"
GetXnDefCStr = D2StrDgts
End Function

Function GetXnDefaultDigits() As Integer
Attribute GetXnDefaultDigits.VB_Description = "Returns the Configured default DigitMax"
Attribute GetXnDefaultDigits.VB_HelpID = 500
Attribute GetXnDefaultDigits.VB_ProcData.VB_Invoke_Func = " \n14"
GetXnDefaultDigits = Digits_Def
End Function

Function GetXnSMPadj() As Integer
Attribute GetXnSMPadj.VB_Description = "Returns the Configured default number of extra digits to use for internal calculation of most of the xFunctions"
Attribute GetXnSMPadj.VB_HelpID = 500
Attribute GetXnSMPadj.VB_ProcData.VB_Invoke_Func = " \n14"
GetXnSMPadj = SMPadj
End Function

Function GetXNxAddAdj() As Integer
Attribute GetXNxAddAdj.VB_Description = "Returns the Configured default number of extra digits to use for internal calculation of xAdd (and xSub). Setting this larger ensures that numbers with larger differences in exponents get included in calculations"
Attribute GetXNxAddAdj.VB_HelpID = 500
Attribute GetXNxAddAdj.VB_ProcData.VB_Invoke_Func = " \n14"
GetXNxAddAdj = xAddAdj - xBASE + 2
End Function

Function GetXNxDivAdj() As Integer
Attribute GetXNxDivAdj.VB_Description = "Returns the Configured default number of extra digits to use for internal calculation of xDiv. Setting this to 1 ensures at least 1 extra digit for rounding"
Attribute GetXNxDivAdj.VB_HelpID = 500
Attribute GetXNxDivAdj.VB_ProcData.VB_Invoke_Func = " \n14"
GetXNxDivAdj = xDivAdj - 2 * xBASE + 2
End Function

Function GetXNxMultAdj() As Integer
Attribute GetXNxMultAdj.VB_Description = "Returns the Configured default number of extra packets (as multiples of xBASE) to use for internal calculation of xMult. '2' is required to ensure accuracy"
Attribute GetXNxMultAdj.VB_HelpID = 500
Attribute GetXNxMultAdj.VB_ProcData.VB_Invoke_Func = " \n14"
GetXNxMultAdj = xMultAdj
End Function

Function GetXnUseXroundOUT() As Boolean
Attribute GetXnUseXroundOUT.VB_Description = "Returns TRUE or FALSE,  the Configured default setting for using rounded output of extended number strings"
Attribute GetXnUseXroundOUT.VB_HelpID = 500
Attribute GetXnUseXroundOUT.VB_ProcData.VB_Invoke_Func = " \n14"
GetXnUseXroundOUT = UseXroundOUT
End Function

Function GetXnUseXroundIN() As Boolean
Attribute GetXnUseXroundIN.VB_Description = "Returns TRUE or FALSE,  the Configured default setting for using rounded input\n(IF extended number input strings are larger than DigitMax)"
Attribute GetXnUseXroundIN.VB_HelpID = 500
Attribute GetXnUseXroundIN.VB_ProcData.VB_Invoke_Func = " \n14"
GetXnUseXroundIN = UseXroundIN
End Function

Function GetXnTrailZeros() As Integer
Attribute GetXnTrailZeros.VB_Description = "Returns the Configured default maximum number of trailing zeros that get returned with integers.\nIf more exist extended numbers are returned in scientific notation. To display more zeros than DigitMax use the iFmt function"
Attribute GetXnTrailZeros.VB_HelpID = 500
Attribute GetXnTrailZeros.VB_ProcData.VB_Invoke_Func = " \n14"
GetXnTrailZeros = TrailZeros
End Function

Function GetXnLeadZeros() As Integer
Attribute GetXnLeadZeros.VB_Description = "Returns the Configured default maximum number of leading zeros that get returned with decimal numbers between -1 and 1\nIf more exist extended numbers are returned in scientific notation. To display more zeros than DigitMax use the xFmt function"
Attribute GetXnLeadZeros.VB_HelpID = 500
Attribute GetXnLeadZeros.VB_ProcData.VB_Invoke_Func = " \n14"
GetXnLeadZeros = LeadZeros
End Function

Function GetxBASE() As Integer
Attribute GetxBASE.VB_Description = "Returns xBASE, the number of digits per packet"
Attribute GetxBASE.VB_HelpID = 500
Attribute GetxBASE.VB_ProcData.VB_Invoke_Func = " \n14"
GetxBASE = xBASE
End Function

Function GetXnCaseSen() As Boolean
Attribute GetXnCaseSen.VB_Description = "Returns TRUE or FALSE,  the Configured default setting for using\nCase Sensitive Variable Names for formula strings and labels"
Attribute GetXnCaseSen.VB_HelpID = 500
Attribute GetXnCaseSen.VB_ProcData.VB_Invoke_Func = " \n14"
GetXnCaseSen = CaseSen
End Function

Function GetXnRetUnFmtStr() As Boolean
GetXnRetUnFmtStr = CurRetUnFmtStr
End Function

Function GetDigitsLimit() As Long
Attribute GetDigitsLimit.VB_Description = "Returns DigitsLimit, the largest allowed DgtMax"
Attribute GetDigitsLimit.VB_HelpID = 500
Attribute GetDigitsLimit.VB_ProcData.VB_Invoke_Func = " \n14"
GetDigitsLimit = DIGITS_LIMIT
End Function

Function SetXnRetUnFmtStr(NewRetUnFmtStr) As Integer
fixUnformattedStrings NewRetUnFmtStr
End Function

Function SetDigitsLimit(ByVal NewDigitsLimit&) As Integer
'If Calculation is set to Manual, you need to hit F9 twice
'Application.Volatile
SetNewDigitsLimit NewDigitsLimit
End Function

Function SetXnDefCStr(NewDefCStrDgts) As Integer
If NewDefCStrDgts > DIGITS_LIMIT Then NewDefCStrDgts = DIGITS_LIMIT
If NewDefCStrDgts < 15 Then
  D2StrDgts = 0:  CD2xNdgts = 28 '(28 \ xBASE) * xBASE
  If NewDefCStrDgts > 0 Then xDefDgts = NewDefCStrDgts Else xDefDgts = 15
Else
  D2StrDgts = NewDefCStrDgts: xDefDgts = D2StrDgts
  If xDefDgts > 28 Then CD2xNdgts = 28 Else CD2xNdgts = xDefDgts
End If
End Function

Function SetXnDefaultDigits(NewDefDig) As Integer
If NewDefDig < 1 Or NewDefDig > DIGITS_LIMIT Then Exit Function
Digits_Def = NewDefDig
End Function

Function SetXNxAddAdj(NEWxAddAdj) As Integer
If NEWxAddAdj < 0 Or NEWxAddAdj > DIGITS_LIMIT Then Exit Function
xAddAdj = NEWxAddAdj + xBASE - 2
End Function

Function SetXNxDivAdj(NEWxDivAdj) As Integer
If NEWxDivAdj < 0 Or NEWxDivAdj > DIGITS_LIMIT Then Exit Function
xDivAdj = NEWxDivAdj + 2 * xBASE - 2
End Function

Function SetXNxMultAdj(NEWxMultAdj) As Integer
If NEWxMultAdj < 0 Or NEWxMultAdj > xDgtLim Then Exit Function
xMultAdj = NEWxMultAdj
End Function

Function SetXnUseXroundOUT(NewUseXroundOUT) As Integer
UseXroundOUT = CBool(NewUseXroundOUT)
End Function

Function SetXnUseXroundIN(NewUseXroundIN) As Integer
UseXroundIN = CBool(NewUseXroundIN)
End Function

Function SetXnTrailZeros(NewTrailZeros) As Integer
If NewTrailZeros < 0 Or NewTrailZeros > DIGITS_LIMIT Then Exit Function
TrailZeros = NewTrailZeros
End Function

Function SetXnLeadZeros(NewLeadZeros) As Integer
If NewLeadZeros < 0 Or NewLeadZeros > DIGITS_LIMIT Then Exit Function
LeadZeros = NewLeadZeros
End Function

Function SetXnSMPadj(NewSMPadj) As Integer
If NewSMPadj < 0 Or NewSMPadj > DIGITS_LIMIT Then Exit Function
SMPadj = NewSMPadj
End Function

Function SetXnCaseSen(NewCaseSen) As Integer
CaseSen = CBool(NewCaseSen)
End Function

Function GetXnConfigStatus()
Attribute GetXnConfigStatus.VB_Description = "2 x 19 array function returns all 18 Configuration settings, with labels as their Public variable names (listed in the XnumbPrivate module), plus DigitsLimit"
Attribute GetXnConfigStatus.VB_HelpID = 500
Attribute GetXnConfigStatus.VB_ProcData.VB_Invoke_Func = " \n14"
Dim c(1 To 21, 1 To 2)
c(1, 2) = Digits_Def:               c(1, 1) = "Digits_Def"
c(2, 2) = UseXroundOUT:             c(2, 1) = "UseXroundOUT"
c(3, 2) = UseXroundIN:              c(3, 1) = "UseXroundIN"
c(4, 2) = LeadZeros:                c(4, 1) = "LeadZeros"
c(5, 2) = TrailZeros:               c(5, 1) = "TrailZeros"
c(6, 2) = CplxChar:                 c(6, 1) = "CplxChar"
                                    c(7, 1) = "DefCStrDgts"
If D2StrDgts = 0 Then c(7, 2) = 0 Else c(7, 2) = xDefDgts
c(8, 2) = Foglio13.Range("A16"):    c(8, 1) = "LoadFunBookAtStart"
                                    c(9, 1) = "RegDecSep"
Select Case AskSwDecSep
Case 0: c(9, 2) = "Ignore"
Case 1: c(9, 2) = "Switch"
Case 2: c(9, 2) = "Ask"
End Select
c(10, 2) = Foglio13.Range("A17"):   c(10, 1) = "CalcOnSet"
c(11, 2) = SMPadj:                  c(11, 1) = "SimMachPrecAdj"
c(12, 2) = xAddAdj - xBASE + 2:     c(12, 1) = "xAddAdj"
c(13, 2) = xMultAdj:                c(13, 1) = "xMultAdj"
c(14, 2) = UseTinyFlg:              c(14, 1) = "UseTinyFlg"
c(15, 2) = MultiTiny:               c(15, 1) = "MultiTiny"
c(16, 2) = StdTiny:                 c(16, 1) = "StdTiny"
c(17, 2) = DIGITS_LIMIT:            c(17, 1) = "DIGITS_LIMIT"
c(18, 2) = CaseSen:                 c(18, 1) = "CaseSen"
c(19, 2) = xDivAdj - 2 * xBASE + 2: c(19, 1) = "xDivAdj"
c(20, 2) = CurRetUnFmtStr:          c(20, 1) = "RetUnFmtStr"
c(21, 2) = xBASE:                   c(21, 1) = "PacketSize"
GetXnConfigStatus = PasteVector_(c)
End Function

Function SIACF(RetVal, SimRows, SimCols)
'Set Invalid Application Caller Flag
xNumInvAppCallFlg = True
xNumACRows = SimRows
xNumACCols = SimCols
SIACF = RetVal
End Function

Function CIACF(RetVal)
'Clear Invalid Application Caller Flag
xNumInvAppCallFlg = False
CIACF = RetVal
End Function

Sub ReDoCapitalization()
' ReSet the correct Capitalization for all the functions
If ActiveCell Is Nothing Then Exit Sub
Dim Row&, f$, v
Dim OrigCalcStatus%, OrigSavedStatus As Boolean, OrigScreenStatus As Boolean
OrigScreenStatus = Application.ScreenUpdating
OrigCalcStatus = Application.Calculation
OrigSavedStatus = ActiveWorkbook.Saved
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
If ActiveCell.HasFormula Then
  f = ActiveCell.Formula
ElseIf Not IsEmpty(ActiveCell) Then
  v = ActiveCell.Value
End If
Row = 2
Do Until IsEmpty(Foglio11.Cells(Row, 2))
  ActiveCell.Formula = "=" & Foglio11.Cells(Row, 2).Value
  Row = Row + 1
Loop
If Not IsEmpty(v) Then
  ActiveCell.Value = v
  If VarType(v) = vbString Then If VarType(ActiveCell.Value) <> vbString Then _
    ActiveCell.Value = "'" & v: If ActiveCell.NumberFormatLocal = "General" Then ActiveCell.ClearFormats
ElseIf f <> vbNullString Then
  ActiveCell.Formula = f
Else
  ActiveCell.ClearContents
End If
Application.Calculation = OrigCalcStatus
ActiveWorkbook.Saved = OrigSavedStatus
Application.ScreenUpdating = OrigScreenStatus
End Sub
VBA Filename SpecialFunctions.bas Extracted Macro
'**********************************************************
'Module for 32bit-High Precision Special Functions
' rev. 1.2 2-11-06
'**********************************************************
Option Explicit
'#Compile Time Constants - Special Functions Module only
#Const HperGeomTesting = False

'The following "xq" functions allow use of VBA's 96 bit Variant Decimal data type
'by returning 29 digit Strings to the spreadsheet.

Function xqAdd(x, y) As String: xqAdd = CDec_(x) + CDec_(y): End Function
Attribute xqAdd.VB_Description = "Performs addition in quadruple precision up to 29 digits:  xqAdd(x, y) = x + y"
Attribute xqAdd.VB_HelpID = 8
Attribute xqAdd.VB_ProcData.VB_Invoke_Func = " \n14"
Function xqSub(x, y) As String: xqSub = CDec_(x) - CDec_(y): End Function
Attribute xqSub.VB_Description = "Performs subtraction in quadruple precision up to 29 digits:  xqSub(x, y) = x - y"
Attribute xqSub.VB_HelpID = 9
Attribute xqSub.VB_ProcData.VB_Invoke_Func = " \n14"
Function xqMult(x, y) As String: xqMult = CDec_(x) * CDec_(y): End Function
Attribute xqMult.VB_Description = "Performs multiplication in quadruple precision up to 29 digits:  xqMult(x, y) = x * y"
Attribute xqMult.VB_HelpID = 10
Attribute xqMult.VB_ProcData.VB_Invoke_Func = " \n14"
Function xqDiv(x, y) As String: xqDiv = CDec_(x) / CDec_(y): End Function
Attribute xqDiv.VB_Description = "Performs division in quadruple precision up to 29 digits:  xqDiv(x, y) = x / y"
Attribute xqDiv.VB_HelpID = 11
Attribute xqDiv.VB_ProcData.VB_Invoke_Func = " \n14"
Function xqAbs(x) As String: xqAbs = Abs(CDec_(x)): End Function
Attribute xqAbs.VB_Description = "Returns the absolute value in quadruple precision up to 29 digits: xqAbs(x)= |x|"
Attribute xqAbs.VB_HelpID = 16
Attribute xqAbs.VB_ProcData.VB_Invoke_Func = " \n14"
Function xqInt(x) As String: xqInt = Int(CDec_(x)): End Function
Attribute xqInt.VB_Description = "Returns the 'integer' of a number 'x' as the greatest integer less than or equal to 'x'\nReturns up to 29 digits in quadruple precision"
Attribute xqInt.VB_HelpID = 40
Attribute xqInt.VB_ProcData.VB_Invoke_Func = " \n14"
Function xqDec(x) As String: xqDec = qDec(CDec_(x)): End Function
Attribute xqDec.VB_Description = "Returns the decimal part of a number in quadruple precision up to 29 digits"
Attribute xqDec.VB_HelpID = 73
Attribute xqDec.VB_ProcData.VB_Invoke_Func = " \n14"
Function xqRound(x, Optional DecDgts& = 0) As String: xqRound = Round(CDec_(x), DecDgts): End Function
Attribute xqRound.VB_Description = "Rounding of numbers in quadruple precision up to 29 digits (default DecDgts = 0)"
Attribute xqRound.VB_HelpID = 47
Attribute xqRound.VB_ProcData.VB_Invoke_Func = " \n14"

Function xqERF(x) As String: xqERF = qERF(CDec_(x)): End Function
Attribute xqERF.VB_Description = "Integral of Gauss' standard error function\nThe same as Excels ERF( ) function, but with quadruple precision"
Attribute xqERF.VB_HelpID = 204
Attribute xqERF.VB_ProcData.VB_Invoke_Func = " \n14"
Function xqERFc(x) As String: xqERFc = qERFc(CDec_(x)): End Function
Attribute xqERFc.VB_Description = "Complementary of the standard error function\nThe same as Excels ERFC( ) function, but with quadruple precision"
Attribute xqERFc.VB_HelpID = 204
Attribute xqERFc.VB_ProcData.VB_Invoke_Func = " \n14"
Function xqSqr(x) As String: xqSqr = qSqr(CDec_(x)): End Function
Attribute xqSqr.VB_Description = "Returns the square root of a number using quadruple precision (up to 29 digits)"
Attribute xqSqr.VB_HelpID = 14
Attribute xqSqr.VB_ProcData.VB_Invoke_Func = " \n14"
Function xqRoot(x, n): xqRoot = CvD2s(qRoot(CDec_(x), n)): End Function
Attribute xqRoot.VB_Description = "the n-th root of a number in quadruple precision (returns up to 29 digits).\nWhen x is negative, assumes numerator of n is odd (returns real number)"
Attribute xqRoot.VB_HelpID = 15
Attribute xqRoot.VB_ProcData.VB_Invoke_Func = " \n14"
Function xqPow(x, n): xqPow = CvD2s(qPow(CDec_(x), n)): End Function
Attribute xqPow.VB_Description = "Raises a number to power n. xqPow(x, n) = x^n\nWhen n is not an integer and x is negative, assumes denominator of n is odd.\nReturns up to 29 digits in quadruple precision"
Attribute xqPow.VB_HelpID = 13
Attribute xqPow.VB_ProcData.VB_Invoke_Func = " \n14"
Function xqAtan2(y, x) As String: xqAtan2 = qAtan2(CDec_(y), CDec_(x)): End Function
Attribute xqAtan2.VB_Description = "Arctangent returns angle in radians between -Pi and +Pi\nusing quadruple precision (up to 29 digits)\nxAtan2(y,x) equals ATAN(y/x), except that x can equal zero"
Attribute xqAtan2.VB_HelpID = 32
Attribute xqAtan2.VB_ProcData.VB_Invoke_Func = " \n14"
Function xqCosh(x): xqCosh = CvD2s(qCosh(CDec_(x))): End Function
Attribute xqCosh.VB_Description = "quadruple precision Hyperbolic Cosine returns up to 29 digits"
Attribute xqCosh.VB_HelpID = 120
Attribute xqCosh.VB_ProcData.VB_Invoke_Func = " \n14"
Function xqSinh(x): xqSinh = CvD2s(qSinh(CDec_(x))): End Function
Attribute xqSinh.VB_Description = "quadruple precision Hyperbolic Sine returns up to 29 digits"
Attribute xqSinh.VB_HelpID = 119
Attribute xqSinh.VB_ProcData.VB_Invoke_Func = " \n14"
Function xqTanh(x): xqTanh = CvD2s(qTanh(CDec_(x))): End Function
Attribute xqTanh.VB_Description = "quadruple precision Hyperbolic Tangent returns up to 29 digits"
Attribute xqTanh.VB_HelpID = 121
Attribute xqTanh.VB_ProcData.VB_Invoke_Func = " \n14"
Function xqAcosh(x) As String: xqAcosh = qAcosh(CDec_(x)): End Function
Attribute xqAcosh.VB_Description = "quadruple precision Inverse Hyperbolic Cosine returns up to 29 digits"
Attribute xqAcosh.VB_HelpID = 123
Attribute xqAcosh.VB_ProcData.VB_Invoke_Func = " \n14"
Function xqAsinh(x) As String: xqAsinh = qAsinh(CDec_(x)): End Function
Attribute xqAsinh.VB_Description = "quadruple precision Inverse Hyperbolic Sine returns up to 29 digits"
Attribute xqAsinh.VB_HelpID = 124
Attribute xqAsinh.VB_ProcData.VB_Invoke_Func = " \n14"
Function xqAtanh(x) As String: xqAtanh = qAtanh(CDec_(x)): End Function
Attribute xqAtanh.VB_Description = "quadruple precision Inverse Hyperbolic Tangent returns up to 29 digits"
Attribute xqAtanh.VB_HelpID = 122
Attribute xqAtanh.VB_ProcData.VB_Invoke_Func = " \n14"
Function xqAsin(x) As String: xqAsin = qAsin(CDec_(x)): End Function
Attribute xqAsin.VB_Description = "Returns the arcsin or inv-sin of x : xqAsin(x) = arcsin(x)\nin quadruple precision up to 29 digits"
Attribute xqAsin.VB_HelpID = 30
Attribute xqAsin.VB_ProcData.VB_Invoke_Func = " \n14"
Function xqAcos(x) As String: xqAcos = qAcos(CDec_(x)): End Function
Attribute xqAcos.VB_Description = "Returns the arccos or inv-cos of x:  xqAcos(x) = arccos(x)\nusing quadruple precision (up to 29 digits)"
Attribute xqAcos.VB_HelpID = 31
Attribute xqAcos.VB_ProcData.VB_Invoke_Func = " \n14"
Function xqAtan(x) As String: xqAtan = qAtan(CDec_(x)): End Function
Attribute xqAtan.VB_Description = "quadruple precision Arctangent returns up to 29 digits"
Attribute xqAtan.VB_HelpID = 32
Attribute xqAtan.VB_ProcData.VB_Invoke_Func = " \n14"
Function xqLog(x, Optional BASEn) As String: xqLog = qLog(x, BASEn): End Function
Attribute xqLog.VB_Description = "Log to any Base with quadruple precision returns up to 29 digits"
Attribute xqLog.VB_HelpID = 20
Attribute xqLog.VB_ProcData.VB_Invoke_Func = " \n14"
Function xqLn(x) As String: xqLn = qLn(x): End Function
Attribute xqLn.VB_Description = "Natural Log x with quadruple precision returns up to 29 digits"
Attribute xqLn.VB_HelpID = 19
Attribute xqLn.VB_ProcData.VB_Invoke_Func = " \n14"
Function xqExp(x): xqExp = CvD2s(qExp(CDec_(x))): End Function
Attribute xqExp.VB_Description = "e^x with quadruple precision returns up to 29 digits"
Attribute xqExp.VB_HelpID = 21
Attribute xqExp.VB_ProcData.VB_Invoke_Func = " \n14"
Function xqExpa(x, a): xqExpa = CvD2s(qExpa(CDec_(x), a)): End Function
Attribute xqExpa.VB_Description = "compute a^x with quadruple precision returns up to 29 digits"
Attribute xqExpa.VB_HelpID = 22
Attribute xqExpa.VB_ProcData.VB_Invoke_Func = " \n14"
Function xqAnglec(x) As String: xqAnglec = qPi2_ - CDec_(x): End Function
Attribute xqAnglec.VB_Description = "Complement of the right angle with quadruple precision returns up to 29 digits:\nxqAngleC(x) = Pi/2 - x"
Attribute xqAnglec.VB_HelpID = 63
Attribute xqAnglec.VB_ProcData.VB_Invoke_Func = " \n14"
Function xqTan(x) As String
Attribute xqTan.VB_Description = "Returns the tangent of angle:  xqTan(x) = tan(x)\nusing quadruple precision (up to 29 digits)"
Attribute xqTan.VB_HelpID = 29
Attribute xqTan.VB_ProcData.VB_Invoke_Func = " \n14"
If Abs(CDbl_(x)) > 10000000000# Then xqTan = qTan(CDec(xAdj2Pi(x, 29))) Else xqTan = qTan(CDec_(x))
End Function
Function xqSin(x) As String
Attribute xqSin.VB_Description = "Sine x with quadruple precision returns up to 29 digits"
Attribute xqSin.VB_HelpID = 27
Attribute xqSin.VB_ProcData.VB_Invoke_Func = " \n14"
If Abs(CDbl_(x)) > 10000000000# Then xqSin = qSin(CDec(xAdj2Pi(x, 29))) Else xqSin = qSin(CDec_(x))
End Function
Function xqCos(x) As String
Attribute xqCos.VB_Description = "Cosine x with quadruple precision returns up to 29 digits"
Attribute xqCos.VB_HelpID = 28
Attribute xqCos.VB_ProcData.VB_Invoke_Func = " \n14"
If Abs(CDbl_(x)) > 10000000000# Then xqCos = qCos(CDec(xAdj2Pi(x, 29))) Else xqCos = qCos(CDec_(x))
End Function
Function xqPow2(n) As String
Attribute xqPow2.VB_Description = "Integer Powers of 2, xqPow2(n) = 2^n\nRetrieves Stored up to 29 digits in quadruple precision"
Attribute xqPow2.VB_HelpID = 13
Attribute xqPow2.VB_ProcData.VB_Invoke_Func = " \n14"
If n <> Int(n) Then xqPow2 = xqExpa(n, 2): Exit Function
If n < 0 Then
  If n < -1075 Then GoTo UsexPow2
  If n < -1023 Then xqPow2 = Pof2M(Abs(n)) & "E" & Pof2E(Abs(n)): Exit Function
  If n > -29 Then xqPow2 = 1 / (Pof2M(Abs(n)) * 10 ^ Pof2E(Abs(n))): Exit Function
  xqPow2 = xInv(Pof2M(Abs(n)) & "E" & Pof2E(Abs(n)), 29): Exit Function
End If
If n < 1024 Then
  If Pof2E(n) > 0 Then xqPow2 = Pof2M(n) & "E+" & Pof2E(n) Else xqPow2 = Pof2M(n)
  Exit Function
End If
UsexPow2: xqPow2 = xPow2Int(n, 29)
End Function

Sub error_function(x, y, yC)
'returns the integral of Gauss' standard error function
'10.11.06
Dim U, A0, a1, a2, B0, b1, b2, g, t, p, s, i, f1, f2, d
Const maxloop = 200
Const Tiny# = Ten_15
U = Abs(x)   '10.11.06 fix bug for x<<0. Thanks to Michael Hautus
If U <= 2 Then
    GoSub erf_low
Else
    GoSub erf_high
End If

Exit Sub
'----------------------------
erf_low:
t = 2 * U * U: p = 1: s = 1
For i = 3 To maxloop Step 2
    p = p * t / i
    s = s + p
    If p < Tiny Then Exit For
Next
y = 2 * s * U * Exp(-U * U) / SqPi_
If x < 0 Then y = -y
yC = 1 - y
Return

erf_high:
A0 = 1: B0 = 0
a1 = 0: b1 = 1: f1 = 0
For i = 1 To maxloop
    g = 2 - (i Mod 2)
    a2 = g * U * a1 + i * A0
    b2 = g * U * b1 + i * B0
    f2 = a2 / b2
    d = Abs(f2 - f1)
    If d < Tiny Then Exit For
    A0 = a1 / b2
    B0 = b1 / b2
    a1 = a2 / b2
    b1 = 1
    f1 = f2
Next
yC = 2 * Exp(-U * U) / (2 * U + f2) / SqPi_
y = 1 - yC
If x < 0 Then
    y = -y
    yC = 2 - yC
End If
Return
End Sub

Function errFun(x)
Attribute errFun.VB_Description = "error function ERF(x)"
Attribute errFun.VB_HelpID = 204
Attribute errFun.VB_ProcData.VB_Invoke_Func = " \n14"
'returns the integral of Gauss' standard error function
Dim y#, yC#
Call error_function(x, y, yC)
errFun = y
End Function

Function errFunC(x)
Attribute errFunC.VB_Description = "complementary of error function ERFC(x)"
Attribute errFunC.VB_HelpID = 204
Attribute errFunC.VB_ProcData.VB_Invoke_Func = " \n14"
'returns the complementary of the standard error function
Dim y#, yC#
Call error_function(x, y, yC)
errFunC = yC
End Function

Function Exp_Integr(x)
Attribute Exp_Integr.VB_Description = "Exponential integral Ei(x) for x >0"
Attribute Exp_Integr.VB_HelpID = 205
Attribute Exp_Integr.VB_ProcData.VB_Invoke_Func = " \n14"
'Computes the exponential integral Ei(x) for any x<>0.
'Parameters: EPS is the relative error, or absolute error near the zero
'EULER is Euler's constant ; MAXIT is the maximum number of iterations allowed; FPMIN
'is a number near the smallest representable oating-point number.
'3.3.2006. This version accept also negative argument. Thanks to Hans Gunter
'Def. Ei(-x) = E1(x)  for x>0  (ref. Abramowitz and Stegun)
Const EPS# = 0.000000000000001, maxit = 100, FPMIN# = 1E-30
Dim Fact#, prev#, Sum#, Term#, x1#, k%
On Error GoTo Error_Handler
x1 = CDbl_(x)
If Abs(x1) < FPMIN Then
      Exp_Integr = Log(Abs(x1)) + dEu_
ElseIf x1 > 0 And Abs(x1) <= -Log(EPS) Or x1 > -12 Then 'Use power series.
     Sum = 0#
     Fact = 1#
     For k = 1 To maxit
        Fact = Fact * x1 / k
        Term = Fact / k
        Sum = Sum + Term
        If Abs(Term) < EPS * Abs(Sum) Then Exit For
    Next
    Exp_Integr = Sum + Log(Abs(x1)) + dEu_
Else 'Use asymptotic series.
    Sum = 0# 'Start with second term.
    Term = 1#
    For k = 1 To maxit
      prev = Term
      Term = Term * k / x1
      If Abs(Term) < EPS Then Exit For
      If Abs(Term) < Abs(prev) Or k < 10 Then
         Sum = Sum + Term 'Still converging: add new term.
      Else
         Sum = Sum - prev 'Diverging: subtract previous term and exit.
         Exit For
      End If
    Next
    Exp_Integr = Exp(x1) * (1# + Sum) / x1
End If
Exit Function
Error_Handler: Exp_Integr = "?"
End Function

Function Expn_Integr(x_, n_)
Attribute Expn_Integr.VB_Description = "Exponential integral En(x)"
Attribute Expn_Integr.VB_HelpID = 206
Attribute Expn_Integr.VB_ProcData.VB_Invoke_Func = " \n14"
'Evaluates the exponential integral En(x).
'Parameters: MAXIT is the maximum allowed number of iterations; EPS is the desired rel-
'ative error, not smaller than the machine precision; FPMIN is a number near the smallest
'representable foating-point number; EULER is Euler's constant .
Const maxit = 100, EPS# = 0.000000000000001, FPMIN# = 1E-30
Dim x#, n#, nm1#, a#, b#, c#, d#, h#, i%, del#, Fact#, psi#, ii#
x = CDbl_(x_)
n = CDbl_(n_)
nm1 = n - 1
If (n < 0 Or x < 0 Or (x = 0 And (n = 0 Or n = 1))) Then
   Exit Function
ElseIf n = 0 Then 'Special case.
   Expn_Integr = Exp(-x) / x
ElseIf x = 0 Then 'Another special case.
   Expn_Integr = 1# / nm1
ElseIf x > 1 Then 'Lentz's algorithm .
   b = x + n
   c = 1# / FPMIN
   d = 1# / b
   h = d
   For i = 1 To maxit
      a = -i * (nm1 + i)
      b = b + 2#
      d = 1# / (a * d + b) 'Denominators cannot be zero.
      c = b + a / c
      del = c * d
      h = h * del
      If Abs(del - 1#) < EPS Then
         Expn_Integr = h * Exp(-x)
         Exit Function
      End If
   Next
   Expn_Integr = "?"
    Exit Function 'continued fraction failed '
Else 'Evaluate series.
   If nm1 <> 0 Then 'Set rst term.
      Expn_Integr = 1# / nm1
   Else
      Expn_Integr = -Log(x) - dEu_
   End If
   Fact = 1#
   For i = 1 To maxit
      Fact = -Fact * x / i
      If i <> nm1 Then
         del = -Fact / (i - nm1)
      Else
         psi = -dEu_ '.
         For ii = 1 To nm1
            psi = psi + 1# / ii
         Next
         del = Fact * (-Log(x) + psi)
      End If
      Expn_Integr = Expn_Integr + del
      If Abs(del) < Abs(Expn_Integr) * EPS Then Exit Function
   Next
   Expn_Integr = "?"
   Exit Function 'series failed in'
End If

End Function

Function BesselJx(x, Optional n)
Attribute BesselJx.VB_Description = "Bessel function of 1st kind, order n: Jn(x)"
Attribute BesselJx.VB_HelpID = 215
Attribute BesselJx.VB_ProcData.VB_Invoke_Func = " \n14"
'Bessel function first kind, order n, Jn(x)
Dim n1#, BJ0#, DJ0#, BJ1#, DJ1#, BY0#, DY0#, BY1#, DY1#
Dim NM#, BJ#(), dj#(), by#(), dY#()
If IsMissing(n) Then n1 = 0 Else n1 = CDbl_(n)
If n1 <= 1 Then
    Call JY01A(x, BJ0, DJ0, BJ1, DJ1, BY0, DY0, BY1, DY1)
    If n1 = 0 Then BesselJx = BJ0 Else BesselJx = BJ1
Else
    Call JYNA(n1, x, NM, BJ, dj, by, dY)
    BesselJx = BJ(n1)
End If
End Function

Function BesselYx(x, Optional n)
Attribute BesselYx.VB_Description = "Bessel function of 2nd kind, order n: Yn(x)"
Attribute BesselYx.VB_HelpID = 215
Attribute BesselYx.VB_ProcData.VB_Invoke_Func = " \n14"
'Bessel function second kind, order n, Yn(x)
Dim n1#, BJ0#, DJ0#, BJ1#, DJ1#, BY0#, DY0#, BY1#, DY1#
Dim NM#, BJ#(), dj#(), by#(), dY#()
If IsMissing(n) Then n1 = 0 Else n1 = CDbl_(n)
If n1 <= 1 Then
    Call JY01A(x, BJ0, DJ0, BJ1, DJ1, BY0, DY0, BY1, DY1)
    If n1 = 0 Then BesselYx = BY0 Else BesselYx = BY1
Else
    Call JYNA(n1, x, NM, BJ, dj, by, dY)
    BesselYx = by(n1)
End If
End Function

Function BesseldJ(x, Optional n)
Attribute BesseldJ.VB_Description = "First derivative of Bessel functions of 1st kind, order n: J'n(x)"
Attribute BesseldJ.VB_HelpID = 215
Attribute BesseldJ.VB_ProcData.VB_Invoke_Func = " \n14"
'First Derivative of Bessel functions first kind, order n, J'n(x)
Dim x1#, n1#, BJ0#, DJ0#, BJ1#, DJ1#, BY0#, DY0#, BY1#, DY1#
Dim NM#, BJ#(), dj#(), by#(), dY#()
If IsMissing(n) Then n1 = 0 Else n1 = CDbl_(n)
x1 = CDbl_(x)
If n1 <= 1 Then
    Call JY01A(x1, BJ0, DJ0, BJ1, DJ1, BY0, DY0, BY1, DY1)
    If n1 = 0 Then BesseldJ = DJ0 Else BesseldJ = DJ1
Else
    Call JYNA(n1, x1, NM, BJ, dj, by, dY)
    BesseldJ = dj(n1)
End If
End Function

Function BesseldY(x, Optional n)
Attribute BesseldY.VB_Description = "First derivative of Bessel functions of 2nd kind, order n: Y'n(x)"
Attribute BesseldY.VB_HelpID = 215
Attribute BesseldY.VB_ProcData.VB_Invoke_Func = " \n14"
'First Derivative of Bessel functions second kind, order n, Y'n(x)
Dim x1#, n1#, BJ0#, DJ0#, BJ1#, DJ1#, BY0#, DY0#, BY1#, DY1#
Dim NM#, BJ#(), dj#(), by#(), dY#()
If IsMissing(n) Then n1 = 0 Else n1 = CDbl_(n)
x1 = CDbl_(x)
If n1 <= 1 Then
    Call JY01A(x1, BJ0, DJ0, BJ1, DJ1, BY0, DY0, BY1, DY1)
    If n1 = 0 Then BesseldY = DY0 Else BesseldY = DY1
Else
    Call JYNA(n1, x1, NM, BJ, dj, by, dY)
    BesseldY = dY(n1)
End If
End Function

Function BesselIx(x, Optional n)
Attribute BesselIx.VB_Description = "Modified Bessel function of 1st kind, order n: In(x)"
Attribute BesselIx.VB_HelpID = 215
Attribute BesselIx.VB_ProcData.VB_Invoke_Func = " \n14"
'modified Bessel function 1\xb0 kind, order n, In(x)
Dim n1#, BI0#, DI0#, BI1#, DI1#, BK0#, DK0#, BK1#, DK1#
Dim NM#, bi#(), Di#(), BK#(), DK#()
If IsMissing(n) Then n1 = 0 Else n1 = CDbl_(n)
If n1 <= 1 Then
    Call IK01A(x, BI0, DI0, BI1, DI1, BK0, DK0, BK1, DK1)
    If n1 = 0 Then BesselIx = BI0 Else BesselIx = BI1
Else
    Call IKNA(n1, x, NM, bi, Di, BK, DK)
    BesselIx = bi(n1)
End If
End Function

Function BesseldI(x, Optional n)
Attribute BesseldI.VB_Description = "First derivative of mod. Bessel functions of 1st kind, order n: I'n(x)"
Attribute BesseldI.VB_HelpID = 215
Attribute BesseldI.VB_ProcData.VB_Invoke_Func = " \n14"
'derivative modified Bessel function 1\xb0 kind, order n, In(x)
Dim x1#, n1#, BI0#, DI0#, BI1#, DI1#, BK0#, DK0#, BK1#, DK1#
Dim NM#, bi#(), Di#(), BK#(), DK#()
If IsMissing(n) Then n1 = 0 Else n1 = CDbl_(n)
x1 = CDbl_(x)
If n1 <= 1 Then
    Call IK01A(x1, BI0, DI0, BI1, DI1, BK0, DK0, BK1, DK1)
    If n1 = 0 Then BesseldI = DI0 Else BesseldI = DI1
Else
    Call IKNA(n1, x1, NM, bi, Di, BK, DK)
    BesseldI = Di(n1)
End If
End Function

Function BesselKx(x, Optional n)
Attribute BesselKx.VB_Description = "Modified Bessel function of 2nd kind, order n: Kn(x)"
Attribute BesselKx.VB_HelpID = 215
Attribute BesselKx.VB_ProcData.VB_Invoke_Func = " \n14"
'modified Bessel function 2\xb0 kind, order n, In(x)
Dim n1#, BI0#, DI0#, BI1#, DI1#, BK0#, DK0#, BK1#, DK1#
Dim NM#, bi#(), Di#(), BK#(), DK#()
If IsMissing(n) Then n1 = 0 Else n1 = CDbl_(n)
If n1 <= 1 Then
    Call IK01A(x, BI0, DI0, BI1, DI1, BK0, DK0, BK1, DK1)
    If n1 = 0 Then BesselKx = BK0 Else BesselKx = BK1
Else
    Call IKNA(n1, x, NM, bi, Di, BK, DK)
    BesselKx = BK(n1)
End If
End Function

Function BesseldK(x, Optional n)
Attribute BesseldK.VB_Description = "First derivative of mod. Bessel functions of 2nd kind, order n: K'n(x)"
Attribute BesseldK.VB_HelpID = 215
Attribute BesseldK.VB_ProcData.VB_Invoke_Func = " \n14"
'derivative of modified Bessel function 2\xb0 kind, order n, In(x)
Dim x1#, n1#, BI0#, DI0#, BI1#, DI1#, BK0#, DK0#, BK1#, DK1#
Dim NM#, bi#(), Di#(), BK#(), DK#()
If IsMissing(n) Then n1 = 0 Else n1 = CDbl_(n)
x1 = CDbl_(x)
If n1 <= 1 Then
    Call IK01A(x1, BI0, DI0, BI1, DI1, BK0, DK0, BK1, DK1)
    If n1 = 0 Then BesseldK = DK0 Else BesseldK = DK1
Else
    Call IKNA(n1, x1, NM, bi, Di, BK, DK)
    BesseldK = DK(n1)
End If
End Function

Function CosIntegral(x) As Double
Attribute CosIntegral.VB_Description = "Cosine integral Ci(x)"
Attribute CosIntegral.VB_HelpID = 216
Attribute CosIntegral.VB_ProcData.VB_Invoke_Func = " \n14"
'returns cos integral ci(x)
Dim Ci#, sI#
If x > 0 Then
  Call CISIA(x, Ci, sI)
  CosIntegral = Ci
End If
End Function

Function SinIntegral(x) As Double
Attribute SinIntegral.VB_Description = "Sine integral Si(x)"
Attribute SinIntegral.VB_HelpID = 217
Attribute SinIntegral.VB_ProcData.VB_Invoke_Func = " \n14"
'returns sin integral ci(x)
Dim Ci#, sI#
If x >= 0 Then
  Call CISIA(x, Ci, sI)
  SinIntegral = sI
End If
End Function

Function Fresnel_Cos(x) As Double
Attribute Fresnel_Cos.VB_Description = "Fresnel cosine integral C(x)"
Attribute Fresnel_Cos.VB_HelpID = 219
Attribute Fresnel_Cos.VB_ProcData.VB_Invoke_Func = " \n14"
'returns Fresnel's cos integral
Dim Fr_C#, Fr_S#
If x >= 0 Then
  Call FCS(x, Fr_C, Fr_S)
  Fresnel_Cos = Fr_C
End If
End Function

Function Fresnel_Sin(x) As Double
Attribute Fresnel_Sin.VB_Description = "Fresnel Sine integral S(x)"
Attribute Fresnel_Sin.VB_HelpID = 218
Attribute Fresnel_Sin.VB_ProcData.VB_Invoke_Func = " \n14"
'returns Fresnel's sin integral
Dim Fr_C#, Fr_S#
If x >= 0 Then
  Call FCS(x, Fr_C, Fr_S)
  Fresnel_Sin = Fr_S
End If
End Function

Function diGamma#(ByVal x#)
Attribute diGamma.VB_Description = "diGamma function"
Attribute diGamma.VB_HelpID = 212
Attribute diGamma.VB_ProcData.VB_Invoke_Func = " \n14"
Dim s#, t#, x2#, c, q#
Const LIM_LOW = 9
If x < -64 Then
  Select Case Int(x) - x
    Case Is < -0.5: x = 1# - x: s = vIntMod(x, 0.5) * Pi_
    Case 0: ErrRaise: Exit Function
    Case Else: s = vIntMod(x, 0.5) * -Pi_: x = 1# - x
  End Select
  If s <> 0 Then s = Pi_ * Cos(s) / Sin(s)
Else
  While x < LIM_LOW: s = s - 1# / x: x = x + 1#: Wend
End If
x2 = x ^ -2: t = x2
For Each c In psi_coeff: q = q - c * t: t = t * x2: Next
diGamma = s + Log(x) + q - 0.5 / x
End Function

Private Function HGammaPQ#(x1#, x2#, x3#, x4#)
'returns the product/quotient of four gamma functions PQ = Gamma(x1)*Gamma(x2) / Gamma(x3)*Gamma(x4)
Dim m1#, e1#, m2#, e2#, m3#, e3#, m4#, e4#
gamma_split x1, m1, e1
gamma_split x2, m2, e2
gamma_split x3, m3, e3
gamma_split x4, m4, e4
'm1 = (m1 * m2) / (m3 * m4)
'e1 = e1 + e2 - e3 - e4
'HGammaPQ = m1 * 10 ^ e1
HGammaPQ = ((m1 * m2) / (m3 * m4)) * 10 ^ (e1 + e2 - e3 - e4)
End Function

Private Function HGamma#(ByVal x#)
'compute y = gamma(x)
Dim Mantissa#, Expo#
If x <= 0 Then If x = Int(x) Then ErrRaise: Exit Function  'negative integer
gamma_split x, Mantissa, Expo
HGamma = Mantissa * 10 ^ Expo
End Function

Sub gamma_split(x#, Mantissa#, Expo#)
Dim z#, i%, s#, p#
Const G_# = 4.7421875  '607/128
Const sDiv# = "457526158344057598639561800698E-28"
    z = Abs(x) - 1
    s = GCf_(0)
    For i = 1 To 15: s = s + GCf_(i) / (z + i): Next
    s = s / sDiv
    p = z + 0.5
    p = Log((G_ + p) / dE_) * p / dLn10_
    'split in mantissa and exponent to avoid overflow
    Expo = Int(p)
    p = p - Int(p)
    s = 10 ^ p * s
    'rescaling
    p = Int(Log(s) / dLn10_)
    Mantissa = s * 10 ^ -p
    Expo = Expo + p
  If x < 0 Then
    p = Abs(x)
    s = -Pi_ / (Mantissa * p * Sin(Pi_ * p))
    p = Int(Log(Abs(s)) / dLn10_)
    Mantissa = s * 10 ^ -p
    Expo = p - Expo
  End If
End Sub

'-------------------------------------------------------------------------------
' logarithm gamma function
'-------------------------------------------------------------------------------
Private Function gammaln_(x#)
Dim Mantissa#, Expo#
    gamma_split x, Mantissa, Expo
    gammaln_ = Log(Mantissa) + Expo * dLn10_
End Function

'-------------------------------------------------------------------------------
' beta function
'---------------------------------------------------------------------------------
Sub HBeta(z#, w#, y#)
y = Exp(gammaln_(z) + gammaln_(w) - gammaln_(z + w))
End Sub


#If HperGeomTesting Then
Sub HYGFX(ByVal a#, ByVal b#, ByVal c#, ByVal x#, hf#, ErrorMsg$)
' ====================================================
'       Purpose: Compute hypergeometric function F(a,b,c,x)
'       Input :  a --- Parameter
'                b --- Parameter
'                c --- Parameter, c <> 0,-1,-2,...
'                x --- Argument   ( x < 1 )
'       Output:  HF --- F(a,b,c,x)
'====================================================
Dim CisNegInt As Boolean, AisNegInt As Boolean, BisNegInt As Boolean, CAisNegInt As Boolean, _
  CBisNegInt As Boolean, ZisClose2one As Boolean, EPS#, GC#, GCAB#, GCA#, GCB#, _
  NM#, r#, j&, k&, k1&, aa#, BB#, x1#, GM#, m#, GA#, GB#, _
  GAM#, GBM#, pa#, pb#, RM#, f0#, R0#, R1#, SP0#, sp#, C0#, _
  c1#, f1#, Sm#, rp#, HW#, GABC#, A0#, cab#

On Error GoTo Error_Handler

EPS = 1.6E-16
cab = c - a - b
CisNegInt = (c = Int(c)) And (c < 0)
ZisClose2one = (1 - x) < EPS
AisNegInt = (a = Int(a)) And (a < 0)
BisNegInt = (b = Int(b)) And (b < 0)
CAisNegInt = (c - a = Int(c - a)) And (c - a <= 0)
CBisNegInt = (c - b = Int(c - b)) And (c - b <= 0)

If x > 0.95 Then EPS = 0.00000001 '1e-8

If CisNegInt And Not ((AisNegInt And c <= a) Or (BisNegInt And c <= b) Or (CAisNegInt And c <= c - a) Or (CBisNegInt And c <= c - b)) Then
IsDivrgMsg: ErrorMsg = "The hypergeometric series is divergent" ' Hit zero denominator before numerator goes to 0
   Exit Sub
ElseIf x = 0 Or a = 0 Or b = 0 Then
   hf = 1
   Exit Sub
ElseIf ZisClose2one Then
  If cab <= 0 Then GoTo IsDivrgMsg
'  hf = (HGamma(c) * HGamma(cab)) / (HGamma(c - a) * HGamma(c - b))
  hf = HGammaPQ(c, cab, c - a, c - b)
  Exit Sub
ElseIf (1 + x <= EPS) And (Abs(c - a + b - 1) <= EPS) Then
   hf = (SqPi_ / 2 ^ a) * HGamma(c) / (HGamma(1 + a / 2 - b) * HGamma(0.5 + 0.5 * a))
   Exit Sub
ElseIf AisNegInt Or BisNegInt Then
   If AisNegInt Then If BisNegInt Then NM = min_(Int(Abs(b)), Int(Abs(a))) Else NM = Int(Abs(a)) Else NM = Int(Abs(b))
   hf = 1: r = 1
   For k = 1 To NM
      r = r * (a + k1) * (b + k1) / (k * (c + k1)) * x
      hf = hf + r: k1 = k
   Next k
   Exit Sub
ElseIf CAisNegInt Or CBisNegInt Then
   If CAisNegInt Then If CBisNegInt Then NM = min_(Int(Abs(c - b)), Int(Abs(c - a))) Else NM = Int(Abs(c - a)) Else NM = Int(Abs(c - b))
   hf = 1: r = 1
   For k = 1 To NM
      r = r * (c - a + k1) * (c - b + k1) / (k * (c + k1)) * x
      hf = hf + r: k1 = k
   Next k
   hf = (1 - x) ^ cab * hf
   Exit Sub
End If
aa = a
BB = b
x1 = x
If x < 0 Then
   x = x / (x - 1)
   If c > a And b < a And b > 0 Then
      a = BB
      b = aa
   End If
   b = c - b
End If
cab = c - a - b
If x >= 0.75 Then
   GM = 0
   If Abs(cab - Int(cab)) < 0.000000000000001 Then
      m = Int(cab)
      GA = HGamma(a) '  Call HGamma(a, GA)
      GB = HGamma(b)   'Call HGamma(b, GB)
      GC = HGamma(c)    'Call HGamma(c, GC)
      GAM = HGamma(a + m)   'Call HGamma(a + m, GAM)
      GBM = HGamma(b + m)   ' Call HGamma(b + m, GBM)
      pa = diGamma(a) '  Call HDigamma(a, PA)
      pb = diGamma(b)  'Call HDigamma(b, PB)
      If m <> 0 Then GM = 1
      For j = 1 To Abs(m) - 1
         GM = GM * j
      Next j
      RM = 1
      For j = 1 To Abs(m)
         RM = RM * j
      Next j
      f0 = 1
      R0 = 1
      R1 = 1
      SP0 = 0
      sp = 0
      If m >= 0 Then
         C0 = GM * GC / (GAM * GBM)
         c1 = -GC * (x - 1) ^ m / (GA * GB * RM)
         For k = 1 To m - 1
            R0 = R0 * (a + k1) * (b + k1) / (k * (k - m)) * (1 - x)
            f0 = f0 + R0: k1 = k
         Next k
         k1 = 0
         For k = 1 To m
            SP0 = SP0 + 1 / (a + k1) + 1 / (b + k1) - 1 / k: k1 = k
         Next k
         f1 = pa + pb + SP0 + 2 * dEu_ + Log(1 - x)
         k1 = 0
         For k = 1 To 250
            sp = sp + (1 - a) / (k * (a + k1)) + (1 - b) / (k * (b + k1))
            Sm = 0
            For j = 1 To m
               Sm = Sm + (1 - a) / ((j + k) * (a + j + k1)) + 1 / (b + j + k1)
            Next j
            rp = pa + pb + 2 * dEu_ + sp + Sm + Log(1 - x)
            R1 = R1 * (a + m + k1) * (b + m + k1) / (k * (m + k)) * (1 - x)
            f1 = f1 + R1 * rp
            If Abs(f1 - HW) < Abs(f1) * EPS Then Exit For
            HW = f1: k1 = k
         Next k
         hf = f0 * C0 + f1 * c1
      Else 'If m < 0 Then
         m = -m
         C0 = GM * GC / (GA * GB * (1 - x) ^ m)
         c1 = -(-1) ^ m * GC / (GAM * GBM * RM)
         For k = 1 To m - 1
            R0 = R0 * (a - m + k1) * (b - m + k1) / (k * (k - m)) * (1 - x)
            f0 = f0 + R0: k1 = k
         Next k
         For k = 1 To m
            SP0 = SP0 + 1 / k
         Next k
         f1 = pa + pb - SP0 + 2 * dEu_ + Log(1 - x)
         k1 = 0
         For k = 1 To 250
            sp = sp + (1 - a) / (k * (a + k1)) + (1 - b) / (k * (b + k1))
            Sm = 0
            For j = 1 To m
               Sm = Sm + 1 / (j + k)
            Next j
            rp = pa + pb + 2 * dEu_ + sp - Sm + Log(1 - x)
            R1 = R1 * (a + k1) * (b + k1) / (k * (m + k)) * (1 - x)
            f1 = f1 + R1 * rp
            If Abs(f1 - HW) < (Abs(f1) * EPS) Then Exit For
            HW = f1: k1 = k
         Next k
         hf = f0 * C0 + f1 * c1
      End If
   Else 'cab not int
'    GA = HGamma(a)    'Call HGamma(a, GA)
'    GB = HGamma(b)    'Call HGamma(b, GB)
'    GC = HGamma(c)    'Call HGamma(c, GC)
'    GCA = HGamma(c - a)    'Call HGamma(c - a, GCA)
'    GCB = HGamma(c - b)  'Call HGamma(c - b, GCB)
'    GCAB = HGamma(cab)  'Call HGamma(c - a - b, GCAB)
'    GABC = HGamma(a + b - c)   'Call HGamma(a + b - c, GABC)
'    C0 = GC * GCAB / (GCA * GCB)
'    C1 = GC * GABC / (GA * GB) * (1 - x) ^ cab
C0 = HGammaPQ(c, cab, c - a, c - b)
c1 = HGammaPQ(c, a + b - c, a, b) * (1 - x) ^ cab
    R0 = C0
    R1 = c1
    For k = 1 To 250
      R0 = R0 * (a + k1) * (b + k1) / (k * (a + b - c + k)) * (1 - x)
      R1 = R1 * (c - a + k1) * (c - b + k1) / (k * (cab + k)) * (1 - x)
      hf = hf + R0 + R1
      If Abs(hf - HW) < (Abs(hf) * EPS) Then Exit For
      HW = hf: k1 = k
    Next k
    hf = hf + C0 + c1
   End If
Else 'x<.75
   A0 = 1
   If c > a And c < 2 * a And c > b And c < 2 * b Then
      A0 = (1 - x) ^ cab
      a = c - a
      b = c - b
   End If
   hf = 1
   r = 1
   For k = 1 To 250
      r = r * (a + k1) * (b + k1) / (k * (c + k1)) * x
      hf = hf + r
      If Abs(hf - HW) <= (Abs(hf) * EPS) Then Exit For
      HW = hf: k1 = k
   Next k
   hf = A0 * hf
End If
If x1 < 0 Then
   x = x1
   C0 = 1 / (1 - x) ^ aa
   hf = C0 * hf
End If
a = aa
b = BB
If k > 120 Then ErrorMsg = "Warning! You should check the accuracy"
Exit Sub
Error_Handler: ErrorMsg = Err.Description
End Sub

Private Function Hypergeom2(a, b, c, x)
' Compute hypergeometric function
'  a --- Parameter
'  b --- Parameter
'  c --- Parameter, c <> 0,-1,-2,...
'  z --- Argument   ( x < 1 )
If VarType(a) < vbInteger Then Exit Function
Dim y#, Msg$, dt1 As Currency, dt0 As Currency: getTickCount dt0
Call HYGFX(a, b, c, x, y, Msg)
getTickCount dt1
Hypergeom2 = Array(y, (dt1 - dt0) * 10000, Msg)
End Function
#End If

'-------------------------------------------------------------------------------

 Sub INCOG(ByVal a#, ByVal x#, GIN#, GIM#, GIP#, Msg$)
' ===================================================
'       Purpose: Compute the incomplete gamma function
'         G(a, x), g(a, x) And P(a, x)
'       Input :  a   --- Parameter ( 0 < a < 170 )
'                x   --- Argument >= 0
'       Output:        GIN ---G(a, x)
'                      GIM ---g(a, x)
'                      GIP ---P(a, x)
'       Routine called: GAMMA for computing \xe2(x)
'===================================================
Dim k&, XAM#, GA#, s#, r#, t0 As Double
        If x > 0 Then
            XAM = -x + a * Log(x)
            If XAM > 700 Or a > 170 Then
               Msg = "a and/or x too large"
               Exit Sub
            End If
        ElseIf x < 0 Then
            Msg = "x < 0 not allowe"
            Exit Sub
        End If
        If x = 0 Then
           GIN = 0
           GA = HGamma(a) 'Call HGamma(a, GA)
           GIM = GA
           GIP = 0
        ElseIf x <= 1 + a Then
           s = 1 / a
           r = s
            For k = 1 To 60
              r = r * x / (a + k)
              s = s + r
              If Abs(r / s) < Ten_15 Then Exit For
            Next k
           GIN = Exp(XAM) * s
           GA = HGamma(a) 'Call HGamma(a, GA)
           GIP = GIN / GA
           GIM = GA - GIN
        ElseIf x > 1 + a Then
           t0 = 0
           For k = 60 To 1 Step -1
              t0 = (k - a) / (1 + k / (x + t0))
           Next k
           GIM = Exp(XAM) / (x + t0)
           GA = HGamma(a) 'Call HGamma(a, GA)
           GIN = GA - GIM
           GIP = 1 - GIM / GA
        End If
End Sub

Sub INCOB(ByVal a#, ByVal b#, ByVal x#, BIX#, bx#)
' ========================================================
'      Purpose: Compute the incomplete beta function Ix(a,b)
'       Input :  a --- Parameter >0
'                b - --Parameter >0
'                x --- Argument ( 0 <= x <= 1 )
'       Output:        BIX ---Ix(a, b)
'       Routine called: BETA for computing beta function B(p,q)
' ========================================================
Dim DK#(51), FK#(51), k&, s0#, t1#, t2#, TA#, TB#, BT#
    s0 = (a + 1) / (a + b + 2)
    Call HBeta(a, b, BT)
    If x <= s0 Then
       For k = 1 To 20
          DK(2 * k) = k * (b - k) * x / (a + 2 * k - 1) / (a + 2 * k)
       Next k
       For k = 0 To 20
          DK(2 * k + 1) = -(a + k) * (a + b + k) * x / (a + 2 * k) / (a + 2 * k + 1)
       Next k
       t1 = 0
       For k = 20 To 1 Step -1
          t1 = DK(k) / (1 + t1)
       Next k
       TA = 1 / (1 + t1)
       BIX = x ^ a * (1 - x) ^ b / (a * BT) * TA
       bx = x ^ a * (1 - x) ^ b / a * TA
    Else
       For k = 1 To 20
          FK(2 * k) = k * (a - k) * (1 - x) / (b + 2 * k - 1) / (b + 2 * k)
       Next k
       For k = 0 To 20
          FK(2 * k + 1) = -(b + k) * (a + b + k) * (1 - x) / (b + 2 * k) / (b + 2 * k + 1)
       Next k
       t2 = 0
       For k = 20 To 1 Step -1
          t2 = FK(k) / (1 + t2)
       Next k
       TB = 1 / (1 + t2)
       BIX = 1 - x ^ a * (1 - x) ^ b / (b * BT) * TB
       bx = BT - x ^ a * (1 - x) ^ b / b * TB
    End If
End Sub

Sub Airy_B(ByVal x#, Ai#, bi#, ad#, BD#)
'=======================================================
'       Purpose: Compute Airy functions and their derivatives
'       Input:   x  --- Argument of Airy function
'       Output:  AI --- Ai(x)
'                BI --- Bi(x)
'                AD --- Ai'(x)
'                BD --- Bi'(x)
'=======================================================
   Dim CK(41) As Double, DK(41) As Double
   Dim EPS#, c1#, c2#, SR3#, xa#, xq#, Xm#, fx#, r#, GX#, DF#, Dg#
   Dim xE#, XR1#, XAR#, xF#, rp#, km#
   Dim SAI#, SAD#, SBI#, SBD#, xp1#, xcs#, xss#, SSA#, SDA#, xR2#, SSB#, SDB#
   Dim k As Long
   
   EPS = 0.000000000000001
   c1 = 0.355028053887817
   c2 = 0.258819403792807
   SR3 = 1.73205080756888
   xa = Abs(x)
   xq = Sqr(xa)
   If x > 0 Then Xm = 5
   If x <= 0 Then Xm = 8
   If x = 0 Then
      Ai = c1
      bi = SR3 * c1
      ad = -c2
      BD = SR3 * c2
      Exit Sub
   End If
   If xa <= Xm Then
      fx = 1
      r = 1
      For k = 1 To 40
         r = r * x / (3 * k) * x / (3 * k - 1) * x
         fx = fx + r
         If Abs(r) < Abs(fx) * EPS Then Exit For
      Next k
      GX = x
      r = x
      For k = 1 To 40
         r = r * x / (3 * k) * x / (3 * k + 1) * x
         GX = GX + r
         If Abs(r) < Abs(GX) * EPS Then Exit For
      Next k
      Ai = c1 * fx - c2 * GX
      bi = SR3 * (c1 * fx + c2 * GX)
      DF = 0.5 * x * x
      r = DF
      For k = 1 To 40
         r = r * x / (3 * k) * x / (3 * k + 2) * x
         DF = DF + r
         If Abs(r) < Abs(DF) * EPS Then Exit For
      Next k
      Dg = 1
      r = 1
      For k = 1 To 40
         r = r * x / (3 * k) * x / (3 * k - 2) * x
         Dg = Dg + r
         If Abs(r) < Abs(Dg) * EPS Then Exit For
      Next k
      ad = c1 * DF - c2 * Dg
      BD = SR3 * (c1 * DF + c2 * Dg)
   Else
      xE = xa * xq / 1.5
      XR1 = 1 / xE
      XAR = 1 / xq
      xF = Sqr(XAR)
      rp = 0.564189583547756
      r = 1
      For k = 1 To 40
         r = r * (6 * k - 1) / 216 * (6 * k - 3) / k * (6 * k - 5) / (2 * k - 1)
         CK(k) = r
         DK(k) = -(6 * k + 1) / (6 * k - 1) * CK(k)
      Next k
      km = Int(24.5 - xa)
      If xa < 6 Then km = 14
      If xa > 15 Then km = 10
      If x > 0 Then
         SAI = 1
         SAD = 1
         r = 1
         For k = 1 To km
            r = -r * XR1
            SAI = SAI + CK(k) * r
            SAD = SAD + DK(k) * r
         Next k
         SBI = 1
         SBD = 1
         r = 1
         For k = 1 To km
            r = r * XR1
            SBI = SBI + CK(k) * r
            SBD = SBD + DK(k) * r
         Next k
         xp1 = Exp(-xE)
         If xp1 <> 0 Then
          Ai = 0.5 * rp * xF * xp1 * SAI
          bi = rp * xF / xp1 * SBI
          ad = -0.5 * rp / xF * xp1 * SAD
          BD = rp / xF / xp1 * SBD
         End If
      Else
         xcs = Cos(xE + Pi4_)
         xss = Sin(xE + Pi4_)
         SSA = 1
         SDA = 1
         r = 1
         xR2 = 1 / (xE * xE)
         For k = 1 To km
            r = -r * xR2
            SSA = SSA + CK(2 * k) * r
            SDA = SDA + DK(2 * k) * r
         Next k
         SSB = CK(1) * XR1
         SDB = DK(1) * XR1
         r = XR1
         For k = 1 To km
            r = -r * xR2
            SSB = SSB + CK(2 * k + 1) * r
            SDB = SDB + DK(2 * k + 1) * r
         Next k
         Ai = rp * xF * (xss * SSA - xcs * SSB)
         bi = rp * xF * (xcs * SSA + xss * SSB)
         ad = -rp / xF * (xcs * SDA + xss * SDB)
         BD = rp / xF * (xss * SDA - xcs * SDB)
      End If
   End If
End Sub

Function xGammaI(ByVal a#, ByVal x#, Optional sel) As Double
Attribute xGammaI.VB_Description = "Incomplete Gamma function\nOptional [sel] can be entered as 1 or 2\nIf [sel] is missing, [sel] = 1"
Attribute xGammaI.VB_HelpID = 287
Attribute xGammaI.VB_ProcData.VB_Invoke_Func = " \n14"
'incomplete gamma function . v.7.3.2007
Dim GIN#, GIM#, GIP#, Msg$, Ret#
If IsMissing(sel) Then sel = 1
If a <= 0 Or x < 0 Then xGammaI = "?": Exit Function
If x = 0 And sel = 4 Then
    Ret = 1 / xGamma(a + 1, 15) 'Tricomi for x=0
Else
    Call INCOG(a, x, GIN, GIM, GIP, Msg)
    If Len(Msg) <> 0 Then xGammaI = vbNullString  'raise an error
    Select Case sel
        Case 1: Ret = GIN  'g(a,x)
        Case 2: Ret = GIM  'G(a,x)
        Case 3: Ret = GIP  'P(a,x)
        Case 4: Ret = GIP * x ^ (-a)  't(a,x) Tricomi form
        Case Else: Ret = GIN  '(Default)
    End Select
End If
xGammaI = Ret
End Function

Function xBetaI(ByVal x#, ByVal a#, ByVal b#, Optional sel)
Attribute xBetaI.VB_Description = "Incomplete Beta function.\nOptional [sel] can be entered as 1 or 2\nIf [sel] is missing, [sel] = 1"
Attribute xBetaI.VB_HelpID = 288
Attribute xBetaI.VB_ProcData.VB_Invoke_Func = " \n14"
'incomplete gamma function
Dim BIX#, bx#
If IsMissing(sel) Then sel = 1
If x < 0 Or x > 1 Or a <= 0 Or b <= 0 Then xBetaI = "?": Exit Function
Call INCOB(a, b, x, BIX, bx)
If sel = 1 Then xBetaI = bx Else xBetaI = BIX
End Function

Function AiryA(ByVal x#) As Double
Attribute AiryA.VB_Description = "Airy function A(x)"
Attribute AiryA.VB_HelpID = 289
Attribute AiryA.VB_ProcData.VB_Invoke_Func = " \n14"
Dim y#, Ai#, bi#, ad#, BD As Double
    Call Airy_B(x, Ai, bi, ad, BD)
    AiryA = Ai
End Function

Function AiryB(ByVal x#) As Double
Attribute AiryB.VB_Description = "Airy function B(x)"
Attribute AiryB.VB_HelpID = 289
Attribute AiryB.VB_ProcData.VB_Invoke_Func = " \n14"
Dim y#, Ai#, bi#, ad#, BD As Double
    Call Airy_B(x, Ai, bi, ad, BD)
    AiryB = bi
End Function

Function AiryAD(ByVal x#) As Double
Attribute AiryAD.VB_Description = "Derivative Airy function A'(x)"
Attribute AiryAD.VB_HelpID = 289
Attribute AiryAD.VB_ProcData.VB_Invoke_Func = " \n14"
Dim y#, Ai#, bi#, ad#, BD As Double
    Call Airy_B(x, Ai, bi, ad, BD)
    AiryAD = ad
End Function

Function AiryBD(ByVal x#) As Double
Attribute AiryBD.VB_Description = "Derivative Airy function B'(x)"
Attribute AiryBD.VB_HelpID = 289
Attribute AiryBD.VB_ProcData.VB_Invoke_Func = " \n14"
Dim y#, Ai#, bi#, ad#, BD As Double
    Call Airy_B(x, Ai, bi, ad, BD)
    AiryBD = BD
End Function

'return the M(a,b,z) Kummer confluent hypergeometric function of 1st kind
'it uses the serie expansion method
'
Function Kummer1(a, b, z)
Attribute Kummer1.VB_Description = "Kummer confluent hypergeometric function of 1st kind"
Attribute Kummer1.VB_HelpID = 309
Attribute Kummer1.VB_ProcData.VB_Invoke_Func = " \n14"
Dim n&, kn#, PN#, dY#, y#, ua#
Const TOL# = 1.6 * Ten_16
kn = 1#: PN = 1#:  y = 1#
'Kummer's transformation for negative value of z
If z < 0 Then ua = b - a Else ua = a
For n = 1 To 999
    kn = kn * (ua + n - 1) / (b + n - 1)
    PN = PN * Abs(z) / n
    dY = kn * PN
    y = y + dY
    If Abs(dY) < TOL * Abs(y) Then Exit For
Next n
If n < 999 Then
    If z < 0 Then y = y * Exp(z)  'Kummer's anti-transformation
    Kummer1 = y
Else
    Kummer1 = "?"
End If
End Function

Function xKummer1(a, b, z, Optional Digit_Max, Optional ConvDetCnt& = 5000, _
  Optional Tolerance# = 0.05, Optional Force_NUMBER_ret As Boolean) As String
Attribute xKummer1.VB_Description = "Kummer confluent hypergeometric function of 1st kind\nConvDetCnt default=5000, Tolerance default=0.05\n[Force_NUMBER_ret] returns current sum instead of error message. Default=FALSE"
Attribute xKummer1.VB_HelpID = 309
Attribute xKummer1.VB_ProcData.VB_Invoke_Func = " \n14"
'Python MpMath equiv hyp1f1
Dim n&, kn$, PN$, dY$, y$, ua$, py$, DgMx&, n1&, ub$, uz$, IsNeg As Boolean, MatchDgts#, PrevMD#
SetDgMx DgMx, Digit_Max
If ConvDetCnt > 2000000 Then ConvDetCnt = 2000000
ub = dCStr_(b): uz = dCStr_(z)
kn = 1: PN = 1:  y = 1: n = 0
'Kummer's transformation for negative value of z
If xCompZ(z) < 0 Then ua = xSubR(b, a, DgMx): IsNeg = True Else ua = dCStr_(a)
Do
  n1 = n: n = n + 1
  kn = xDivR(xMultR(kn, xAddR(ua, n1, DgMx), DgMx), xAddR(ub, n1, DgMx), DgMx)
  PN = xDivR(xMultR(PN, xAbsR(uz), DgMx), n, DgMx)
  dY = xMultR(kn, PN, DgMx)
  py = y: y = xAddR(y, dY, DgMx)
  MatchDgts = fDgMat(y, py, DgMx)
  If n > ConvDetCnt Then
    If MatchDgts - PrevMD < Tolerance Then
'      If Force_NUMBER_ret Then
'        dY = "1E" & DgMx
'        xKummer1 = xHypGeom(a, dY, ub, xDivR(uz, dY, DgMx), Digit_Max): Exit Function
      If Force_NUMBER_ret And MatchDgts > 1 Then
        Digit_Max = Int(MatchDgts + 1): Exit Do
      Else
        xKummer1 = "Convergence Detection Failure: " _
        & "IterCnt = " & n & ": Improvement = " & (MatchDgts - PrevMD) & _
        ": Value= " & xFmtStr(y, Digit_Max) & _
        ": PrevValue= " & xFmtStr(py, Digit_Max): Exit Function
      End If
    End If
    PrevMD = MatchDgts
  End If
Loop While MatchDgts < Digit_Max
If IsNeg Then y = xMultR(y, xExp(uz, DgMx), DgMx) 'Kummer's anti-transformation
xKummer1 = xFmtStr(y, Digit_Max)
End Function

'return the U(a,b,z) Kummer confluent hypergeometric function of 2st kind
'uses the infinite integration integration method for a>0
'uses the recurrence equation for a<0
'
Function Kummer2(a, b, z)
Attribute Kummer2.VB_Description = "Kummer confluent hypergeometric function of 2nd kind"
Attribute Kummer2.VB_HelpID = 309
Attribute Kummer2.VB_ProcData.VB_Invoke_Func = " \n14"
On Error GoTo Error_Handler
Dim y#
If a > 0 Then
    Dim res, g#
    Dim pm(1 To 2, 1 To 3)
    pm(1, 1) = "a": pm(1, 2) = "b": pm(1, 3) = "z"
    pm(2, 1) = a: pm(2, 2) = b: pm(2, 3) = z
    g = HGamma(a)
    res = Integr_DE("exp(-z*x)*x^(a-1)*(1+x)^(b-a-1)", 0, "inf", pm)
    y = res(1, 1) / g
    Kummer2 = y
ElseIf a < 0 Then
    Dim u0#, U1#, A0#, n&, i&
    n = Int(Abs(a)) + 1
    A0 = n - Abs(a)
    u0 = Kummer2(A0, b, z)
    U1 = Kummer2(A0 + 1, b, z)
    For i = 1 To n
        y = -(b - 2 * A0 - z) * u0 + -A0 * (1 + A0 - b) * U1
        U1 = u0
        u0 = y
        A0 = A0 - 1
    Next i
    Kummer2 = y
Else
    GoTo Error_Handler
End If
Exit Function
Error_Handler:
    Kummer2 = "?"
End Function

'integral power of cosine
Function IntPowCos(n, x)
Attribute IntPowCos.VB_Description = "Integral of cosine raised to integer power"
Attribute IntPowCos.VB_HelpID = 316
Attribute IntPowCos.VB_ProcData.VB_Invoke_Func = " \n14"
Dim k, z, y, h, y1
'reduce angle in the interval [0 , pi/2]
If x = 0 Then IntPowCos = 0: Exit Function
angle_reduce Abs(x), z, k
If z < qPi2_ Then
    y = CosPowRid(n, z)
Else
    If n Mod 2 = 0 Then
        h = CosPowRid(n, qPi2_)
        y = h + SinPowRid(n, z - qPi2_)
    Else
        y = CosPowRid(n, 2 * qPi2_ - z)
    End If
End If
If n Mod 2 = 0 Then
    If h = 0 Then h = CosPowRid(n, qPi2_)
    y = y + 2 * k * h
Else
    If k Mod 2 <> 0 Then y = -y
End If
If x < 0 Then y = -y
IntPowCos = CvD2s(y)
End Function

'integral power of sine
Function IntPowSin(n, x)
Attribute IntPowSin.VB_Description = "Integral of sine raised to integer power"
Attribute IntPowSin.VB_HelpID = 316
Attribute IntPowSin.VB_ProcData.VB_Invoke_Func = " \n14"
Dim k, z, y, h, y1
'reduce angle in the interval [0 , pi/2]
If x = 0 Then IntPowSin = 0: Exit Function
angle_reduce Abs(x), z, k
If k Mod 2 <> 0 And n Mod 2 <> 0 Then
    If z < qPi2_ Then
        h = SinPowRid(n, qPi2_)
        y = 2 * h - SinPowRid(n, z)
    Else
        y = SinPowRid(n, 2 * qPi2_ - z)
    End If
Else
    If z < qPi2_ Then
        y = SinPowRid(n, z)
    Else
        If h = 0 Then h = SinPowRid(n, qPi2_)
        y = CosPowRid(n, z - qPi2_) + h
    End If
    If n Mod 2 = 0 Then
        If h = 0 Then h = SinPowRid(n, qPi2_)
        y = y + 2 * k * h
    End If
End If

If x < 0 Then If n Mod 2 = 0 Then y = -y
IntPowSin = CvD2s(y)
End Function

'angle reduction
Sub angle_reduce(x, z, k)
Dim y
y = (CDec_(x) / qPi_)
k = Int(y)
'z = CDbl(x - k * qPi_)
z = x - k * qPi_
End Sub

'x <= pi/2
Private Function CosPowRid(n, x)
Dim i&, j&, s, c, y(2), p ', TOL#
'TOL = 2 * Ten_16
If n = 0 Then
    CosPowRid = x
    Exit Function
End If
y(0) = CDec_(x)
c = qCos_rid(y(0))
s = qSin_rid(y(0))
y(1) = s
p = c
For i = 2 To n
    y(2) = s * p / i + CDec((i - 1)) / CDec(i) * y(0)
    p = p * c
    y(0) = y(1)
    y(1) = y(2)
Next i
CosPowRid = y(1)
End Function

'x <= pi/2
Private Function SinPowRid(n, x)
Dim a, y(2)
If n = 0 Then
    SinPowRid = x
    Exit Function
End If
If x < 0.7 Then
    y(2) = SinPowSmall(n, x)
Else
    y(0) = CosPowRid(n, qPi2_ - x)
    y(1) = CosPowRid(n, qPi2_)
    y(2) = y(1) - y(0)
End If
SinPowRid = y(2)
End Function

'x < 0.7
Private Function SinPowSmall(n, x)
Dim pi2, a, s, q, U, jmax&, j&, c, y, d, p
'set pi/2
Const TOL# = 10 ^ -28
a = 1
s = 1# / (n + 1)
U = 1
jmax = 1000
y = Sin(x)
q = y * y
j = 2
Do
    a = (j - 1) / j * a
    U = U * q
    d = (a * U) / (j + n + 1)
    If Abs(d) < TOL Then Exit Do
    s = s + d
    j = j + 2
Loop Until j > jmax
If j > jmax Then SinPowSmall = 0: Exit Function
SinPowSmall = s * y ^ (n + 1)
End Function

#If HperGeomTesting Then
Private Function HypGeom0(a_, b#, c#, z#)
Dim a#, convergent As Boolean, finite As Boolean, zerodiv As Boolean, AisInt As Boolean, BisInt As Boolean, _
  CisInt As Boolean, absz
If VarType(a_) < vbInteger Then Exit Function Else a = a_

    CisInt = (c = Int(c))
    AisInt = (a = Int(a))
    BisInt = (b = Int(b))
    If z = 1 Then
        ' TODO: the following logic can be simplified
        convergent = (c - a - b) > 0
        finite = (AisInt And a <= 0) Or (BisInt And b <= 0)
        zerodiv = c = Int(c) And c <= 0 And Not ((AisInt And c <= a <= 0) Or (BisInt And c <= b <= 0))
        ' Gauss's theorem gives the value if convergent
        If (convergent Or finite) And Not zerodiv Then
        ''    return ctx.gammaprod([c, c-a-b], [c-a, c-b], _infsign=True)
          HypGeom0 = (HGamma(c) * HGamma(c - a - b)) / (HGamma(c - a) * HGamma(c - b))
        Else
        ' Otherwise, there is a pole and we take the
        ' sign to be that when approaching from below
        ' XXX: this evaluation is not necessarily correct in all cases
          HypGeom0 = "+inf" 'return ctx.hyp2f1(a,b,c,1-ctx.eps*2) * ctx.inf
        End If
        Exit Function
    ElseIf z = 0 Then ' Equal to 1 , unless there is a subsequent division by zero
        If c <> 0 Or a = 0 Or b = 0 Then
        ' Division by zero but power of z is higher than first order so cancels
            HypGeom0 = 1#
        Else
        ' Indeterminate
          HypGeom0 = "nan" 'return ctx.nan
        End If
        Exit Function
    ElseIf CisInt And c <= 0 Then ' Hit zero denominator unless numerator goes to 0 first
        If Not ((AisInt And c <= a And a <= 0) Or (BisInt And c <= b And b <= 0)) Then
            ' Pole in series
          HypGeom0 = "+inf" 'return ctx.inf
          Exit Function
        End If
    End If

    absz = Abs(z)
    
'    If absz <= 0.8 Or (AisInt And a <= 0 And a >= -1000) Or (BisInt And b <= 0 And b >= -1000) Then
    If absz <= 0.8 Or (AisInt And a <= 0 And a >= -50) Or (BisInt And b <= 0 And b >= -50) Then
    ' Fast case: standard series converges rapidly, possibly in finitely many terms
       ' return ctx.hypsum(2, 1, (atype, btype, ctype), [a, b, c], z, **kwargs)
      HypGeom0 = Gauss_Series(a, b, c, z)

'try:
        'ctx.prec += 10

        
    ElseIf absz >= 1.3 Then ' Use 1/z transformation
'            def h(a, b):
'                t = ctx.mpq_1-c; ab = a-b; rz = 1/z
'                T1 = ([-z],[-a], [c,-ab],[b,c-a], [a,t+a],[ctx.mpq_1+ab],  rz)
'                T2 = ([-z],[-b], [c,ab],[a,c-b], [b,t+b],[ctx.mpq_1-ab],  rz)
'                return T1, T2
'            v = ctx.hypercomb(h, [a,b], **kwargs)
'      HypGeom0 = Gauss_Series(c - a, b, c, z / (z - 1)) / (1 - z) ^ b
'      HypGeom0 = Gauss_Series(a, c - b, c, z / (z - 1)) / (1 - z) ^ a
       HypGeom0 = HypGeom27(a, b, c, z)
       
    ElseIf Abs(1 - z) <= 0.75 Then ' Use 1-z transformation
'            def h(a, b):
'                t = c-a-b; ca = c-a; cb = c-b; rz = 1-z
'                T1 = [], [], [c,t], [ca,cb], [a,b], [1-t], rz
'                T2 = [rz], [t], [c,a+b-c], [a,b], [ca,cb], [1+t], rz
'                return T1, T2
'            v = ctx.hypercomb(h, [a,b], **kwargs)
      HypGeom0 = Gauss_Series(c - a, c - b, c, z) * (1 - z) ^ (c - a - b)
        
    ElseIf Abs(z / (z - 1)) <= 0.75 Then ' Use z/(z-1) transformation
'            v = ctx.hyp2f1(a, c-b, c, z/(z-1)) / (1-z)**a
      HypGeom0 = Gauss_Series(a, c - b, c, z / (z - 1)) / (1 - z) ^ a

    Else ' Remaining part of unit circle
'            v = _hyp2f1_gosper(ctx,a,b,c,z,**kwargs)
      HypGeom0 = HypGeom5_(a, b, c, z)
    End If
End Function
#End If


'Computes the Hypergeometric function
' |z| < 1 and c <> 0,-1,-2,-3 ...
Function HypGeom(a, b, c, z)
Attribute HypGeom.VB_Description = "Hypergeometric function"
Attribute HypGeom.VB_HelpID = 260
Attribute HypGeom.VB_ProcData.VB_Invoke_Func = " \n14"
If VarType(a) < vbInteger Then Exit Function
Dim U1#, U2#
On Error GoTo Error_Handler
'check domain
If c <= 0 Then If Round(c) = c Then GoTo Error_Handler 'c = 0,-1,-2 ...
    
If z < 0 Then
'  z_ = z / (z - 1)  '0 < z_ < 0.5
'  U1 = 1 + (b - a) / c
'  U2 = 1 + (a - b) / c
  U1 = c - a: U2 = c - b
  If U1 < U2 Then
    HypGeom = Gauss_Series(U1, b, c, z / (z - 1)) / (1 - z) ^ b
  Else
    HypGeom = Gauss_Series(a, U2, c, z / (z - 1)) / (1 - z) ^ a
  End If
Else
  U1 = c - a - b
  If z = 1 Then
    HypGeom = (xGamma(c, 15) * xGamma(U1, 15)) / (xGamma(c - a, 15) * xGamma(c - b, 15))
  Else
    If U1 > 0 Then
      HypGeom = Gauss_Series(a, b, c, z)
    Else
      HypGeom = Gauss_Series(c - a, c - b, c, z) * (1 - z) ^ U1
    End If
  End If
End If
Exit Function
Error_Handler:
HypGeom = "?"
End Function

#If HperGeomTesting Then
Private Function HypGeomGamma(a, b#, c#) ' z is 1
If VarType(a) < vbInteger Then Exit Function
Dim y#, dt1 As Currency, dt0 As Currency: getTickCount dt0
'y = (xGamma(c, 15) * xGamma(c - a - b, 15)) / (xGamma(c - a, 15) * xGamma(c - b, 15))
'y = (HGamma(c) * HGamma(c - a - b)) / (HGamma(c - a) * HGamma(c - b))
'y = xGammaP(c, c - a - b, 15) / xGammaP(c - a, c - b, 15)
y = xGammaPQ(c, c - a - b, c - a, c - b, 15)
getTickCount dt1
HypGeomGamma = Array(y, (dt1 - dt0) * 10000)
End Function

Private Function HypGeom1(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
Dim y#, dt1 As Currency, dt0 As Currency: getTickCount dt0
y = Gauss_Series(a, b, c, z)
getTickCount dt1
HypGeom1 = Array(y, (dt1 - dt0) * 10000)
End Function
Private Function HypGeom2(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
Dim y#, dt1 As Currency, dt0 As Currency: getTickCount dt0
y = Gauss_Series(c - a, c - b, c, z) * (1 - z) ^ (c - a - b)
getTickCount dt1
HypGeom2 = Array(y, (dt1 - dt0) * 10000)
End Function
Private Function HypGeom3(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
Dim y#, dt1 As Currency, dt0 As Currency: getTickCount dt0
y = Gauss_Series(a, c - b, c, z / (z - 1)) / (1 - z) ^ a
getTickCount dt1
HypGeom3 = Array(y, (dt1 - dt0) * 10000)
End Function
Private Function HypGeom4(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
Dim y#, dt1 As Currency, dt0 As Currency: getTickCount dt0
y = Gauss_Series(c - a, b, c, z / (z - 1)) / (1 - z) ^ b
getTickCount dt1
HypGeom4 = Array(y, (dt1 - dt0) * 10000)
End Function
Private Function HypGeom5(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
Dim y#, dt1 As Currency, dt0 As Currency: getTickCount dt0
y = Gauss_Series(a, b, a + b + 1 - c, 1 - z)
getTickCount dt1
HypGeom5 = Array(y, (dt1 - dt0) * 10000)
End Function
Private Function HypGeom6(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
Dim y#, dt1 As Currency, dt0 As Currency: getTickCount dt0
y = Gauss_Series(a + 1 - c, b + 1 - c, a + b + 1 - c, 1 - z) * z ^ (1 - c)
getTickCount dt1
HypGeom6 = Array(y, (dt1 - dt0) * 10000)
End Function
Private Function HypGeom7(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
Dim y#, dt1 As Currency, dt0 As Currency: getTickCount dt0
y = Gauss_Series(a, a + 1 - c, a + b + 1 - c, 1 - 1 / z) / z ^ a
getTickCount dt1
HypGeom7 = Array(y, (dt1 - dt0) * 10000)
End Function
Private Function HypGeom8(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
Dim y#, dt1 As Currency, dt0 As Currency: getTickCount dt0
y = Gauss_Series(b + 1 - c, b, a + b + 1 - c, 1 - 1 / z) / z ^ b
getTickCount dt1
HypGeom8 = Array(y, (dt1 - dt0) * 10000)
End Function
Private Function HypGeom9(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
Dim y#, dt1 As Currency, dt0 As Currency: getTickCount dt0
y = Gauss_Series(a, a + 1 - c, a + 1 - b, 1 / z) / -z ^ a
getTickCount dt1
HypGeom9 = Array(y, (dt1 - dt0) * 10000)
End Function
Private Function HypGeom10(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
Dim y#, dt1 As Currency, dt0 As Currency: getTickCount dt0
y = Gauss_Series(1 - b, c - b, a + 1 - b, 1 / z) * -z ^ (b - c) * (1 - z) ^ (c - a - b)
getTickCount dt1
HypGeom10 = Array(y, (dt1 - dt0) * 10000)
End Function
Private Function HypGeom11(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
Dim y#, dt1 As Currency, dt0 As Currency: getTickCount dt0
y = Gauss_Series(a, c - b, a + 1 - b, 1 / (1 - z)) / (1 - z) ^ a
getTickCount dt1
HypGeom11 = Array(y, (dt1 - dt0) * 10000)
End Function
Private Function HypGeom12(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
Dim y#, dt1 As Currency, dt0 As Currency: getTickCount dt0
y = Gauss_Series(a + 1 - c, 1 - b, a + 1 - b, 1 / (1 - z)) * -z ^ (1 - c) * (1 - z) ^ (c - a - 1)
getTickCount dt1
HypGeom12 = Array(y, (dt1 - dt0) * 10000)
End Function
Private Function HypGeom13(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
Dim y#, dt1 As Currency, dt0 As Currency: getTickCount dt0
y = Gauss_Series(b + 1 - c, b, b + 1 - a, 1 / z) / -z ^ b
getTickCount dt1
HypGeom13 = Array(y, (dt1 - dt0) * 10000)
End Function
Private Function HypGeom14(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
Dim y#, dt1 As Currency, dt0 As Currency: getTickCount dt0
y = Gauss_Series(1 - a, c - a, b + 1 - a, 1 / z) * -z ^ (a - c) * (1 - z) ^ (c - a - b)
getTickCount dt1
HypGeom14 = Array(y, (dt1 - dt0) * 10000)
End Function
Private Function HypGeom15(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
Dim y#, dt1 As Currency, dt0 As Currency: getTickCount dt0
y = Gauss_Series(b, c - a, b + 1 - a, 1 / (1 - z)) / (1 - z) ^ b
getTickCount dt1
HypGeom15 = Array(y, (dt1 - dt0) * 10000)
End Function
Private Function HypGeom16(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
Dim y#, dt1 As Currency, dt0 As Currency: getTickCount dt0
y = Gauss_Series(b + 1 - c, 1 - a, b + 1 - a, 1 / (1 - z)) * -z ^ (1 - c) * (1 - z) ^ (c - b - 1)
getTickCount dt1
HypGeom16 = Array(y, (dt1 - dt0) * 10000)
End Function
Private Function HypGeom17(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
Dim y#, dt1 As Currency, dt0 As Currency: getTickCount dt0
y = Gauss_Series(a + 1 - c, b + 1 - c, 2 - c, z) * z ^ (1 - c)
getTickCount dt1
HypGeom17 = Array(y, (dt1 - dt0) * 10000)
End Function
Private Function HypGeom18(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
Dim y#, dt1 As Currency, dt0 As Currency: getTickCount dt0
y = Gauss_Series(1 - a, 1 - b, 2 - c, z) * z ^ (1 - c) * (1 - z) ^ (c - a - b)
getTickCount dt1
HypGeom18 = Array(y, (dt1 - dt0) * 10000)
End Function
Private Function HypGeom19(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
Dim y#, dt1 As Currency, dt0 As Currency: getTickCount dt0
y = Gauss_Series(a + 1 - c, 1 - b, 2 - c, z / (z - 1)) * z ^ (1 - c) * (1 - z) ^ (c - a - 1)
getTickCount dt1
HypGeom19 = Array(y, (dt1 - dt0) * 10000)
End Function
Private Function HypGeom20(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
Dim y#, dt1 As Currency, dt0 As Currency: getTickCount dt0
y = Gauss_Series(b + 1 - c, 1 - a, 2 - c, z / (z - 1)) * z ^ (1 - c) * (1 - z) ^ (c - b - 1)
getTickCount dt1
HypGeom20 = Array(y, (dt1 - dt0) * 10000)
End Function
Private Function HypGeom21(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
Dim y#, dt1 As Currency, dt0 As Currency: getTickCount dt0
y = Gauss_Series(c - a, c - b, c + 1 - a - b, 1 - z) * (1 - z) ^ (c - a - b)
getTickCount dt1
HypGeom21 = Array(y, (dt1 - dt0) * 10000)
End Function
Private Function HypGeom22(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
Dim y#, dt1 As Currency, dt0 As Currency: getTickCount dt0
y = Gauss_Series(1 - a, 1 - b, c + 1 - a - b, 1 - z) * (1 - z) ^ (c - a - b) * z ^ (1 - c)
getTickCount dt1
HypGeom22 = Array(y, (dt1 - dt0) * 10000)
End Function
Private Function HypGeom23(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
Dim y#, dt1 As Currency, dt0 As Currency: getTickCount dt0
y = Gauss_Series(c - a, 1 - a, c + 1 - a - b, 1 - 1 / z) * (1 - z) ^ (c - a - b) * z ^ (a - c)
getTickCount dt1
HypGeom23 = Array(y, (dt1 - dt0) * 10000)
End Function
Private Function HypGeom24(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
Dim y#, dt1 As Currency, dt0 As Currency: getTickCount dt0
y = Gauss_Series(c - b, 1 - b, c + 1 - a - b, 1 - 1 / z) * (1 - z) ^ (c - a - b) * z ^ (b - c)
getTickCount dt1
HypGeom24 = Array(y, (dt1 - dt0) * 10000)
End Function
Private Function HGM_1(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
'If Abs(z) <= 1 Then HGM_1 = a * b / c * z
HGM_Arr (a), b, c, z, HGM_1
End Function
Private Function HGM_2(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
'If Abs(z) <= 1 Then HGM_2 = (c - a) * (c - b) / c * z
HGM_Arr c - a, c - b, c, z, HGM_2
End Function
Private Function HGM_3(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
'If Abs(z / (z - 1)) <= 1 Then HGM_3 = a * (c - b) / (c * (z / (z - 1)))
HGM_Arr (a), c - b, c, z / (z - 1), HGM_3
End Function
Private Function HGM_4(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
'If Abs(z / (z - 1)) <= 1 Then HGM_4 = (c - a) * b / (c * (z / (z - 1)))
HGM_Arr c - a, b, c, z / (z - 1), HGM_4
End Function
Private Function HGM_5(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
'If Abs(1 - z) <= 1 Then HGM_5 = a * b / ((a + b + 1 - c) * (1 - z))
HGM_Arr (a), b, a + b + 1 - c, 1 - z, HGM_5
End Function
Private Function HGM_6(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
'If Abs(1 - z) <= 1 Then HGM_6 = (a + 1 - c) * (b + 1 - c) / (a + b + 1 - c) * (1 - z)
HGM_Arr a + 1 - c, b + 1 - c, a + b + 1 - c, 1 - z, HGM_6
End Function
Private Function HGM_7(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
'If Abs(1 - 1 / z) <= 1 Then HGM_7 = a * (a + 1 - c) / (a + b + 1 - c) * (1 - 1 / z)
HGM_Arr (a), a + 1 - c, a + b + 1 - c, 1 - 1 / z, HGM_7
End Function
Private Function HGM_8(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
'If Abs(1 - 1 / z) <= 1 Then HGM_8 = (b + 1 - c) * b / (a + b + 1 - c) * (1 - 1 / z)
HGM_Arr b + 1 - c, b, a + b + 1 - c, 1 - 1 / z, HGM_8
End Function
Private Function HGM_9(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
'If Abs(1 / z) <= 1 Then HGM_9 = a * (a + 1 - c) / (a + 1 - b) * (1 / z)
HGM_Arr (a), a + 1 - c, a + 1 - b, 1 / z, HGM_9
End Function
Private Function HGM_10(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
'If Abs(1 / z) <= 1 Then HGM_10 = (1 - b) * (c - b) / (a + 1 - b) * (1 / z)
HGM_Arr 1 - b, c - b, a + 1 - b, 1 / z, HGM_10
End Function
Private Function HGM_11(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
'If Abs(1 / (1 - z)) <= 1 Then HGM_11 = a * (c - b) / (a + 1 - b) * (1 / (1 - z))
HGM_Arr (a), c - b, a + 1 - b, 1 / (1 - z), HGM_11
End Function
Private Function HGM_12(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
'If Abs(1 / (1 - z)) <= 1 Then HGM_12 = (a + 1 - c) * (1 - b) / (a + 1 - b) * (1 / (1 - z))
HGM_Arr a + 1 - c, 1 - b, a + 1 - b, 1 / (1 - z), HGM_12
End Function
Private Function HGM_13(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
'If Abs(1 / z) <= 1 Then HGM_13 = (b + 1 - c) * b / (b + 1 - a) * (1 / z)
HGM_Arr b + 1 - c, b, b + 1 - a, 1 / z, HGM_13
End Function
Private Function HGM_14(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
'If Abs(1 / z) <= 1 Then HGM_14 = (1 - a) * (c - a) / (b + 1 - a) * (1 / z)
HGM_Arr 1 - a, c - a, b + 1 - a, 1 / z, HGM_14
End Function
Private Function HGM_15(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
'If Abs(1 / (1 - z)) <= 1 Then HGM_15 = b * (c - a) / (b + 1 - a) * (1 / (1 - z))
HGM_Arr b, c - a, b + 1 - a, 1 / (1 - z), HGM_15
End Function
Private Function HGM_16(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
'If Abs(1 / (1 - z)) <= 1 Then HGM_16 = (b + 1 - c) * (1 - a) / (b + 1 - a) * (1 / (1 - z))
HGM_Arr b + 1 - c, 1 - a, b + 1 - a, 1 / (1 - z), HGM_16
End Function
Private Function HGM_17(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
'If Abs(z) <= 1 Then HGM_17 = (a + 1 - c) * (b + 1 - c) / (2 - c) * z
HGM_Arr a + 1 - c, b + 1 - c, 2 - c, z, HGM_17
End Function
Private Function HGM_18(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
'If Abs(z) <= 1 Then HGM_18 = (1 - a) * (1 - b) / (2 - c) * z
HGM_Arr 1 - a, 1 - b, 2 - c, z, HGM_18
End Function
Private Function HGM_19(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
'If Abs(z / (z - 1)) <= 1 Then HGM_19 = (a + 1 - c) * (1 - b) / (2 - c) * (z / (z - 1))
HGM_Arr a + 1 - c, 1 - b, 2 - c, z / (z - 1), HGM_19
End Function
Private Function HGM_20(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
'If Abs(z / (z - 1)) <= 1 Then HGM_20 = (b + 1 - c) * (1 - a) / (2 - c) * (z / (z - 1))
HGM_Arr b + 1 - c, 1 - a, 2 - c, z / (z - 1), HGM_20
End Function
Private Function HGM_21(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
'If Abs(1 - z) <= 1 Then HGM_21 = (c - a) * (c - b) / (c + 1 - a - b) * (1 - z)
HGM_Arr c - a, c - b, c + 1 - a - b, 1 - z, HGM_21
End Function
Private Function HGM_22(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
'If Abs(1 - z) <= 1 Then HGM_22 = (1 - a) * (1 - b) / (c + 1 - a - b) * (1 - z)
HGM_Arr 1 - a, 1 - b, c + 1 - a - b, 1 - z, HGM_22
End Function
Private Function HGM_23(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
'If Abs(1 - 1 / z) <= 1 Then HGM_23 = (c - a) * (1 - a) / (c + 1 - a - b) * (1 - 1 / z)
HGM_Arr c - a, 1 - a, c + 1 - a - b, 1 - 1 / z, HGM_23
End Function
Private Function HGM_24(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
'If Abs(1 - 1 / z) <= 1 Then HGM_24 = (c - b) * (1 - b) / (c + 1 - a - b) * (1 - 1 / z)
HGM_Arr c - b, 1 - b, c + 1 - a - b, 1 - 1 / z, HGM_24
End Function
Private Sub HGM_Arr(a#, b#, c#, z#, Ret)
On Error GoTo EH
ReDim Ret(1 To 14)
Ret(1) = a: Ret(2) = b: Ret(3) = c: Ret(14) = "ERR"
Dim k&
Ret(4) = 1: a = a - 1: b = b - 1: c = c - 1
For k = 1 To 10
  Ret(k + 4) = Ret(k + 3) * (a + k) * (b + k) / (c + k) * z / k
Next
EH: Ret(4) = z
End Sub

Private Function HypGeom25(a, b#, c#, z#)
'Single Fraction
'method is more successful for computing 2F1 the smaller |c| is or the closer c is to an integer.
If VarType(a) < vbInteger Then Exit Function
Dim y#, dt1 As Currency, dt0 As Currency: getTickCount dt0
Dim j%, a1#, b1#, c1#, p#
a1 = c: b1 = a * b * z: c1 = c: p = (c + a * b * z) / c
For j = 3 To 500
    a1 = (a1 + b1) * (j - 1) * (c + j - 2)
    b1 = b1 * (a + j - 2) * (b + j - 2) * z
    c1 = c1 * (j - 1) * (c + j - 2)
    y = (a1 + b1) / c1
    If y = p Then Exit For
    p = y
Next
getTickCount dt1
HypGeom25 = Array(y, (dt1 - dt0) * 10000)
End Function
Private Function HypGeom26(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
Dim y#, dt1 As Currency, dt0 As Currency: getTickCount dt0
y = HGammaPQ(c, b - a, b, c - a) * Gauss_Series(a, c - b, a - b + 1, 1 / (1 - z)) / (1 - z) ^ a + _
  HGammaPQ(c, a - b, (a), c - b) * Gauss_Series(b, c - a, b - a + 1, 1 / (1 - z)) / (1 - z) ^ b
getTickCount dt1
HypGeom26 = Array(y, (dt1 - dt0) * 10000)
End Function
Private Function HypGeom27(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
Dim y#, dt1 As Currency, dt0 As Currency: getTickCount dt0
y = HGammaPQ(c, c - a - b, c - a, c - b) * Gauss_Series(a, b, a + b - c + 1, 1 - z) + _
  HGammaPQ(c, a + b - c, (a), b) * Gauss_Series(c - a, c - b, c - a - b + 1, 1 - z) * (1 - z) ^ (c - a - b)
getTickCount dt1
HypGeom27 = Array(y, (dt1 - dt0) * 10000)
End Function
Private Function HypGeom28(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
Dim y#, dt1 As Currency, dt0 As Currency: getTickCount dt0
y = HGammaPQ(c, c - a - b, c - a, c - b) * Gauss_Series(a, a - c + 1, a + b - c + 1, 1 - 1 / z) / z ^ a + _
  HGammaPQ(c, a + b - c, (a), b) * Gauss_Series(c - a, 1 - a, c - a - b + 1, 1 - 1 / z) * z ^ (a - c) * (1 - z) ^ (c - a - b)
getTickCount dt1
HypGeom28 = Array(y, (dt1 - dt0) * 10000)
End Function
Private Function HypGeom29(a, b#, c#, z#)
If VarType(a) < vbInteger Then Exit Function
Dim y#, dt1 As Currency, dt0 As Currency: getTickCount dt0
y = HGammaPQ(c, b - a, b, c - a) * Gauss_Series(a, a - c + 1, a - b + 1, 1 / z) / -z ^ a + _
  HGammaPQ(c, a - b, (a), c - b) * Gauss_Series(b - c + 1, b, b - a + 1, 1 / z) / -z ^ b
getTickCount dt1
HypGeom29 = Array(y, (dt1 - dt0) * 10000)
End Function

Private Function HypGeom5_(a_, b#, c#, z#)
Dim x#, y#, dt1 As Currency, dt0 As Currency, _
 k&, k1#, C0#, c1#, R0#, R1#, cab#, abc#, ca#, cb#, a#
If VarType(a) < vbInteger Then Exit Function Else a = a_
getTickCount dt0
'x = Gauss_Series(c - a, c - b, 1 + (c - a - b), 1 - z) * (1 - z) ^ (c - a - b)
'y = Gauss_Series(a, b, a - c + b + 1, 1 - z)
'GC = xGamma(c, 15)
'y = ((GC * xGamma(c - a - b, 15)) / (xGamma(c - a, 15) * xGamma(c - b, 15))) * y + _
  ((GC * xGamma(a - c + b, 15)) / (xGamma(a, 15) * xGamma(b, 15))) * x
If z < 0 Then
   x = z / (z - 1)
   If c > a And b < a And b > 0 Then Swap_ a, b
   b = c - b
Else
  x = z
End If
  x = 1 - x: cb = c - b: ca = c - a
  cab = ca - b: abc = a - c + b
'  GC = HGamma(c)
'  C0 = GC * HGamma(cab) / (HGamma(ca) * HGamma(cb))
'  C1 = GC * HGamma(abc) / (HGamma(a) * HGamma(b)) * x ^ cab
'C0 = xGammaPQ(c, cab, ca, cb, 15)
'c1 = xGammaPQ(c, abc, a, b, 15) * x ^ cab
C0 = HGammaPQ(c, cab, ca, cb)
c1 = HGammaPQ(c, abc, a, b) * x ^ cab
  R0 = C0: R1 = c1
  For k = 1 To 250
    R0 = R0 * (a + k1) * (b + k1) / (k * (abc + k)) * x
    R1 = R1 * (ca + k1) * (cb + k1) / (k * (cab + k)) * x
    k1 = R0 + R1
    y = y + k1
    If Abs(k1) < Abs(y) * 1.6E-16 Then Exit For
    k1 = k
  Next k
  y = y + C0 + c1
If z < 0 Then y = y / (1 - z) ^ a_
getTickCount dt1
HypGeom5_ = Array(y, (dt1 - dt0) * 10000)
End Function
Private Function HypGeom6_(a_, b#, c#, z#)
Dim x#, y#, dt1 As Currency, dt0 As Currency, k&, k1#, A0#, r#, a#
If VarType(a) < vbInteger Then Exit Function Else a = a_
getTickCount dt0
If z < 0 Then
   x = z / (z - 1)
   If c > a And b < a And b > 0 Then Swap_ a, b
   b = c - b
Else
  x = z
End If

   A0 = 1
   If c > a And c < 2 * a And c > b And c < 2 * b Then
      A0 = (1 - x) ^ (c - a - b)
      a = c - a
      b = c - b
   End If
   y = 1
   r = 1
   For k = 1 To 250
      r = r * (a + k1) * (b + k1) / (k * (c + k1)) * x
      y = y + r
      If Abs(r) <= Abs(y) * 1.6E-16 Then Exit For
      k1 = k
   Next k
   y = A0 * y
  
If z < 0 Then y = y / (1 - z) ^ a_
getTickCount dt1
HypGeom6_ = Array(y, (dt1 - dt0) * 10000)
End Function
#End If
'compute the Gauss series
'c<> 0, -1, -2 ...
Private Function Gauss_Series#(ByVal a#, ByVal b#, ByVal c#, ByVal z#)
Dim k&, r#, s#, p#
Const kMax& = 10000
'Const TOL# = 1.6 * Ten_16
'Debug.Print a * b / c * z, z
r = 1: s = 1: a = a - 1: b = b - 1: c = c - 1
For k = 1 To kMax
    r = r * (a + k) * (b + k) / (c + k) * z / k
    s = s + r
'    If Abs(r) < TOL * Abs(s) Then Exit For
    If s = p Then Exit For
    p = s
Next k
Gauss_Series = s
'Gauss_Series = Array(s, k)
End Function
#If HperGeomTesting Then
Private Function Gauss_SeriesB#(ByVal a#, ByVal b#, ByVal c#, ByVal z#)
Const kMax& = 10000
Dim j&, j1&, s#, p#, q#
'r=zeros(2,1);
'r(1)=a*b/c;
'r(2)=(a+1)*(b+1)/2/(c+1);
'
'% Initialise A(j) as detailed in Section 4.2
'A=zeros(2,1);
'A(1)=1+z*r(1);
q = 1 + z * a * b / c
'A(2)=A(1)+z^2*a*b/c*r(2);
p = q + z ^ 2 * a * b / c * (a + 1) * (b + 1) / 2 / (c + 1)
j1 = 2
'for j=3:500
For j = 3 To kMax
'    % Update r(j) and A(j) in terms of previous values
'    r(j)=(a+j-1)*(b+j-1)/j/(c+j-1);
'    A(j)=A(j-1)+(A(j-1)-A(j-2))*r(j)*z;
  s = p + (p - q) * z * (a + j1) * (b + j1) / (c + j1) / j
  If s = p Then Exit For
  j1 = j: q = p: p = s
Next
Gauss_SeriesB = s
End Function

Private Function xHypGeomGamma(a$, b$, c$, DgMx&, Digit_Max&) As String ' z assumed to be 1
xHypGeomGamma = xSubR(c, a, DgMx)
xHypGeomGamma = xFmtStr(xDivR(xMultR(xGamma(c, DgMx), xGamma(xSubR(xHypGeomGamma, b, DgMx), DgMx), DgMx), _
  xMultR(xGamma(xHypGeomGamma, DgMx), xGamma(xSubR(c, b, DgMx), DgMx), DgMx), DgMx), Digit_Max)
End Function
Private Function xHypGeom1(a$, b$, c$, z$, DgMx&, Digit_Max&)
Dim y
''y = Gauss_Series(a, b, c, z)
y = xGauss_SeriesT(a, b, c, z, DgMx, Digit_Max)
y(0) = xFmtStr(y(0), Digit_Max)
xHypGeom1 = y
End Function
Private Function xHypGeom2(a$, b$, c$, z$, DgMx&, Digit_Max&)
Dim y, ca$
''y = Gauss_Series(c - a, c - b, c, z) * (1 - z) ^ (c - a - b)
ca = xSubR(c, a, DgMx)
y = xGauss_SeriesT(ca, xSubR(c, b, DgMx), c, z, DgMx, Digit_Max)
y(0) = xFmtStr(xMultR(y(0), xPow(xIncr(xNegR(z)), xSubR(ca, b, DgMx), DgMx), DgMx), Digit_Max)
xHypGeom2 = y
End Function
Private Function xHypGeom3(a$, b$, c$, z$, DgMx&, Digit_Max&)
Dim y
''y = Gauss_Series(a, c - b, c, z / (z - 1)) / (1 - z) ^ a
y = xGauss_SeriesT(a, xSubR(c, b, DgMx), c, xDivR(z, xDecr(z), DgMx), DgMx, Digit_Max)
y(0) = xFmtStr(xDivR(y(0), xPow(xIncr(xNegR(z)), a, DgMx), DgMx), Digit_Max)
xHypGeom3 = y
End Function
Private Function xHypGeom4(a$, b$, c$, z$, DgMx&, Digit_Max&)
Dim y
''y = Gauss_Series(c - a, b, c, z / (z - 1)) / (1 - z) ^ b
y = xGauss_SeriesT(xSubR(c, a, DgMx), b, c, xDivR(z, xDecr(z), DgMx), DgMx, Digit_Max)
y(0) = xFmtStr(xDivR(y(0), xPow(xIncr(xNegR(z)), b, DgMx), DgMx), Digit_Max)
xHypGeom4 = y
End Function
Private Function xHypGeom5(a$, b$, c$, z$, DgMx&, Digit_Max&)
Dim y
''y = Gauss_Series(a, b, a + b + 1 - c, 1 - z)
y = xGauss_SeriesT(a, b, xSubR(xAddR(a, xIncr(b), DgMx), c, DgMx), xIncr(xNegR(z)), DgMx, Digit_Max)
y(0) = xFmtStr(y(0), Digit_Max)
xHypGeom5 = y
End Function
Private Function xHypGeom6(a$, b$, c$, z$, DgMx&, Digit_Max&)
Dim y
''y = Gauss_Series(a + 1 - c, b + 1 - c, a + b + 1 - c, 1 - z) * z ^ (1 - c)
y = xGauss_SeriesT(xSubR(xIncr(a), c, DgMx), xSubR(xIncr(b), c, DgMx), xSubR(xAddR(a, xIncr(b), DgMx), c, DgMx), xIncr(xNegR(z)), DgMx, Digit_Max)
y(0) = xFmtStr(xMultR(y(0), xPow(z, xIncr(xNegR(c)), DgMx), DgMx), Digit_Max)
xHypGeom6 = y
End Function
Private Function xHypGeom7(a$, b$, c$, z$, DgMx&, Digit_Max&)
Dim y
''y = Gauss_Series(a, a + 1 - c, a + b + 1 - c, 1 - 1 / z) / z ^ a
y = xGauss_SeriesT(a, xSubR(xIncr(a), c, DgMx), xSubR(xAddR(a, xIncr(b), DgMx), c, DgMx), xIncr(xNegR(xInvR(z, DgMx))), DgMx, Digit_Max)
y(0) = xFmtStr(xDivR(y(0), xPow(z, a, DgMx), DgMx), Digit_Max)
xHypGeom7 = y
End Function
Private Function xHypGeom8(a$, b$, c$, z$, DgMx&, Digit_Max&)
Dim y
''y = Gauss_Series(b + 1 - c, b, a + b + 1 - c, 1 - 1 / z) / z ^ b
y = xGauss_SeriesT(xSubR(xIncr(b), c, DgMx), b, xSubR(xAddR(a, xIncr(b), DgMx), c, DgMx), xIncr(xNegR(xInvR(z, DgMx))), DgMx, Digit_Max)
y(0) = xFmtStr(xDivR(y(0), xPow(z, b, DgMx), DgMx), Digit_Max)
xHypGeom8 = y
End Function
Private Function xHypGeom9(a$, b$, c$, z$, DgMx&, Digit_Max&)
Dim y
''y = Gauss_Series(a, a + 1 - c, a + 1 - b, 1 / z) / -z ^ a
y = xGauss_SeriesT(a, xSubR(xIncr(a), c, DgMx), xSubR(xIncr(a), b, DgMx), xInvR(z, DgMx), DgMx, Digit_Max)
y(0) = xFmtStr(xDivR(y(0), xPow(xNegR(z), a, DgMx), DgMx), Digit_Max)
xHypGeom9 = y
End Function
Private Function xHypGeom10(a$, b$, c$, z$, DgMx&, Digit_Max&)
Dim y
''y = Gauss_Series(1 - b, c - b, a + 1 - b, 1 / z) * -z ^ (b - c) * (1 - z) ^ (c - a - b)
y = xGauss_SeriesT(xIncr(xNegR(b)), xSubR(c, b, DgMx), xSubR(xIncr(a), b, DgMx), xInvR(z, DgMx), DgMx, Digit_Max)
y(0) = xFmtStr(xMultR(xMultR(y(0), xPow(xNegR(z), xSubR(b, c, DgMx), DgMx), DgMx), _
  xPow(xIncr(xNegR(z)), xSubR(xSubR(c, a, DgMx), b, DgMx), DgMx), DgMx), Digit_Max)
xHypGeom10 = y
End Function
Private Function xHypGeom11(a$, b$, c$, z$, DgMx&, Digit_Max&)
Dim y, inz$
''y = Gauss_Series(a, c - b, a + 1 - b, 1 / (1 - z)) / (1 - z) ^ a
inz = xIncr(xNegR(z))
y = xGauss_SeriesT(a, xSubR(c, b, DgMx), xSubR(xIncr(a), b, DgMx), xInvR(inz, DgMx), DgMx, Digit_Max)
y(0) = xFmtStr(xDivR(y(0), xPow(inz, a, DgMx), DgMx), Digit_Max)
xHypGeom11 = y
End Function
Private Function xHypGeom12(a$, b$, c$, z$, DgMx&, Digit_Max&)
Dim y
''y = Gauss_Series(a + 1 - c, 1 - b, a + 1 - b, 1 / (1 - z)) * -z ^ (1 - c) * (1 - z) ^ (c - a - 1)
y = xGauss_SeriesT(xSubR(xIncr(a), c, DgMx), xIncr(xNegR(b)), xSubR(xIncr(a), b, DgMx), xInvR(xIncr(xNegR(z)), DgMx), DgMx, Digit_Max)
y(0) = xFmtStr(xMultR(xMultR(y(0), xPow(xIncr(xNegR(z)), xSubR(c, xDecr(a), DgMx), DgMx), DgMx), xPow(xNegR(z), xIncr(xNegR(c)), DgMx), DgMx), Digit_Max)
xHypGeom12 = y
End Function
Private Function xHypGeom13(a$, b$, c$, z$, DgMx&, Digit_Max&)
Dim y
''y = Gauss_Series(b + 1 - c, b, b + 1 - a, 1 / z) / -z ^ b
y = xGauss_SeriesT(xSubR(xIncr(b), c, DgMx), b, xSubR(xIncr(b), a, DgMx), xInvR(z, DgMx), DgMx, Digit_Max)
y(0) = xFmtStr(xDivR(y(0), xPow(xNegR(z), b, DgMx), DgMx), Digit_Max)
xHypGeom13 = y
End Function
Private Function xHypGeom14(a$, b$, c$, z$, DgMx&, Digit_Max&)
Dim y
''y = Gauss_Series(1 - a, c - a, b + 1 - a, 1 / z) * -z ^ (a - c) * (1 - z) ^ (c - a - b)
y = xGauss_SeriesT(xIncr(xNegR(a)), xSubR(c, a, DgMx), xSubR(xIncr(b), a, DgMx), xInvR(z, DgMx), DgMx, Digit_Max)
y(0) = xFmtStr(xMultR(xMultR(y(0), xPow(xNegR(z), xSubR(a, c, DgMx), DgMx), DgMx), xPow(xIncr(xNegR(z)), xSubR(xSubR(c, a, DgMx), b, DgMx), DgMx), DgMx), Digit_Max)
xHypGeom14 = y
End Function
Private Function xHypGeom15(a$, b$, c$, z$, DgMx&, Digit_Max&)
Dim y
''y = Gauss_Series(b, c - a, b + 1 - a, 1 / (1 - z)) / (1 - z) ^ b
y = xGauss_SeriesT(b, xSubR(c, a, DgMx), xSubR(xIncr(b), a, DgMx), xInvR(xIncr(xNegR(z)), DgMx), DgMx, Digit_Max)
y(0) = xFmtStr(xDivR(y(0), xPow(xIncr(xNegR(z)), b, DgMx), DgMx), Digit_Max)
xHypGeom15 = y
End Function
Private Function xHypGeom16(a$, b$, c$, z$, DgMx&, Digit_Max&)
Dim y
''y = Gauss_Series(b + 1 - c, 1 - a, b + 1 - a, 1 / (1 - z)) * -z ^ (1 - c) * (1 - z) ^ (c - b - 1)
y = xGauss_SeriesT(xSubR(xIncr(b), c, DgMx), xIncr(xNegR(a)), xSubR(xIncr(b), a, DgMx), xInvR(xIncr(xNegR(z)), DgMx), DgMx, Digit_Max)
y(0) = xFmtStr(xMultR(xMultR(y(0), xPow(xNegR(z), xIncr(xNegR(c)), DgMx), DgMx), xPow(xIncr(xNegR(z)), xSubR(c, xDecr(b), DgMx), DgMx), DgMx), Digit_Max)
xHypGeom16 = y
End Function
Private Function xHypGeom17(a$, b$, c$, z$, DgMx&, Digit_Max&)
Dim y
''y = Gauss_Series(a + 1 - c, b + 1 - c, 2 - c, z) * z ^ (1 - c)
y = xGauss_SeriesT(xSubR(xIncr(a), c, DgMx), xSubR(xIncr(b), c, DgMx), xSubR(2, c, DgMx), z, DgMx, Digit_Max)
y(0) = xFmtStr(xMultR(y(0), xPow(z, xIncr(xNegR(c)), DgMx), DgMx), Digit_Max)
xHypGeom17 = y
End Function
Private Function xHypGeom18(a$, b$, c$, z$, DgMx&, Digit_Max&)
Dim y
'y = Gauss_Series(1 - a, 1 - b, 2 - c, z) * z ^ (1 - c) * (1 - z) ^ (c - a - b)
y = xGauss_SeriesT(xIncr(xNegR(a)), xIncr(xNegR(b)), xSubR(2, c, DgMx), z, DgMx, Digit_Max)
y(0) = xFmtStr(xMultR(xMultR(y(0), xPow(z, xIncr(xNegR(c)), DgMx), DgMx), xPow(xIncr(xNegR(z)), xSubR(xSubR(c, a, DgMx), b, DgMx), DgMx), DgMx), Digit_Max)
xHypGeom18 = y
End Function
Private Function xHypGeom19(a$, b$, c$, z$, DgMx&, Digit_Max&)
Dim y
''y = Gauss_Series(a + 1 - c, 1 - b, 2 - c, z / (z - 1)) * z ^ (1 - c) * (1 - z) ^ (c - a - 1)
y = xGauss_SeriesT(xSubR(xIncr(a), c, DgMx), xIncr(xNegR(b)), xSubR(2, c, DgMx), xDivR(z, xDecr(z), DgMx), DgMx, Digit_Max)
y(0) = xFmtStr(xMultR(xMultR(y(0), xPow(z, xIncr(xNegR(c)), DgMx), DgMx), xPow(xIncr(xNegR(z)), xSubR(c, xDecr(a), DgMx), DgMx), DgMx), Digit_Max)
xHypGeom19 = y
End Function
Private Function xHypGeom20(a$, b$, c$, z$, DgMx&, Digit_Max&)
Dim y
''y = Gauss_Series(b + 1 - c, 1 - a, 2 - c, z / (z - 1)) * z ^ (1 - c) * (1 - z) ^ (c - b - 1)
y = xGauss_SeriesT(xSubR(xIncr(b), c, DgMx), xIncr(xNegR(a)), xSubR(2, c, DgMx), xDivR(z, xDecr(z), DgMx), DgMx, Digit_Max)
y(0) = xFmtStr(xMultR(xMultR(y(0), xPow(z, xIncr(xNegR(c)), DgMx), DgMx), xPow(xIncr(xNegR(z)), xSubR(c, xDecr(b), DgMx), DgMx), DgMx), Digit_Max)
xHypGeom20 = y
End Function
Private Function xHypGeom21(a$, b$, c$, z$, DgMx&, Digit_Max&)
Dim y
''y = Gauss_Series(c - a, c - b, c + 1 - a - b, 1 - z) * (1 - z) ^ (c - a - b)
y = xGauss_SeriesT(xSubR(c, a, DgMx), xSubR(c, b, DgMx), xSubR(xSubR(xIncr(c), a, DgMx), b, DgMx), xIncr(xNegR(z)), DgMx, Digit_Max)
y(0) = xFmtStr(xMultR(y(0), xPow(xIncr(xNegR(z)), xSubR(xSubR(c, a, DgMx), b, DgMx), DgMx), DgMx), Digit_Max)
xHypGeom21 = y
End Function
Private Function xHypGeom22(a$, b$, c$, z$, DgMx&, Digit_Max&)
Dim y
''y = Gauss_Series(1 - a, 1 - b, c + 1 - a - b, 1 - z) * (1 - z) ^ (c - a - b) * z ^ (1 - c)
y = xGauss_SeriesT(xIncr(xNegR(a)), xIncr(xNegR(b)), xSubR(xSubR(xIncr(c), a, DgMx), b, DgMx), xIncr(xNegR(z)), DgMx, Digit_Max)
y(0) = xFmtStr(xMultR(xMultR(y(0), xPow(xIncr(xNegR(z)), xSubR(xSubR(c, a, DgMx), b, DgMx), DgMx), DgMx), xPow(z, xIncr(xNegR(c)), DgMx), DgMx), Digit_Max)
xHypGeom22 = y
End Function
Private Function xHypGeom23(a$, b$, c$, z$, DgMx&, Digit_Max&)
Dim y
''y = Gauss_Series(c - a, 1 - a, c + 1 - a - b, 1 - 1 / z) * (1 - z) ^ (c - a - b) * z ^ (a - c)
y = xGauss_SeriesT(xSubR(c, a, DgMx), xIncr(xNegR(a)), xSubR(xSubR(xIncr(c), a, DgMx), b, DgMx), xIncr(xNegR(xInvR(z, DgMx))), DgMx, Digit_Max)
y(0) = xFmtStr(xMultR(xMultR(y(0), xPow(xIncr(xNegR(z)), xSubR(xSubR(c, a, DgMx), b, DgMx), DgMx), DgMx), xPow(z, xSubR(a, c, DgMx), DgMx), DgMx), Digit_Max)
xHypGeom23 = y
End Function
Private Function xHypGeom24(a$, b$, c$, z$, DgMx&, Digit_Max&)
Dim y
''y = Gauss_Series(c - b, 1 - b, c + 1 - a - b, 1 - 1 / z) * (1 - z) ^ (c - a - b) * z ^ (b - c)
y = xGauss_SeriesT(xSubR(c, b, DgMx), xIncr(xNegR(b)), xSubR(xSubR(xIncr(c), a, DgMx), b, DgMx), xIncr(xNegR(xInvR(z, DgMx))), DgMx, Digit_Max)
y(0) = xFmtStr(xMultR(xMultR(y(0), xPow(xIncr(xNegR(z)), xSubR(xSubR(c, a, DgMx), b, DgMx), DgMx), DgMx), xPow(z, xSubR(b, c, DgMx), DgMx), DgMx), Digit_Max)
xHypGeom24 = y
End Function

Private Function xGauss_SeriesT(a$, b$, c$, z$, DgMx&, Digit_Max&)
Dim k&, r$, s$, ps$, MatchDgts#, k1&, PrevMD#
r = vbStr1: s = r
Do: k1 = k: k = k + 1
  r = xDivR(xMultR(xDivR(xMultR(xMultR(r, xAddR(a, k1, DgMx), DgMx), xAddR(b, k1, DgMx), _
    DgMx), xAddR(c, k1, DgMx), DgMx), z, DgMx), k, DgMx)
  ps = s: s = xAddR(s, r, DgMx)
  PrevMD = MatchDgts: MatchDgts = fDgMat(s, ps, DgMx)
  If k > 1000 Then Exit Do
  If k > 100 Then If PrevMD > 1 Then If MatchDgts - PrevMD < 0.005 Then Exit Do
Loop While MatchDgts < Digit_Max
xGauss_SeriesT = Array(s, k)
End Function

Private Function xHypGeom25(a$, b$, c$, z$, DgMx&, Digit_Max&)
'Single Fraction
'method is more successful for computing 2F1 the smaller |c| is or the closer c is to an integer.
Dim y$, j&, a1$, b1$, c1$, p$, j1&, j2&
a1 = c: b1 = xProd(Array(a, b, z), DgMx): c1 = c
p = xDiv(xAddR(a1, b1, DgMx), c1, Digit_Max)
For j = 3 To 1000
  j1 = j - 1: j2 = j - 2
    a1 = xProd(Array(xAddR(a1, b1, DgMx), j1, xAddR(c, j2, DgMx)), DgMx)
    b1 = xProd(Array(b1, xAddR(a, j2, DgMx), xAddR(b, j2, DgMx), z), DgMx)
    c1 = xProd(Array(c1, j1, xAddR(c, j2, DgMx)), DgMx)
    y = xDiv(xAddR(a1, b1, DgMx), c1, Digit_Max)
    If y = p Then Exit For
    p = y
Next
xHypGeom25 = Array(y, j)
End Function
Private Function xHypGeom26(a$, b$, c$, z$, DgMx&, Digit_Max&)
Dim x, y, ca$, cb$, ab$, ba$, z1$, z2$
ca = xSubR(c, a, DgMx): cb = xSubR(c, b, DgMx): ab = xSubR(a, b, DgMx): ba = xSubR(b, a, DgMx)
z1 = xIncr(xNegR(z)): z2 = xInvR(z1, DgMx)
'y = HGammaPQ(c, b - a, b, c - a) * Gauss_Series(a, c - b, a - b + 1, 1 / (1 - z)) / (1 - z) ^ a + _
  HGammaPQ(c, a - b, (a), c - b) * Gauss_Series(b, c - a, b - a + 1, 1 / (1 - z)) / (1 - z) ^ b
x = xGauss_SeriesT(a, cb, xIncr(ab), z2, DgMx, Digit_Max)
x(0) = xDivR(x(0), xPow(z1, a, DgMx), DgMx)
y = xGauss_SeriesT(b, ca, xIncr(ba), z2, DgMx, Digit_Max)
y(0) = xDivR(y(0), xPow(z1, b, DgMx), DgMx)
y(0) = xMultR(y(0), xGammaPQ(c, ab, a, cb, DgMx), DgMx)
y(0) = xFmtStr(xAddR(y(0), xMultR(x(0), xGammaPQ(c, ba, b, ca, DgMx), DgMx), DgMx), Digit_Max)
y(1) = max_(y(1), x(1))
xHypGeom26 = y
End Function
Private Function xHypGeom27(a$, b$, c$, z$, DgMx&, Digit_Max&)
Dim x, y, ca$, cb$, cab$, abc$, z1$
z1 = xIncr(xNegR(z))
ca = xSubR(c, a, DgMx): cb = xSubR(c, b, DgMx): cab = xSubR(ca, b, DgMx): abc = xAddR(a, xSubR(b, c, DgMx), DgMx)
'y = HGammaPQ(c, c - a - b, c - a, c - b) * Gauss_Series(a, b, a + b - c + 1, 1 - z) + _
  HGammaPQ(c, a + b - c, (a), b) * Gauss_Series(c - a, c - b, c - a - b + 1, 1 - z) * (1 - z) ^ (c - a - b)
x = xGauss_SeriesT(a, b, xIncr(abc), z1, DgMx, Digit_Max)
y = xGauss_SeriesT(ca, cb, xIncr(cab), z1, DgMx, Digit_Max)
y(0) = xProd(Array(y(0), xPow(z1, cab, DgMx), xGammaPQ(c, abc, a, b, DgMx)), DgMx)
y(0) = xFmtStr(xAddR(y(0), xMultR(x(0), xGammaPQ(c, cab, ca, cb, DgMx), DgMx), DgMx), Digit_Max)
y(1) = max_(y(1), x(1))
xHypGeom27 = y
End Function
Private Function xHypGeom28(a$, b$, c$, z$, DgMx&, Digit_Max&)
Dim x, y, ca$, cb$, cab$, abc$, z1$
z1 = xIncr(xNegR(xInvR(z, DgMx)))
ca = xSubR(c, a, DgMx): cb = xSubR(c, b, DgMx): cab = xSubR(ca, b, DgMx): abc = xAddR(a, xSubR(b, c, DgMx), DgMx)
'y = HGammaPQ(c, c - a - b, c - a, c - b) * Gauss_Series(a, a - c + 1, a + b - c + 1, 1 - 1 / z) / z ^ a + _
  HGammaPQ(c, a + b - c, (a), b) * Gauss_Series(c - a, 1 - a, c - a - b + 1, 1 - 1 / z) * z ^ (a - c) * (1 - z) ^ (c - a - b)
x = xGauss_SeriesT(a, xSubR(a, xIncr(c), DgMx), xIncr(abc), z1, DgMx, Digit_Max)
x(0) = xMultR(xDivR(x(0), xPow(z, a, DgMx), DgMx), xGammaPQ(c, cab, ca, cb, DgMx), DgMx)
y = xGauss_SeriesT(ca, xIncr(xNegR(a)), xIncr(cab), z1, DgMx, Digit_Max)
y(0) = xProd(Array(y(0), xGammaPQ(c, abc, a, b, DgMx), xPow(z, xSubR(a, c, DgMx), DgMx), xPow(xIncr(xNegR(z)), cab, DgMx)), DgMx)
y(0) = xFmtStr(xAddR(y(0), x(0), DgMx), Digit_Max)
y(1) = max_(y(1), x(1))
xHypGeom28 = y
End Function
Private Function xHypGeom29(a$, b$, c$, z$, DgMx&, Digit_Max&)
Dim x, y, z1$
z1 = xInvR(z, DgMx)
'y = HGammaPQ(c, b - a, b, c - a) * Gauss_Series(a, a - c + 1, a - b + 1, 1 / z) / -z ^ a + _
  HGammaPQ(c, a - b, (a), c - b) * Gauss_Series(b - c + 1, b, b - a + 1, 1 / z) / -z ^ b
x = xGauss_SeriesT(a, xSubR(a, xIncr(c), DgMx), xSubR(a, xIncr(b), DgMx), z1, DgMx, Digit_Max)
x(0) = xMultR(xDivR(x(0), xPow(xNegR(z), a, DgMx), DgMx), xGammaPQ(c, xSubR(b, a, DgMx), b, xSubR(c, a, DgMx), DgMx), DgMx)
y = xGauss_SeriesT(xSubR(b, xIncr(c), DgMx), b, xSubR(b, xIncr(a), DgMx), z1, DgMx, Digit_Max)
y(0) = xMultR(xDivR(y(0), xPow(xNegR(z), b, DgMx), DgMx), xGammaPQ(c, xSubR(a, b, DgMx), a, xSubR(c, b, DgMx), DgMx), DgMx)
y(0) = xFmtStr(xAddR(y(0), x(0), DgMx), Digit_Max)
y(1) = max_(y(1), x(1))
xHypGeom29 = y
End Function
#End If

Private Function xGauss_Series(a$, b$, c$, x$, DgMx&, Digit_Max, ConvDetCnt&, _
  Tolerance#, Force_NUMBER_ret As Boolean) As String
Dim k&, r$, s$, ps$, MatchDgts#, k1&, PrevMD#
r = vbStr1: s = r
Do: k1 = k: k = k + 1
  r = xDivR(xMultR(xDivR(xMultR(xMultR(r, xAddR(a, k1, DgMx), DgMx), xAddR(b, k1, DgMx), _
    DgMx), xAddR(c, k1, DgMx), DgMx), x, DgMx), k, DgMx)
  ps = s: s = xAddR(s, r, DgMx)
  MatchDgts = fDgMat(s, ps, DgMx)
  If k > ConvDetCnt Then
    If MatchDgts - PrevMD < Tolerance Then
      If Force_NUMBER_ret And MatchDgts > 1 Then
        Digit_Max = Int(MatchDgts + 1): Exit Do
      Else
        xGauss_Series = "Convergence Detection Failure: " _
        & "IterCnt = " & k & ": Improvement = " & (MatchDgts - PrevMD) & _
        ": Value= " & xFmtStr(s, Digit_Max) & _
        ": PrevValue= " & xFmtStr(ps, Digit_Max): Exit Function
      End If
    End If
    PrevMD = MatchDgts
  End If
Loop While MatchDgts < Digit_Max
xGauss_Series = s
End Function

Function xHypGeom(a, b, c, x, Optional Digit_Max, Optional ConvDetCnt& = 5000, _
  Optional Tolerance# = 0.05, Optional Force_NUMBER_ret As Boolean) As String
Attribute xHypGeom.VB_Description = "Hypergeometric function\nConvDetCnt default=5000, Tolerance default=0.05\n[Force_NUMBER_ret] returns current sum instead of error message. Default=FALSE"
Attribute xHypGeom.VB_HelpID = 260
Attribute xHypGeom.VB_ProcData.VB_Invoke_Func = " \n14"
'Python MpMath equiv hyp2f1
Dim a_$, b_$, c_$, x_$
Dim U1$, U2$, y$, DgMx&
SetDgMx DgMx, Digit_Max
'check domain c <> 0,-1,-2 ...
'If xCompZ(c) <= 0 Then If xIsInteger(c) Then ErrRaise: Exit Function
If ConvDetCnt > 2000000 Then ConvDetCnt = 2000000
b_ = dCStr_(b): a_ = dCStr_(a): c_ = dCStr_(c)
If xCompZ(x) < 0 Then
  x_ = xDivR(x, xDecr(x), DgMx)
  U1 = xIncr(xDivR(xSubR(b_, a_, DgMx), c_, DgMx))
  U2 = xIncr(xDivR(xSubR(a_, b_, DgMx), c_, DgMx))
  If xComp(U1, U2) < 0 Then
    a_ = xSubR(c_, a_, DgMx): U1 = b_
  Else
    b_ = xSubR(c_, b_, DgMx): U1 = a_
  End If
  y = xGauss_Series(a_, b_, c_, x_, DgMx, Digit_Max, ConvDetCnt, Tolerance, Force_NUMBER_ret)
  If Not CBool(xIsNumeric(y)) Then xHypGeom = y: Exit Function
  y = xDivR(y, xPow(xIncr(xNegR(x)), U1, DgMx), DgMx)
Else
  If xComp1(x) = 0 Then
    a_ = xSubR(c_, a_, DgMx)
    y = xDivR(xMultR(xGamma(c_, DgMx), xGamma(xSubR(a_, b_, DgMx), DgMx), DgMx), _
      xMultR(xGamma(a_, DgMx), xGamma(xSubR(c_, b_, DgMx), DgMx), DgMx), DgMx)
'  ElseIf xCompZ(c) > 0 Then
'    y = xGauss_Series(a_, b_, c_, dCStr_(x), DgMx, Digit_Max, ConvDetCnt, Tolerance, Force_NUMBER_ret)
'    If Not CBool(xIsNumeric(y)) Then xHypGeom = y: Exit Function
  Else
    U2 = xSubR(c_, a_, DgMx * 1.5)
    U1 = xSubR(U2, b_, DgMx * 1.5)
    If xCompZ(U1) > 0 Then
      y = xGauss_Series(a_, b_, c_, dCStr_(x), DgMx, Digit_Max, ConvDetCnt, Tolerance, Force_NUMBER_ret)
      If Not CBool(xIsNumeric(y)) Then xHypGeom = y: Exit Function
    Else
      DgMx = DgMx * 1.5
      y = xGauss_Series(U2, xSubR(c_, b_, DgMx), c_, dCStr_(x), DgMx, Digit_Max, ConvDetCnt, Tolerance, Force_NUMBER_ret)
      If Not CBool(xIsNumeric(y)) Then xHypGeom = y: Exit Function
      y = xMultR(y, xPow(xIncr(xNegR(x)), U1, DgMx), DgMx)
    End If
  End If
End If
xHypGeom = xFmtStr(y, Digit_Max)
End Function

'spherical bessel function of 2nd kind yn
Function BesselSphY(x, Optional n)
Attribute BesselSphY.VB_Description = "Spherical Bessel function of 2nd kind Yn"
Attribute BesselSphY.VB_HelpID = 401
Attribute BesselSphY.VB_ProcData.VB_Invoke_Func = " \n14"
Dim sy(), dY(), RC
    If IsMissing(n) Then n = 0
    Call SPHY(n, x, sy, dY, RC)
    If RC < 0 Then GoTo Error_Handler
    BesselSphY = sy(n)
Exit Function
Error_Handler:
    BesselSphY = "?"
End Function

'spherical bessel function of 1st kind jn
Function BesselSphJ(x, Optional n)
Attribute BesselSphJ.VB_Description = "Spherical Bessel function of 1st kind Jn"
Attribute BesselSphJ.VB_HelpID = 401
Attribute BesselSphJ.VB_ProcData.VB_Invoke_Func = " \n14"
Dim SJ(), dj(), NM
    If IsMissing(n) Then n = 0
    Call SPHJ(n, x, NM, SJ, dj)
    If NM < n Then GoTo Error_Handler
    BesselSphJ = SJ(n)
Exit Function
Error_Handler:
    BesselSphJ = "?"
End Function

'*****************************************************************************
'Derived from FORTRAN-77 routines for computation of Special Functions
'written  by Shanjie Zhang and Jianming Jin.
'*****************************************************************************

Sub SPHY(n, x, sy, dY, RC)
'       ======================================================
'       Purpose: Compute spherical Bessel functions yn(x) and
'                their derivatives
'       Input :  x --- Argument of yn(x) ( x > 0 )
'                n --- Order of yn(x) ( n = 0,1,2.. )
'       Output:  SY(n) --- yn(x)
'                DY(n) --- yn'(x)
'       rc: return code 0 if all OK, -1 if failed
'       ======================================================
Dim k&, f0, f1, f
    ReDim sy(n), dY(n)
    n = CInt(n)
    x = CDbl_(x)
    RC = 0
    If x < 1E-60 Then
       For k = 0 To n
          sy(k) = -1E+300
          dY(k) = 1E+300
       Next k
       Exit Sub
    End If
    sy(0) = -Cos(x) / x
    If n > 0 Then
        sy(1) = (sy(0) - Sin(x)) / x
        f0 = sy(0)
        f1 = sy(1)
        For k = 2 To n
           f = (2 * k - 1) * f1 / x - f0
           sy(k) = f
           If Abs(f) >= 1E+300 And k < n Then
                RC = -1  'overflow
                Exit Sub
           End If
           f0 = f1
           f1 = f
        Next k
    End If
    dY(0) = (Sin(x) + Cos(x) / x) / x
    For k = 1 To n
       dY(k) = sy(k - 1) - (k + 1) * sy(k) / x
    Next k
End Sub

Sub SPHJ(n, x, NM, SJ, dj)
'       =======================================================
'       Purpose: Compute spherical Bessel functions jn(x) and
'                their derivatives
'       Input :  x --- Argument of jn(x)
'                n --- Order of jn(x)  ( n = 0,1,\xfa\xfa\xfa )
'       Output:  SJ(n) --- jn(x)
'                DJ(n) --- jn'(x)
'                NM --- Highest order computed
'       Routines called:
'                MSTA1 and MSTA2 for computing the starting
'                point for backward recurrence
'       =======================================================
    ReDim SJ(n), dj(n)
    Dim k&, sa, sb, m, f0, f1, f, CS
      n = CInt(n)
      x = CDbl_(x)
    If x = 0 Then Exit Sub
        NM = n
        If Abs(x) = 1E-100 Then
           For k = 0 To n
              SJ(k) = 0#
              dj(k) = 0#
           Next k
           SJ(0) = 1#
           dj(1) = 1# / 3
           Exit Sub
        End If
        SJ(0) = Sin(x) / x
        If n > 0 Then
            SJ(1) = (SJ(0) - Cos(x)) / x
            If n >= 2 Then
               sa = SJ(0)
               sb = SJ(1)
               m = MSTA1(x, 200)
               If m < n Then
                  NM = m
               Else
                  m = MSTA2(x, n, 15)
               End If
               f0 = 0#
               f1 = 1# - 100
               For k = m To 0 Step -1
                  f = (2# * k + 3#) * f1 / x - f0
                  If k <= NM Then SJ(k) = f
                  f0 = f1
                  f1 = f
               Next k
               If Abs(sa) > Abs(sb) Then CS = sa / f
               If Abs(sa) <= Abs(sb) Then CS = sb / f0
               For k = 0 To NM
                  SJ(k) = CS * SJ(k)
               Next k
            End If
        End If
        dj(0) = (Cos(x) - Sin(x) / x) / x
        For k = 1 To NM
           dj(k) = SJ(k - 1) - (k + 1#) * SJ(k) / x
        Next k
End Sub


'*****************************************************************************
'FORTRAN routines for computation of Special Functions
'written in FORTRAN-77 by Shanjie Zhang and Jianming Jin.
'All these programs and subroutines are copyrighted.
'However, authors give kindly permission to incorporate any of these
'routines into other programs providing that the copyright is acknowledged.
'We have modified only minimal parts for adapting to VBA.

Sub JY01A(x, BJ0, DJ0, BJ1, DJ1, BY0, DY0, BY1, DY1)
'=======================================================
' Purpose: Compute Bessel functions J0(x), J1(x), Y0(x),
'         Y1(x), and their derivatives
' Input :  x   --- Argument of Jn(x) & Yn(x) ( x \xf2 0 )
' Output:  BJ0 --- J0(x)
'          DJ0 --- J0'(x)
'          BJ1 --- J1(x)
'          DJ1 --- J1'(x)
'          BY0 --- Y0(x)
'          DY0 --- Y0'(x)
'          BY1 --- Y1(x)
'          DY1 --- Y1'(x)
'=======================================================
'by Shanjie Zhang and Jianming Jin, 2001
Dim rp2#, x2#, r#, k%, EC#, cs0#, w0#, R0#, cs1#, w1#, R1#
Dim k0%, t1#, p0#, q0#, i%, CU#, t2#, p1#, q1#, a, b, a1, b1
rp2 = 0.63661977236758
x2 = x * x
If x = 0# Then
   BJ0 = 1#
   BJ1 = 0#
   DJ0 = 0#
   DJ1 = 0.5
   BY0 = -1E+300
   BY1 = -1E+300
   DY0 = 1E+300
   DY1 = 1E+300
   Exit Sub  'fix bug 29.10.06 for x=0
End If
If x <= 12# Then
   BJ0 = 1#
   r = 1#
   For k = 1 To 30
      r = -0.25 * r * x2 / (k * k)
      BJ0 = BJ0 + r
      If Abs(r) < Abs(BJ0) * 0.000000000000001 Then Exit For
   Next
   BJ1 = 1#
   r = 1#
   For k = 1 To 30
      r = -0.25 * r * x2 / (k * (k + 1#))
      BJ1 = BJ1 + r
      If Abs(r) < Abs(BJ1) * 0.000000000000001 Then Exit For
   Next
   BJ1 = 0.5 * x * BJ1
   EC = Log(x / 2#) + dEu_
   cs0 = 0#
   w0 = 0#
   R0 = 1#
   For k = 1 To 30
      w0 = w0 + 1# / k
      R0 = -0.25 * R0 / (k * k) * x2
      r = R0 * w0
      cs0 = cs0 + r
      If Abs(r) < Abs(cs0) * 0.000000000000001 Then Exit For
   Next
   BY0 = rp2 * (EC * BJ0 - cs0)
   cs1 = 1#
   w1 = 0#
   R1 = 1#
   For k = 1 To 30
      w1 = w1 + 1# / k
      R1 = -0.25 * R1 / (k * (k + 1)) * x2
      r = R1 * (2# * w1 + 1# / (k + 1#))
      cs1 = cs1 + r
      If Abs(r) < Abs(cs1) * 0.000000000000001 Then Exit For
   Next
   BY1 = rp2 * (EC * BJ1 - 1# / x - 0.25 * x * cs1)
Else
    a = Array(-0.0703125, 0.112152099609375, _
         -0.572501420974731, 6.07404200127348, _
         -110.017140269247, 3038.09051092238, _
         -118838.426256783, 6252951.4934348, _
         -425939216.504767, 36468400807.0656, _
         -3833534661393.94, 485401468685290#)
   b = Array(0.0732421875, -0.227108001708984, _
          1.72772750258446, -24.3805296995561, _
          551.335896122021, -18257.7554742932, _
          832859.304016289, -50069589.5319889, _
          3836255180.23043, -364901081884.983, _
          42189715702841#, -5.82724463156691E+15)
   a1 = Array(0.1171875, -0.144195556640625, _
          0.676592588424683, -6.88391426810995, _
          121.597891876536, -3302.27229448085, _
          127641.272646175, -6656367.71881769, _
          450278600.305039, -38338575207.4279, _
          4011838599133.2, -506056850331473#)
   b1 = Array(-0.1025390625, 0.277576446533203, _
          -1.9935317337513, 27.2488273112685, _
          -603.84407670507, 19718.3759122366, _
          -890297.876707068, 53104110.1096852, _
          -4043620325.10775, 382701134659.86, _
          -44064814178522.8, 6.0650913512227E+15)
   k0 = 12
   If x >= 35# Then k0 = 10
   If x >= 50# Then k0 = 8
   t1 = x - 0.25 * Pi_
   p0 = 1#
   q0 = -0.125 / x
   For k = 1 To k0
    i = k - 1
    p0 = p0 + a(i) * x ^ (-2 * k)
    q0 = q0 + b(i) * x ^ (-2 * k - 1)
   Next
   CU = Sqr(rp2 / x)
   BJ0 = CU * (p0 * Cos(t1) - q0 * Sin(t1))
   BY0 = CU * (p0 * Sin(t1) + q0 * Cos(t1))
   t2 = x - 0.75 * Pi_
   p1 = 1#
   q1 = 0.375 / x
   For k = 1 To k0
      i = k - 1
      p1 = p1 + a1(i) * x ^ (-2 * k)
      q1 = q1 + b1(i) * x ^ (-2 * k - 1)
   Next
   CU = Sqr(rp2 / x)
   BJ1 = CU * (p1 * Cos(t2) - q1 * Sin(t2))
   BY1 = CU * (p1 * Sin(t2) + q1 * Cos(t2))
End If
DJ0 = -BJ1
DJ1 = BJ0 - BJ1 / x
DY0 = -BY1
DY1 = BY0 - BY1 / x
End Sub


Sub JYNA(n, x, NM, BJ, dj, by, dY)
'  ==========================================================
'       Purpose: Compute Bessel functions Jn(x) & Yn(x) and
'                their derivatives
'       Input :  x --- Argument of Jn(x) & Yn(x)  ( x > 0 )
'                n --- Order of Jn(x) & Yn(x)
'       Output:  BJ(n) --- Jn(x)
'                DJ(n) --- Jn'(x)
'                BY(n) --- Yn(x)
'                DY(n) --- Yn'(x)
'                NM --- Highest order computed
'       Routines called:
'            (1) JY01A to calculate J0(x), J1(x), Y0(x) & Y1(x)
'            (2) MSTA1 and MSTA2 to calculate the starting
'                point for backward recurrence
'  =========================================================
'by Shanjie Zhang and Jianming Jin, 2001
Dim k&, BJ0#, DJ0#, BJ1#, DJ1#, BY0#, DY0#, BY1#, DY1#, BJK#, m%, f#, f0#, f1#, f2#
Dim CS#
ReDim BJ(n), by(n), dj(n), dY(n)
    NM = n
    If x < 1E-100 Then
       For k = 0 To n
          BJ(k) = 0#
          dj(k) = 0#
          by(k) = -1E+300
          dY(k) = 1E+300
       Next
       BJ(0) = 1#
       dj(1) = 0.5
       Exit Sub
    End If
    Call JY01A(x, BJ0, DJ0, BJ1, DJ1, BY0, DY0, BY1, DY1)
    BJ(0) = BJ0
    BJ(1) = BJ1
    by(0) = BY0
    by(1) = BY1
    dj(0) = DJ0
    dj(1) = DJ1
    dY(0) = DY0
    dY(1) = DY1
    If n <= 1 Then Exit Sub
    If n < Int(0.9 * x) Then
       For k = 2 To n
          BJK = 2# * (k - 1#) / x * BJ1 - BJ0
          BJ(k) = BJK
          BJ0 = BJ1
          BJ1 = BJK
      Next
    Else
       m = MSTA1(x, 200)
       If m < n Then
          NM = m
       Else
          m = MSTA2(x, n, 15)
       End If
       f2 = 0#
       f1 = 1E-100
       For k = m To 0 Step -1
          f = 2# * (k + 1#) / x * f1 - f2
          If k <= NM Then BJ(k) = f
          f2 = f1
          f1 = f
       Next
        If Abs(BJ0) > Abs(BJ1) Then
           CS = BJ0 / f
        Else
           CS = BJ1 / f2
        End If
        For k = 0 To NM
            BJ(k) = CS * BJ(k)
        Next
    End If
    
    For k = 2 To NM
       dj(k) = BJ(k - 1) - k / x * BJ(k)
    Next
    f0 = by(0)
    f1 = by(1)
    For k = 2 To NM
       f = 2# * (k - 1#) / x * f1 - f0
       by(k) = f
       f0 = f1
       f1 = f
    Next
    For k = 2 To NM
       dY(k) = by(k - 1) - k * by(k) / x
    Next
End Sub


Private Function MSTA1(x, MP) As Integer
'  ===================================================
'  Purpose: Determine the starting point for backward
'           recurrence such that the magnitude of
'           Jn(x) at that point is about 10^(-MP)
'  Input :  x     --- Argument of Jn(x)
'           MP    --- Value of magnitude
'  Output:  MSTA1 --- Starting point
' ===================================================
'by Shanjie Zhang and Jianming Jin, 2001
Dim A0#, n0#, f0#, n1#, f1#, it&, nn#, f#
A0 = Abs(x)
n0 = Int(1.1 * A0) + 1
f0 = ENVJ(n0, A0) - MP
n1 = n0 + 5
f1 = ENVJ(n1, A0) - MP
For it = 1 To 20
   nn = n1 - (n1 - n0) / (1# - f0 / f1)
   f = ENVJ(nn, A0) - MP
   If Abs(nn - n1) < 1 Then Exit For
   n0 = n1
   f0 = f1
   n1 = nn
   f1 = f
Next
MSTA1 = nn
End Function


Private Function MSTA2(x, n, MP) As Integer
' ===================================================
' Purpose: Determine the starting point for backward
'         recurrence such that all Jn(x) has MP
'         significant digits
' Input :  x  --- Argument of Jn(x)
'          n  --- Order of Jn(x)
'          MP --- Significant digit
' Output:  MSTA2 --- Starting point
' ===================================================
'by Shanjie Zhang and Jianming Jin, 2001
Dim A0#, n0#, f0#, n1#, f1#, it&, nn#, f#, HMP#, EJN#, obj#
A0 = Abs(x)
HMP = 0.5 * MP
EJN = ENVJ(n, A0)
If EJN <= HMP Then
   obj = MP
   n0 = Int(1.1 * A0) + 1 'bug for x<0.1 - VL, 2-8.2002
Else
   obj = HMP + EJN
   n0 = n
End If
f0 = ENVJ(n0, A0) - obj
n1 = n0 + 5
f1 = ENVJ(n1, A0) - obj
For it = 1 To 20
   nn = n1 - (n1 - n0) / (1# - f0 / f1)
   f = ENVJ(nn, A0) - obj
   If Abs(nn - n1) < 1 Then Exit For
   n0 = n1
   f0 = f1
   n1 = nn
   f1 = f
Next
MSTA2 = nn + 10
End Function

Private Function Log10(x)
Log10 = Log(x) / dLn10_
End Function

Private Function ENVJ(n, x)
ENVJ = 0.5 * Log10(6.28 * n) - n * Log10(1.36 * x / n)
End Function

Sub IK01A(x, BI0, DI0, BI1, DI1, BK0, DK0, BK1, DK1)
'=========================================================
'Purpose: Compute modified Bessel functions I0(x), I1(1),
'         K0(x) and K1(x), and their derivatives
'Input :  x   --- Argument ( x \xf2 0 )
'Output:  BI0 --- I0(x)
'         DI0 --- I0'(x)
'         BI1 --- I1(x)
'         DI1 --- I1'(x)
'         BK0 --- K0(x)
'         DK0 --- K0'(x)
'         BK1 --- K1(x)
'         DK1 --- K1'(x)
'=========================================================
 'by Shanjie Zhang and Jianming Jin, 2001
 Dim x2#, r#, i&, k&, a, b, k0&, ca#, xR#, ct#, w0#, ww#, a1, cb#, xR2#
 x2 = x * x
 If x = 0# Then
    BI0 = 1#
    BI1 = 0#
    BK0 = 1E+300
    BK1 = 1E+300
    DI0 = 0#
    DI1 = 0.5
    DK0 = -1E+300
    DK1 = -1E+300
    Exit Sub
 ElseIf x <= 18# Then
    BI0 = 1#
    r = 1#
    For k = 1 To 50
       r = 0.25 * r * x2 / (k * k)
       BI0 = BI0 + r
       If Abs(r / BI0) < 0.000000000000001 Then Exit For
    Next
    BI1 = 1#
    r = 1#
    For k = 1 To 50
       r = 0.25 * r * x2 / (k * (k + 1))
       BI1 = BI1 + r
       If Abs(r / BI1) < 0.000000000000001 Then Exit For
    Next
    BI1 = 0.5 * x * BI1
 Else
    a = Array(0.125, 0.0703125, _
          0.0732421875, 0.11215209960938, _
          0.22710800170898, 0.57250142097473, _
          1.7277275025845, 6.0740420012735, _
          24.380529699556, 110.01714026925, _
          551.33589612202, 3038.0905109224)
    b = Array(-0.375, -0.1171875, _
          -0.1025390625, -0.14419555664063, _
          -0.2775764465332, -0.67659258842468, _
          -1.9935317337513, -6.8839142681099, _
          -27.248827311269, -121.59789187654, _
          -603.84407670507, -3302.2722944809)
    k0 = 12
    If x >= 35# Then k0 = 9
    If x >= 50# Then k0 = 7
    ca = Exp(x) / Sqr(TPi_ * x)
    BI0 = 1#
    xR = 1# / x
    For k = 1 To k0
        i = k - 1
       BI0 = BI0 + a(i) * xR ^ k
    Next
    BI0 = ca * BI0
    BI1 = 1#
    For k = 1 To k0
        i = k - 1
       BI1 = BI1 + b(i) * xR ^ k
    Next
    BI1 = ca * BI1
 End If
 If x <= 9# Then
    ct = -(Log(x / 2#) + dEu_)
    BK0 = 0#
    w0 = 0#
    r = 1#
    For k = 1 To 50
       w0 = w0 + 1# / k
       r = 0.25 * r / (k * k) * x2
       BK0 = BK0 + r * (w0 + ct)
       If Abs((BK0 - ww) / BK0) < 0.000000000000001 Then Exit For
       ww = BK0
   Next
    BK0 = BK0 + ct
 Else
    a1 = Array(0.125, 0.2109375, _
           1.0986328125, 11.775970458984, _
           214.61706161499, 5951.1522710323, _
           233476.45606175, 12312234.987631)
    cb = 0.5 / x
    xR2 = 1# / x2
    BK0 = 1#
    For k = 1 To 8
        i = k - 1
       BK0 = BK0 + a1(i) * xR2 ^ k
    Next
    BK0 = cb * BK0 / BI0
 End If
 BK1 = (1# / x - BI1 * BK0) / BI0
 DI0 = BI1
 DI1 = BI0 - BI1 / x
 DK0 = -BK1
 DK1 = -BK0 - BK1 / x

 End Sub
 
 Sub IKNA(n, x_, NM, bi, Di, BK, DK)
' ========================================================
' Purpose: Compute modified Bessel functions In(x) and
'          Kn(x), and their derivatives
' Input:   x --- Argument of In(x) and Kn(x) ( x \xf2 0 )
'          n --- Order of In(x) and Kn(x)
' Output:  BI(n) --- In(x)
'          DI(n) --- In'(x)
'          BK(n) --- Kn(x)
'          DK(n) --- Kn'(x)
'          NM --- Highest order computed
' Routines called:
'      (1) IK01A for computing I0(x),I1(x),K0(x) & K1(x)
'      (2) MSTA1 and MSTA2 for computing the starting
'          point for backward recurrence
' ========================================================
'by Shanjie Zhang and Jianming Jin, 2001
Dim x#, k&, BI0, DI0, BI1, DI1, BK0, DK0, BK1, DK1, h0, h1, h#, m, f0, f1, f, s0#, g#, g0#, g1#
ReDim bi(n), Di(n), BK(n), DK(n)
x = CDbl_(x_)
NM = n
If x <= 1E-100 Then
   For k = 0 To n
      bi(k) = 0#
      Di(k) = 0#
      BK(k) = 1E+300
      DK(k) = -1E+300
   Next
   bi(0) = 1#
   Di(1) = 0.5
   Exit Sub
End If
Call IK01A(x, BI0, DI0, BI1, DI1, BK0, DK0, BK1, DK1)
bi(0) = BI0
bi(1) = BI1
BK(0) = BK0
BK(1) = BK1
Di(0) = DI0
Di(1) = DI1
DK(0) = DK0
DK(1) = DK1
If n <= 1 Then Exit Sub
If x > 40# And n < Int(0.25 * x) Then
   h0 = BI0
   h1 = BI1
   For k = 2 To n
     h = -2# * (k - 1#) / x * h1 + h0
     bi(k) = h
     h0 = h1
     h1 = h
   Next
Else
   m = MSTA1(x, 200)
   If m < n Then
      NM = m
   Else
      m = MSTA2(x, n, 15)
   End If
   f0 = 0#
   f1 = 1E-100
   For k = m To 0 Step -1
      f = 2# * (k + 1#) * f1 / x + f0
      If k <= NM Then bi(k) = f
      f0 = f1
      f1 = f
   Next
   s0 = BI0 / f
   For k = 0 To NM
      bi(k) = s0 * bi(k)
   Next
End If
g0 = BK0
g1 = BK1
For k = 2 To NM
   g = 2# * (k - 1#) / x * g1 + g0
   BK(k) = g
   g0 = g1
   g1 = g
Next
For k = 2 To NM
   Di(k) = bi(k - 1) - k / x * bi(k)
   DK(k) = -BK(k - 1) - k / x * BK(k)
Next
End Sub

Sub CISIA(x, Ci, sI)
'=============================================
' Purpose: Compute cosine and sine integrals
'          Si(x) and Ci(x)  ( x \xf2 0 )
' Input :  x  --- Argument of Ci(x) and Si(x)
' Output:  CI --- Ci(x)
'          SI --- Si(x)
'=============================================
'by Shanjie Zhang and Jianming Jin, 2001
Dim BJ(101), El#, EPS#, x2#, xR#, k&, m, xa#, xa1#, xa0#, xs#, xg1#, xg2#, xcs#, xss#, xF#, xg#
El = dEu_
EPS = 0.000000000000001
x2 = x * x
If x = 0# Then
   Ci = -1E+300
   sI = 0#
ElseIf x <= 16# Then
   xR = -0.25 * x2
   Ci = El + Log(x) + xR
   For k = 2 To 40
      xR = -0.5 * xR * (k - 1) / (k * k * (2 * k - 1)) * x2
      Ci = Ci + xR
      If Abs(xR) < Abs(Ci) * EPS Then Exit For
   Next
   xR = x
   sI = x
   For k = 1 To 40
      xR = -0.5 * xR * (2 * k - 1) / k / (4 * k * k + 4 * k + 1) * x2
      sI = sI + xR
      If Abs(xR) < Abs(sI) * EPS Then Exit For
   Next
ElseIf x <= 32# Then
   m = Int(47.2 + 0.82 * x)
   xa1 = 0#
   xa0 = 1E-100
   For k = m To 1 Step -1
      xa = 4# * k * xa0 / x - xa1
      BJ(k) = xa
      xa1 = xa0
      xa0 = xa
   Next
   xs = BJ(1)
   For k = 3 To m Step 2
      xs = xs + 2# * BJ(k)
   Next
   BJ(1) = BJ(1) / xs
   For k = 2 To m
      BJ(k) = BJ(k) / xs
   Next
   xR = 1#
   xg1 = BJ(1)
   For k = 2 To m
      xR = 0.25 * xR * (2# * k - 3#) ^ 2 / ((k - 1#) * (2# * k - 1#) ^ 2) * x
      xg1 = xg1 + BJ(k) * xR
   Next
   xR = 1#
   xg2 = BJ(1)
   For k = 2 To m
      xR = 0.25 * xR * (2# * k - 5#) ^ 2 / ((k - 1#) * (2# * k - 3#) ^ 2) * x
      xg2 = xg2 + BJ(k) * xR
   Next
   xcs = Cos(x / 2#)
   xss = Sin(x / 2#)
   Ci = El + Log(x) - x * xss * xg1 + 2 * xcs * xg2 - 2 * xcs * xcs
   sI = x * xcs * xg1 + 2 * xss * xg2 - Sin(x)
Else
   xR = 1#
   xF = 1#
   For k = 1 To 9
      xR = -2# * xR * k * (2 * k - 1) / x2
      xF = xF + xR
   Next
   xR = 1# / x
   xg = xR
   For k = 1 To 8
      xR = -2# * xR * (2 * k + 1) * k / x2
      xg = xg + xR
   Next
   Ci = xF * Sin(x) / x - xg * Cos(x) / x
   sI = Pi2_ - xF * Cos(x) / x - xg * Sin(x) / x
End If
End Sub

  Sub FCS(x, c, s)
' =================================================
'  Purpose: Compute Fresnel integrals C(x) and S(x)
'  Input :  x --- Argument of C(x) and S(x)
'  Output:  C --- C(x)
'           S --- S(x)
' =================================================
'by Shanjie Zhang and Jianming Jin, 2001
Dim xa#, px#, t#, t2#, r#, k&, m, su#, f#, f0#, f1#, f2#, q#, g#, t0#
   Const EPS# = 0.000000000000001
   xa = Abs(x)
   px = Pi_ * xa
   t = 0.5 * px * xa
   t2 = t * t
   If xa = 0# Then
      c = 0#
      s = 0#
   ElseIf xa < 2.5 Then
      r = xa
      c = r
      For k = 1 To 50
         r = -0.5 * r * (4# * k - 3#) / k / (2# * k - 1#) / (4# * k + 1#) * t2
         c = c + r
         If Abs(r) < Abs(c) * EPS Then Exit For
      Next
      s = xa * t / 3#
      r = s
      For k = 1 To 50
         r = -0.5 * r * (4# * k - 1#) / k / (2# * k + 1#) / (4# * k + 3#) * t2
         s = s + r
         If Abs(r) < Abs(s) * EPS Then GoTo Label40
      Next
   ElseIf xa < 4.5 Then
      m = Int(42# + 1.75 * t)
      su = 0#
      c = 0#
      s = 0#
      f1 = 0#
      f0 = 1E-100
      For k = m To 0 Step -1
         f = (2# * k + 3#) * f0 / t - f1
         If k = Int(CDbl(k / 2)) * 2 Then
            c = c + f
         Else
            s = s + f
         End If
         su = su + (2# * k + 1#) * f * f
         f1 = f0
         f0 = f
      Next
      q = Sqr(su)
      c = c * xa / q
      s = s * xa / q
   Else
      r = 1#
      f = 1#
      For k = 1 To 20
         r = -0.25 * r * (4# * k - 1#) * (4# * k - 3#) / t2
         f = f + r
      Next
      r = 1# / (px * xa)
      g = r
      For k = 1 To 12
         r = -0.25 * r * (4# * k + 1#) * (4# * k - 1#) / t2
         g = g + r
      Next
      t0 = t - Int(CDbl(t / (TPi_))) * TPi_
      c = 0.5 + (f * Sin(t0) - g * Cos(t0)) / px
      s = 0.5 - (f * Cos(t0) + g * Sin(t0)) / px
   End If
Exit Sub
Label40:
If x < 0# Then
   c = -c
   s = -s
End If

End Sub
'*****End of Library for computation of Special Functions*****

VBA Filename xTest.bas Extracted Macro
Option Explicit

Dim BadString$

Function IsDblBad(x) As Boolean
Attribute IsDblBad.VB_Description = "Test function in xTest module\nTRUE if string(s) exist that convert to the wrong double"
Attribute IsDblBad.VB_HelpID = 500
Attribute IsDblBad.VB_ProcData.VB_Invoke_Func = " \n14"
If Len(Tst4BadCDbl(GetMinString$(x))) = 0 Then
  If Len(Tst4BadCDbl(GetMaxString$(x))) <> 0 Then IsDblBad = True
End If
End Function

Function IsStrBad(x) As Boolean
Attribute IsStrBad.VB_Description = "Test function in xTest module\nTRUE if string converts to the wrong double"
Attribute IsStrBad.VB_HelpID = 500
Attribute IsStrBad.VB_ProcData.VB_Invoke_Func = " \n14"
Dim s$, vd, VT, vb, ex%, p#, n#, y#
If VarType(x) <> vbString Then Exit Function
s = x
If Asc(s) = vbKeyMinus Then Mid$(s, 1, 1) = vbStr0 's = Right$(s, Len(s) - 1)
y = CDbl_(s)
s = iFmt(s, 20)
If Mid$(s, 20, 1) <> vbStr0 Then Exit Function
ex = CInt(Right$(s, Len(s) - 21))
vd = CDec(Left$(s, 20))
vb = CDec("10000000000000000000")
VT = CDec("99999999999999999999")
If vd = vb Then
  p = CDbl(CStr(VT) & "E" & CStr(ex - 1))
  Mid$(s, 1, 20) = CStr(vd + 1)
  n = CDbl(s)
ElseIf vd = VT Then
  n = CDbl(CStr(vb) & "E" & CStr(ex + 1))
  Mid$(s, 1, 20) = CStr(vd - 1)
  p = CDbl(s)
Else
  Mid$(s, 1, 20) = CStr(vd - 1)
  p = CDbl(s)
  Mid$(s, 1, 20) = CStr(vd + 1)
  n = CDbl(s)
End If
If p > y Or y > n Then IsStrBad = True
End Function

Function SetBadString$(x)
Attribute SetBadString.VB_Description = "Test function in xTest module"
Attribute SetBadString.VB_HelpID = 500
Attribute SetBadString.VB_ProcData.VB_Invoke_Func = " \n14"
Dim Sign$, s$, vd, VT, vb, ex%, p#, r$
If VarType(x) = vbString Then s = iFmt(x, 20) Else _
  s = iFmt(GetMinString$(x), 20)
If Asc(s) = vbKeyMinus Then Sign = "-": s = Right$(s, Len(s) - 1)
If s = VbMax Then GoTo SetS
ex = CInt(Right$(s, Len(s) - 21))
vd = CDec(Left$(s, 20))
vb = CDec("10000000000000000000")
VT = CDec("99999999999999999999")
vd = vd + 20
If vd > VT Then
  vd = vb
  ex = ex + 1
  s = CStr(vd) & "E" & CStr(ex)
Else
  Mid$(s, 1, 20) = CStr(vd)
End If
SetS: BadString = Sign & s
SetBadString = xCvExp(BadString)
End Function

Function GetBadString() As String
Attribute GetBadString.VB_Description = "Test function in xTest module. No Bad Strings in 64-bit will cause infinite loop:\nhold down on Esc key to avoid having to shut down with Task Manager"
Attribute GetBadString.VB_HelpID = 500
Attribute GetBadString.VB_ProcData.VB_Invoke_Func = " \n14"
Application.Volatile
On Error GoTo EH
Dim Sign$, s$, vd, VT, vb, ex%, p#, r$, i%
If Len(BadString) = 0 Then s = iFmt(1, 20) Else s = BadString
If Asc(s) = vbKeyMinus Then Sign = "-": s = Right$(s, Len(s) - 1)
ex = CInt(Right$(s, Len(s) - 21))
vd = CDec(Left$(s, 20))
vb = CDec("10000000000000000000")
VT = CDec("99999999999999999999")
vd = vd - 10
If vd < vb Then
  vd = VT
  ex = ex - 1
  s = CStr(vd) & "E" & CStr(ex)
Else
  Mid$(s, 1, 20) = CStr(vd)
End If
TryAgain:
For i = 1 To 32766
  p = CDbl(s)
  r = s
  If vd = vb Then
    vd = VT
    ex = ex - 1
    s = CStr(vd) & "E" & CStr(ex)
  Else
    vd = vd - 1
    Mid$(s, 1, 20) = CStr(vd)
  End If
  If CDbl(s) > p Then GoTo FoundBad
Next
DoEvents
GoTo TryAgain
FoundBad:
If Mid$(s, 20, 1) = vbStr0 Then
  BadString = Sign & s
Else
  BadString = Sign & r
End If
GetBadString = xCvExp(BadString)
EH:
End Function

Function Tst4BadMM(min, max)
Attribute Tst4BadMM.VB_Description = "Test function in xTest module"
Attribute Tst4BadMM.VB_HelpID = 500
Attribute Tst4BadMM.VB_ProcData.VB_Invoke_Func = " \n14"
Dim s$
s = Tst4BadCDbl(min)
If Len(s) = 0 Then s = Tst4BadCDbl(max)
Tst4BadMM = s
End Function

Function Tst4BadCDbl(x) As String
Attribute Tst4BadCDbl.VB_Description = "Test function in xTest module\nReturn bad string if one exists, else blank"
Attribute Tst4BadCDbl.VB_HelpID = 500
Attribute Tst4BadCDbl.VB_ProcData.VB_Invoke_Func = " \n14"
On Error GoTo SetS
Dim s$, i%, vd, VT, vb, p#, Sign$, r$
s = iFmt(x, 20)
If s = "-" & vbMax343 Then GoTo SetS
If Asc(s) = vbKeyMinus Then
  Sign = "-": s = Right$(s, Len(s) - 1)
End If
vb = CDec("10000000000000000000")
VT = CDec("99999999999999999999")
vd = CDec(Mid$(s, 1, 20))
For i = 1 To 20
  If vd <> vb Then
    vd = vd - 1
    Mid$(s, 1, 20) = CStr(vd)
  Else
    vd = VT
    s = CStr(vd) & "E" & CStr(CInt(Right$(s, Len(s) - 21)) - 1)
  End If
Next
For i = 1 To 40
  p = CDbl(s)
  r = s
  If vd = VT Then
    vd = vb
    s = CStr(vd) & "E" & CStr(CInt(Right$(s, Len(s) - 21)) + 1)
  Else
    vd = vd + 1
    Mid$(s, 1, 20) = CStr(vd)
  End If
  If CDbl(s) < p Then
    If Mid$(s, 20, 1) = vbStr0 Then
      Tst4BadCDbl = xCvExp(Sign & s): Exit Function
    Else
      Tst4BadCDbl = xCvExp(Sign & r): Exit Function
    End If
  End If
Next
SetS: Tst4BadCDbl = vbNullString
End Function

Function Tst4Badx2Dbl(x) As String
Attribute Tst4Badx2Dbl.VB_Description = "Test function in xTest module"
Attribute Tst4Badx2Dbl.VB_HelpID = 500
Attribute Tst4Badx2Dbl.VB_ProcData.VB_Invoke_Func = " \n14"
On Error GoTo SetS
Dim s$, i%, vd, VT, vb, p#, Sign$, t$, r$, q#
s = iFmt(x, 20)
If s = "-" & vbMax343 Then GoTo SetS
If Asc(s) = vbKeyMinus Then
  Sign = "-": s = Right$(s, Len(s) - 1)
End If
vb = CDec("10000000000000000000")
VT = CDec("99999999999999999999")
vd = CDec(Mid$(s, 1, 20))
q = x2Dbl(s)
For i = 1 To 20
  If vd <> vb Then
    vd = vd - 1
    Mid$(s, 1, 20) = CStr(vd)
  Else
    vd = VT
    s = CStr(vd) & "E" & CStr(CInt(Right$(s, Len(s) - 21)) - 1)
  End If
  If q = x2Dbl(s) Then Tst4Badx2Dbl = xCvExp(Sign & s): Exit Function
Next
SetS: Tst4Badx2Dbl = vbNullString
End Function

Function GetMinString$(x)
Attribute GetMinString.VB_Description = "Test function in xTest module\nFind Min string that converts to the same double"
Attribute GetMinString.VB_HelpID = 500
Attribute GetMinString.VB_ProcData.VB_Invoke_Func = " \n14"
Dim y#, ex#, min, max, Sign$, s$, VT, vb, vd
Select Case VarType(x)
  Case vbString: y = CDbl_(x)
    If Asc(Trim$(x)) = vbKeyMinus Then Sign = "-": y = Abs(y)
  Case Is < vbInteger: Exit Function
  Case Else: If x < 0 Then Sign = "-": y = Abs(x) Else y = x
End Select
If y = 0 Then GetMinString = "-" & vbMax343: Exit Function
s = iFmt(xSubR(qCStr(y), xDivR(GetDecr(y), 2, 35), 35), 20)
ex = CInt(Right$(s, Len(s) - 21))
min = CDec(Left$(s, 20))
max = min
vb = CDec("10000000000000000000")
VT = CDec("99999999999999999999")
If y = CDbl(s) Then ' Found EQ, find good Min
FindMINfromEQ:
  If min > vb + 19 Then min = min - 20 Else min = vb
  Mid$(s, 1, 20) = CStr(min)
  If y > CDbl(s) Then GoTo FindExactMatch
  max = min: If min > vb Then GoTo FindMINfromEQ
  max = VT: min = VT: ex = ex - 1: s = CStr(max) & "E" & CStr(ex)
  GoTo FindMINfromEQ
  
FindExactMatch:
  vd = Int((max + min) / 2): Mid$(s, 1, 20) = CStr(vd)
  If y = CDbl(s) Then max = vd Else min = vd
  If max - min > 1 Then GoTo FindExactMatch

  If Right$(CStr(max), 1) = vbStr0 Then
    Mid$(s, 1, 20) = CStr(max + 1)
    If CDbl(s) < y Then 'Max is a bad value
      min = max + 1
      If max < VT - 9 Then max = max + 10 Else max = VT
      GoTo FindExactMatch
    End If
  ElseIf Right$(CStr(min), 1) = vbStr0 Then
   If min > vb Then
    Mid$(s, 1, 20) = CStr(min - 1)
    If CDbl(s) = y Then ' Min is a bad value
      max = min - 1
      If min > vb + 9 Then min = min - 10 Else min = vb
      GoTo FindExactMatch
  End If: End If: End If
  
  Mid$(s, 1, 20) = CStr(max)
  GetMinString = Sign & s
  Exit Function
     
Else  ' y-s is GT 0, find EQ(we have a good Min)
FindEQfromGT:
  If max < VT - 19 Then max = max + 20 Else max = VT
  Mid$(s, 1, 20) = CStr(max)
  If y = CDbl(s) Then GoTo FindExactMatch
  min = max: If max < VT Then GoTo FindEQfromGT
  max = vb: min = vb: ex = ex + 1: s = CStr(max) & "E" & CStr(ex)
  GoTo FindEQfromGT
End If
End Function

Function GetMaxString$(x)
Attribute GetMaxString.VB_Description = "Test function in xTest module\nFind Max string that converts to the same double"
Attribute GetMaxString.VB_HelpID = 500
Attribute GetMaxString.VB_ProcData.VB_Invoke_Func = " \n14"
Dim y#, ex#, min, max, Sign$, s$, VT, vb, vd
Select Case VarType(x)
  Case vbString: y = CDbl_(x)
    If Asc(Trim$(x)) = vbKeyMinus Then Sign = "-": y = Abs(y)
  Case Is < vbInteger: Exit Function
  Case Else: If x < 0 Then Sign = "-": y = Abs(x) Else y = x
End Select
  
If y = CDbl(VbMax) Then GetMaxString = Sign & VbMax: Exit Function
s = iFmt(xAddR(qCStr(y), xDivR(GetIncr(y), 2, 35), 35), 20)
ex = CInt(Right$(s, Len(s) - 21))
min = CDec(Left$(s, 20))
max = min
vb = CDec("10000000000000000000")
VT = CDec("99999999999999999999")
If y = CDbl(s) Then ' Found EQ, find good Max
  If ex = 289 Then max = CDec("17976931348623158077"): GoTo FindExactMatch
FindMAXfromEQ:
  If max < VT - 19 Then
    max = max + 20: Mid$(s, 1, 20) = CStr(max)
    If y < CDbl(s) Then GoTo FindExactMatch
    min = max: GoTo FindMAXfromEQ
  End If
  max = VT: Mid$(s, 1, 20) = CStr(max)
  If y < CDbl(s) Then GoTo FindExactMatch
  max = vb: min = vb: ex = ex + 1: s = CStr(max) & "E" & CStr(ex)
  GoTo FindMAXfromEQ

FindExactMatch:
  vd = Int((max + min) / 2): Mid$(s, 1, 20) = CStr(vd)
  If y = CDbl(s) Then min = vd Else max = vd
  If max - min > 1 Then GoTo FindExactMatch

  If Right$(CStr(max), 1) = vbStr0 Then
    Mid$(s, 1, 20) = CStr(max + 1)
    If y = CDbl(s) Then 'Max is a bad value
      min = max + 1
      If max < VT - 9 Then max = max + 10 Else max = VT
      GoTo FindExactMatch
    End If
  ElseIf Right$(CStr(min), 1) = vbStr0 Then
   If min > vb Then
    Mid$(s, 1, 20) = CStr(min - 1)
    If CDbl(s) > y Then ' Min is a bad value
      max = min - 1
      If min > vb + 9 Then min = min - 10 Else min = vb
      GoTo FindExactMatch
  End If: End If: End If
  
  Mid$(s, 1, 20) = CStr(min)
  GetMaxString = Sign & s
  Exit Function
    
Else  ' y-s is LT 0, find EQ(we have a good Max)
FindMINfromLT:
  If min > vb + 19 Then min = min - 20 Else min = vb
  Mid$(s, 1, 20) = CStr(min)
  If y = CDbl(s) Then GoTo FindExactMatch
  max = min: If min > vb Then GoTo FindMINfromLT
  max = VT: min = VT: ex = ex - 1: s = CStr(max) & "E" & CStr(ex)
  GoTo FindMINfromLT
End If
End Function

Function GetMinMax(x, Optional SigDgt)
Attribute GetMinMax.VB_Description = "Test function in xTest module"
Attribute GetMinMax.VB_HelpID = 500
Attribute GetMinMax.VB_ProcData.VB_Invoke_Func = " \n14"
On Error GoTo EH
Dim a(2) As String, s$, y#, Sign$, s0$, s01$, s9$, t$, s10$
Dim vd, v93, v92, v91, v9, v10, pvd ', e%, m$
If IsMissing(SigDgt) Then
  SigDgt = 20
ElseIf SigDgt > 20 Then
  SigDgt = 20
ElseIf SigDgt < 17 Then
  SigDgt = 17
End If
y = CDbl(x)
If y < 0 Then
  Sign = "-"
  y = Abs(y)
End If
s10 = vbStr1 & String$(SigDgt - 1, vbKey0)
v10 = CDec(s10)
s0 = String$(SigDgt, vbKey0)
If y > 4E-308 Then
  s = iFmt(y, 20)
  s = Left$(s, 15) & String$(SigDgt - 15, vbKey0) & "E" & _
    CStr(CInt(Right$(s, Len(s) - 21)) + (20 - SigDgt))
  If CDbl(s) >= y Then
TryAgain:
    If CDbl(Mid$(s, 1, 15)) > 100000000000000# Then
'      Mid$(s, 1, SigDgt) = Right$(s0 & xSub(Mid$(s, 1, SigDgt), "000000000000001" & String$(SigDgt - 15, "0"), SigDgt), SigDgt)
      Mid$(s, 1, SigDgt) = Right$(s0 & CStr(CDec(Mid$(s, 1, SigDgt)) - 10 ^ (SigDgt - 15)), SigDgt)
    Else
      s = "999999999999999" & String$(SigDgt - 15, vbKey0) & "E" & _
        CStr(CInt(Right$(s, Len(s) - SigDgt - 1)) - 1)
    End If
    If CDbl(s) >= y Then GoTo TryAgain
  End If
ElseIf y = 0 Then
'  s = Left$(vbStr2 & DecSep & "4703282292062327209", SigDgt + 1) & "E-324"
  s = GetMaxString$(y)
  a(2) = s
  a(0) = "-" & s
  a(1) = vbStr0
  GoTo exitmm
Else
  s = GetMinString$(y)
  s = Left$(s, 15) & String$(SigDgt - 15, vbKey0) & "E" & _
    CStr(CInt(Right$(s, Len(s) - 21)) + (20 - SigDgt))
End If
  vd = CDec(Mid$(s, 1, SigDgt))
  Select Case SigDgt
    Case 20: GoTo nextmin4
    Case 19: GoTo setmin3
    Case 18: GoTo setmin2
    Case 17: GoTo setmin1
    Case Else: GoTo nextmin
  End Select
nextmin4:
  pvd = vd: t = s
  If vd <> CDec(String$(SigDgt - 4, vbStr9) & "0000") Then
    vd = vd + 10000
    Mid$(s, 1, SigDgt) = CStr(vd)
  Else
    vd = v10
    s = s10 & "E" & CStr(CInt(Right$(s, Len(s) - SigDgt - 1)) + 1)
  End If
  If CDbl_(s) < y Then GoTo nextmin4
  vd = pvd: s = t
setmin3:
v93 = CDec(String$(SigDgt - 3, vbStr9) & "000")
nextmin3:
  pvd = vd: t = s
  If vd <> v93 Then
    vd = vd + 1000
    Mid$(s, 1, SigDgt) = CStr(vd)
  Else
    vd = v10
    s = s10 & "E" & CStr(CInt(Right$(s, Len(s) - SigDgt - 1)) + 1)
  End If
  If CDbl_(s) < y Then GoTo nextmin3
  vd = pvd: s = t
setmin2:
v92 = CDec(String$(SigDgt - 2, vbStr9) & "00")
nextmin2:
  pvd = vd: t = s
  If vd <> v92 Then
    vd = vd + 100
    Mid$(s, 1, SigDgt) = CStr(vd)
  Else
    vd = v10
    s = s10 & "E" & CStr(CInt(Right$(s, Len(s) - SigDgt - 1)) + 1)
  End If
  If CDbl_(s) < y Then GoTo nextmin2
  vd = pvd: s = t
setmin1:
v91 = CDec(String$(SigDgt - 1, vbStr9) & vbKey0)
nextmin1:
  pvd = vd: t = s
  If vd <> v91 Then
    vd = vd + 10
    Mid$(s, 1, SigDgt) = CStr(vd)
  Else
    vd = v10
    s = s10 & "E" & CStr(CInt(Right$(s, Len(s) - SigDgt - 1)) + 1)
  End If
  If CDbl_(s) < y Then GoTo nextmin1
  vd = pvd: s = t
SetMin:
s9 = String$(SigDgt, vbStr9)
v9 = CDec(s9)
s01 = String$(SigDgt - 1, vbKey0) & vbStr1
nextmin:
  If vd <> v9 Then
    vd = vd + 1
    Mid$(s, 1, SigDgt) = CStr(vd)
  Else
    vd = v10
    s = s10 & "E" & CStr(CInt(Right$(s, Len(s) - SigDgt - 1)) + 1)
  End If
  If CDbl_(s) < y Then GoTo nextmin
If SigDgt = 20 Then
  If Mid$(s, 20, 1) = vbStr0 Then
    t = s
    If vd <> v9 Then
      vd = vd + 1
      Mid$(t, 1, SigDgt) = CStr(vd)
    Else
      vd = v10
      t = s10 & "E" & CStr(CInt(Right$(t, Len(t) - SigDgt - 1)) + 1)
    End If
    If CDbl(t) = y Then GoTo donemin
    s = t
    vd = CDec(Mid$(s, 1, SigDgt))
    GoTo nextmin
  ElseIf Mid$(s, 20, 1) = vbStr1 Then
    vd = CDec(Mid$(t, 1, SigDgt))
    If vd <> v10 Then
      vd = vd - 1
      Mid$(t, 1, SigDgt) = CStr(vd)
    Else
      vd = v9
      t = s9 & "E" & CStr(CInt(Right$(s, Len(s) - SigDgt - 1)) - 1)
    End If
    If CDbl(t) <> y Then GoTo donemin
lookbackm:
    s = t
    If vd <> v10 Then
      vd = vd - 1
      Mid$(t, 1, SigDgt) = CStr(vd)
    Else
      vd = v9
      t = s9 & "E" & CStr(CInt(Right$(s, Len(s) - SigDgt - 1)) - 1)
    End If
    If CDbl(t) = y Then GoTo lookbackm
  End If
End If
donemin:
'  e = CInt(Right$(s, Len(s) - SigDgt - 1))
'  m = s
  a(0) = xCvExp(Sign & s)
  If y < 1E-305 Then
    s = iFmt(xAddR(s, "4" & DecSep & "940656458412465441111E-324", 21), 20)
    s = Left$(s, 17) & String$(SigDgt - 17, vbKey0) & "E" & _
      CStr(CInt(Right$(s, Len(s) - 21)) + (20 - SigDgt))
  ElseIf y = CDbl(VbMax) Then
    a(2) = iFmt(Sign & VbMax, SigDgt)
    GoTo calcexact
  End If
  Select Case SigDgt
    Case 20: Mid$(s, 18, 3) = "000"
    Case 19: Mid$(s, 18, 2) = "00"
    Case 18: Mid$(s, 18, 1) = vbStr0: GoTo setmax2
    Case Else: GoTo setmax1
  End Select
  vd = CDec(Mid$(s, 1, SigDgt))
findmax3:
  t = s
  If vd <> v93 Then
    vd = vd + 1000
    Mid$(s, 1, SigDgt) = CStr(vd)
  Else
    vd = v10
    s = s10 & "E" & CStr(CInt(Right$(s, Len(s) - SigDgt - 1)) + 1)
  End If
  If CDbl(s) <= y Then GoTo findmax3
  s = t
setmax2:
  vd = CDec(Mid$(s, 1, SigDgt))
FindMax2:
  t = s
  If vd <> v92 Then
    vd = vd + 100
    Mid$(s, 1, SigDgt) = CStr(vd)
  Else
    vd = v10
    s = s10 & "E" & CStr(CInt(Right$(s, Len(s) - SigDgt - 1)) + 1)
  End If
  If CDbl(s) <= y Then GoTo FindMax2
  s = t
setmax1:
  vd = CDec(Mid$(s, 1, SigDgt))
FindMax1:
  t = s
  If vd <> v91 Then
    vd = vd + 10
    Mid$(s, 1, SigDgt) = CStr(vd)
  Else
    vd = v10
    s = s10 & "E" & CStr(CInt(Right$(s, Len(s) - SigDgt - 1)) + 1)
  End If
  If CDbl(s) <= y Then GoTo FindMax1
  s = t
  vd = CDec(Mid$(s, 1, SigDgt))
FindMax:
  t = s
  If vd <> v9 Then
    vd = vd + 1
    Mid$(s, 1, SigDgt) = CStr(vd)
  Else
    vd = v10
    s = s10 & "E" & CStr(CInt(Right$(s, Len(s) - SigDgt - 1)) + 1)
  End If
  If CDbl(s) <= y Then GoTo FindMax
  If SigDgt = 20 Then
    If Mid$(s, 20, 1) = vbStr0 Then
      If vd <> v9 Then
        vd = vd + 1
        Mid$(s, 1, SigDgt) = CStr(vd)
      Else
        vd = v10
        s = s10 & "E" & CStr(CInt(Right$(s, Len(s) - SigDgt - 1)) + 1)
      End If
      If CDbl(s) = y Then GoTo FindMax
    ElseIf Mid$(t, 20, 1) = vbStr0 Then
      s = t
      vd = CDec(Mid$(s, 1, SigDgt))
      If vd <> v10 Then
        Mid$(s, 1, SigDgt) = CStr(vd - 1)
      Else
        s = s9 & "E" & CStr(CInt(Right$(s, Len(s) - SigDgt - 1)) - 1)
      End If
      If CDbl(s) = y Then GoTo donemax
      t = s
      vd = CDec(Mid$(t, 1, SigDgt))
lookback:
      If vd <> v10 Then
        vd = vd - 1
        Mid$(t, 1, SigDgt) = CStr(vd)
      Else
        vd = v9
        t = s9 & "E" & CStr(CInt(Right$(t, Len(t) - SigDgt - 1)) - 1)
      End If
      If CDbl(t) <> y Then GoTo lookback
    End If
  End If
donemax:
  a(2) = xCvExp(Sign & t)
calcexact:
  a(1) = xCvExp(xDivR(xAddR(a(0), a(2), 30), vbStr2, 30))
exitmm:
If xNumInvAppCallFlg Then
  GetMinMax = a
ElseIf Application.Caller.Rows.Count > 1 Then
  GetMinMax = Application.WorksheetFunction.Transpose(a)
ElseIf Application.Caller.Columns.Count > 1 Then
  GetMinMax = a
Else
  GetMinMax = a(1)
End If
Exit Function
EH:
End Function


'Private Sub ListGUID()
'     Dim Ref As Object, N&
'     Sheets.Add
'     Application.ScreenUpdating = False
'     Cells.Font.Size = 8
'     With Rows("1:1")
'           .Font.Size = 9
'           .Font.Bold = True
'           .Font.ColorIndex = 9
'           .Font.Underline = xlUnderlineStyleSingle
'     End With
'     [A1:D1] = _
'     Array("Description", "Name", "Use: ThisWorkbook.VBProject.References.AddFromGuid", "Path")
'     For Each Ref In ThisWorkbook.VBProject.References
'           [A65536].End(xlUp).Offset(1, 0) = Ref.Description
'           [B65536].End(xlUp).Offset(1, 0) = Ref.Name
'           [C65536].End(xlUp).Offset(1, 0) = """" & Ref.GUID & """" & ", " & Ref.Major & ", " & Ref.Minor
'           [D65536].End(xlUp).Offset(1, 0) = Ref.FullPath
'     Next
'     Columns("A:D").EntireColumn.AutoFit
'     Set Ref = Nothing
'End Sub

'Private Sub CreateRef()
'' create a reference to the VBA Extensibility library.
'On Error GoTo EH
'Dim Reference As Object
'With ThisWorkbook.VBProject
'  For Each Reference In .References
'    If Reference.Description Like "Microsoft Visual Basic for Applications Extensibility*" Then
'      .References.Remove Reference 'Remove first incase we have an incompatable version
'      Exit For
'    End If
'  Next
'  .References.AddFromGuid "{0002E157-0000-0000-C000-000000000046}", 5, 0 'Now install the correct version
'End With
'Set Reference = Nothing
'Exit Sub
'EH: DispErr "CreateReference." & vbCr & "Xnumbers can not be properly configured." & vbCr & _
'      "Hit Help for correction proceedures." & vbCr & "Then Re-Load Xnumbers."
'End Sub

'Sub ListIDs()
' Dim cbr As CommandBar
' Dim i As Integer, s$, j&
' j = 1
' 'Set cbr = CommandBars("Standard")
' With ActiveSheet
' For Each cbr In Application.VBE.CommandBars
' s = cbr.Name
' For i = 1 To cbr.Controls.Count
' .Cells(j, 1) = s & " " & i & " id=" & cbr.Controls(i).id & " Caption=" & cbr.Controls(i).Caption & " TooltipText=" & cbr.Controls(i).TooltipText
' j = j + 1
' Next i
' Next
' End With
'End Sub
'Sub DisableCalc()
'Dim ws 'As Worksheet ', wb As Workbook
''Set wb = ThisWorkbook.Worksheets
'For Each ws In ThisWorkbook.Worksheets
'  Debug.Print ws.Name, ws.EnableCalculation
'  ws.EnableCalculation = False
'Next
'End Sub

''Function TestTime(n)
''If VarType(n) < vbInteger Then Exit Function
'Function TestTime(d)
'If VarType(d) < vbInteger Then Exit Function
'Dim OrigxNumInvAppCallFlg As Boolean, OrigxNumACRows&, OrigxNumACCols%
'Dim cyFrequency As Currency, dt1 As Currency, dt0 As Currency, dt2 As Currency, q0, q1, q2, overhead, q
'Dim i&, iMax&, s, x$
'    OrigxNumInvAppCallFlg = xNumInvAppCallFlg
'    OrigxNumACRows = xNumACRows: OrigxNumACCols = xNumACCols
'    On Error GoTo EH
'    xNumACCols = 1: xNumACRows = 3: xNumInvAppCallFlg = True
'    ChkArrayRet (True)
''Dim d&, dMax&, dMin&
''dMax = DIGITS_LIMIT - xBASE * 2
''dMin = 8
''d = DIGITS_LIMIT / 2
'Dim n&, nMax&, nMin&
'nMax = 3000
'nMin = 8
'n = 1500
'
'x = ".1"
'iMax = 3
'
'getFrequency cyFrequency
'q = CDec(cyFrequency) / 100
'DoEvents
'Application.EnableEvents = False
'getTickCount dt1
'For i = 1 To iMax
'  GoSub Dummy
'Next
'getTickCount dt2
'Application.EnableEvents = True
'q1 = CDec(dt1)
'q2 = CDec(dt2)
'overhead = (q2 - q1)
'
'TryAgain:
'GoSub CalcTime
''If q1 > q0 Then dMax = d Else dMin = d
''d = (dMax + dMin) / 2
''If dMax - dMin > 4 Then GoTo TryAgain
''TestTime = d: Exit Function
'If q1 > q0 Then nMax = n Else nMin = n
'n = (nMax + nMin) / 2
'If nMax - nMin > 2 Then GoTo TryAgain
'TestTime = n
'EH: xNumInvAppCallFlg = OrigxNumInvAppCallFlg
'    xNumACRows = OrigxNumACRows: xNumACCols = OrigxNumACCols
'Exit Function
'
'
'CalcTime:
'DoEvents
'Application.EnableEvents = False
'getTickCount dt1
'For i = 1 To iMax
'GoSub First
'Next
'getTickCount dt2
'Application.EnableEvents = True
'
'q0 = CDec(dt1)
'q2 = CDec(dt2)
'q0 = (q2 - q0 - overhead) / q
'
'DoEvents
'Application.EnableEvents = False
'getTickCount dt1
'For i = 1 To iMax
'GoSub Second
'Next
'getTickCount dt2
'Application.EnableEvents = True
'
'q1 = CDec(dt1)
'q2 = CDec(dt2)
'q1 = (q2 - q1 - overhead) / q
'Return
'Dummy: Return
'
'First: 'xPChebTArrRet s, x, n, (d), d
'Return
'
'Second: 'xPChebTArrRet2 s, x, n, (d), d
'Return
'
'End Function

'Function TestTime(Digits_Max)
'If VarType(Digits_Max) < vbInteger Then Exit Function
'Dim cyFrequency As Currency, dt1 As Currency, dt0 As Currency, dt2 As Currency, q1, q2, overhead, q
'Dim i&, iMax&, x() As xNum, d&, r#()
'
'iMax = 10
'
'd = Digits_Max
'ReDim x(1 To 3), r(1 To 4)
'CStr2xNum x(2), xPi(d), d
'CStr2xNum x(3), xE(d), d
'getFrequency cyFrequency
'q = CDec(cyFrequency) / 100
'DoEvents
'Application.EnableEvents = False
'getTickCount dt1
'For i = 1 To iMax: GoSub Dummy: Next
'getTickCount dt2
'Application.EnableEvents = True
'q1 = CDec(dt1)
'q2 = CDec(dt2)
'overhead = (q2 - q1)
'
'DoEvents
'Application.EnableEvents = False
'getTickCount dt1
'For i = 1 To iMax: GoSub TestAdd: Next
'getTickCount dt2
'Application.EnableEvents = True
'q1 = CDec(dt1)
'q2 = CDec(dt2)
'r(1) = (q2 - q1 - overhead) / q
'
'DoEvents
'Application.EnableEvents = False
'getTickCount dt1
'For i = 1 To iMax: GoSub TestMult: Next
'getTickCount dt2
'Application.EnableEvents = True
'q1 = CDec(dt1)
'q2 = CDec(dt2)
'r(2) = (q2 - q1 - overhead) / q
'
'DoEvents
'Application.EnableEvents = False
'getTickCount dt1
'For i = 1 To iMax: GoSub TestDiv: Next
'getTickCount dt2
'Application.EnableEvents = True
'q1 = CDec(dt1)
'q2 = CDec(dt2)
'r(3) = (q2 - q1 - overhead) / q
'
'DoEvents
'Application.EnableEvents = False
'getTickCount dt1
'For i = 1 To iMax: GoSub TestAtan: Next
'getTickCount dt2
'Application.EnableEvents = True
'q1 = CDec(dt1)
'q2 = CDec(dt2)
'r(4) = (q2 - q1 - overhead) / q
'
'TestTime = PasteVector_(r)
'Exit Function
'
'Dummy: Return
'TestAdd: xAdd_ x(1), x(2), x(3), d: Return
'TestMult: xMult_ x(1), x(2), x(3), d: Return
'TestDiv: xDiv_ x(1), x(2), x(3), d: Return
'TestAtan: xAtan_ x(2), d: Return
'
'End Function

'Function testnum()
'Dim i&, j&, k&, l&, o$(), s$
'ReDim o(1 To 4, 100)
'For i = 0 To 255
'For j = 0 To 255
'For k = 0 To 255
'  s = Chr(i) & Chr(j) & Chr(k)
'  If IsNumeric(s) Then
'   If xIsNumeric(s) Then
''    if application.WorksheetFunction.value(s) then
'    o(1, l) = i: o(2, l) = j: o(3, l) = k: o(4, l) = s
'    l = l + 1
'    If l > UBound(o, 2) Then ReDim Preserve o(1 To 4, l + 100)
'   End If
'  End If
'Next k, j, i
'ReDim Preserve o(1 To 4, l - 1)
'testnum = Application.WorksheetFunction.Transpose(o)
'End Function
VBA Filename Rootfinder_Rf.bas Extracted Macro
Option Explicit
'-------------------------------------------------------------------------------------
' Integer Polynomial Roofinder
' uses the Ruffini's method + QD algorithm
' v. 1.0, Ago 05, by Foxes Team
'-------------------------------------------------------------------------------------
Sub Rootfinder_Ruffini(Coef, Root, Root_count, n, RetErr, Optional Itmax As Long = 1000, Optional MP As Boolean = False)
'Ruffini's polynomial integer rootfinder
' v. 13.8.05  VL
Dim a(), b(), poss, i&, j&, Degree, x_max, x_min, loop_max&, dX
Dim segm(), m, x, DgtMax&, p, IsRemZero As Boolean

Degree = UBound(Coef) - 1
If Degree < 1 Then Exit Sub
ReDim a(1 To Degree + 1)
ReDim Root(1 To Degree)
loop_max = Itmax
RetErr = vbNullString
If MP Then
    'estimate the dgtmax parameter
    i = GetDigitMax(Coef)
    DgtMax = min_(2 * i, DIGITS_LIMIT)
Else
    DgtMax = 0  'standard precision
End If

'load vector coefficients in descendent order
For i = 1 To Degree + 1: a(i) = Coef(Degree - i + 2): Next i

'bracketing for integer real roots with the QD algorithm
Call Bracketing_Int_Roots(Coef, segm, m, RetErr) '<<< always in standard precision

'debug <<<<<<<<<<<<<<<<<<<<
'Debug.Print "segments:"
'For j = 1 To m: Debug.Print segm(j, 1), segm(j, 2): Next
'<<<<<<<<<<<<<<<<<<<<<<<<<

If m = 0 Then
    j = 0
    x_min = 0
    x_max = 1000
Else
    j = 1
    x_min = segm(j, 1)
    x_max = segm(j, 2)
End If

Root_count = 0
n = Degree
'Ruffini's integer rootfinder starts
Do
    dX = x_max - x_min
    If dX > loop_max Then
        'eliminate the "hanging" if the sub is used by the Excel function
        RetErr = "Iterations: " & dX & " > " & loop_max 'iteration overflow
        Exit Sub
    End If
    'get the next divisor of a0 greater then xmin
    Do
        If MP Then
            x = xNext_Divisor(a(n + 1), x_min, x_max, loop_max, DgtMax)
        Else
            x = Next_Divisor(a(n + 1), x_min, x_max, loop_max)
        End If
        If x = 0 Then
            If j = 0 Or j = m Then
                GoTo Ruffini_End   'nothing to do exit
            Else
                j = j + 1          'try another segments
                x_min = segm(j, 1)
                x_max = segm(j, 2)
            End If
        End If
    Loop Until x <> 0
    x_min = x
    Do
        'reduce the polynomial by the syntetic division
        If MP Then
            IsRemZero = xSyntetic_Division(a, b, x, DgtMax)
        Else
            IsRemZero = Syntetic_Division(a, b, x)
        End If
        'check if x is an integer root
'        If b(n + 1) = 0 Then
        If IsRemZero Then
            'OK. Take the root
            Root_count = Root_count + 1
            Root(Root_count) = x
            'load the reduced polynomial
            For i = 1 To n + 1: a(i) = b(i): Next i
            n = n - 1
        Else
            If j = 0 And x > 0 Then
                x = -x 'try with the opposite value
            Else
                x_min = x_min + 1 'try with the next divisor
                Exit Do
            End If
        End If
    Loop Until n = 0

Loop Until n = 0

Ruffini_End:
ReDim Coef(1 To n + 1)
If n > 0 Then
    For i = 0 To n
        Coef(i + 1) = a(n + 1 - i)
    Next i
End If
If Root_count > 1 Then
    ReDim Preserve Root(1 To Root_count)
'    MatrixSort Root
End If
RetErr = vbNullString  'all OK
End Sub


'Brackets the polynomial integer roots by QD algorithm
Sub Bracketing_Int_Roots(Coef, segm, m, RetErr)
Dim cf(), i&, j&, Degree&, z#, dz#, q#(), d#(), e#()
Dim Coeff_Tiny#, j_max&, j_min&, v(), L1, L2, gap, f
Dim IterMax%, ErrLimit#, ErrLimit1#, SplitFactor

IterMax = 1000: ErrLimit = 0.001: SplitFactor = 10
ErrLimit1 = ErrLimit
Degree = UBound(Coef) - 1
ReDim cf(Degree)
ReDim v(1 To Degree, 1 To 2), segm(1 To Degree, 1 To 2)

For i = 0 To Degree
    cf(i) = Coef(i + 1)
Next i

'substitute zero coefficients with a small random factor
Coeff_Tiny = 10 ^ -6
For i = 0 To Degree
    If Abs(cf(i)) < Coeff_Tiny Then cf(i) = Coeff_Tiny * Rnd
Next i

    QD_iterate cf, q, d, e, IterMax, ErrLimit1, RetErr

'estimate the splitting-factor
SplitFactor = 10
'estimate the error limit
ErrLimit = 0.0000001 * Degree ^ 3.3
If ErrLimit < 0.001 Then ErrLimit = 0.001
If ErrLimit > 0.5 Then ErrLimit = 0.5
RetErr = 0
j_max = 1
j_min = j_max
m = 0  'intervals counter
For i = 1 To Degree
    j = Degree - i + 1
    If q(j_min) > q(j) Then j_min = j
    If q(j_max) < q(j) Then j_max = j
    If e(j) < ErrLimit Then
        z = Round(q(j))
        dz = Round(SplitFactor * (Abs(z) * e(j) + 1))
        m = m + 1
        v(m, 1) = z - dz
        v(m, 2) = z + dz
    End If
Next

MatCopy v, segm   'v -> segm
ReDim v(1 To m, 1 To 2)
For i = 1 To m
    v(i, 1) = segm(i, 1)
    v(i, 2) = segm(i, 2)
Next i
MatrixSort v

If m > 0 Then
    j = 1
    segm(j, 1) = v(1, 1)
    segm(j, 2) = v(1, 2)
    'merge intervals
    If m > 1 Then
        For i = 2 To m
            If v(i, 2) < v(i - 1, 1) Or v(i - 1, 2) < v(i, 1) Then
'            If (v(i, 2) < v(i - 1, 1) Or v(i, 1) > v(i - 1, 2)) Then
                'take the segment
                j = j + 1
                segm(j, 1) = v(i, 1)
                segm(j, 2) = v(i, 2)
            Else
                If v(i, 1) < segm(j, 1) Then segm(j, 1) = v(i, 1)
                If v(i, 2) > segm(j, 2) Then segm(j, 2) = v(i, 2)
            End If
        Next i
    End If
End If
m = j

'eliminate gaps
ReDim v(1 To m, 1 To 2)
i = 1
v(1, 1) = segm(1, 1)
v(1, 2) = segm(1, 2)
For j = 2 To m
    L1 = v(i, 2) - v(i, 1)
    L2 = segm(j, 2) - segm(j, 1)
    gap = segm(j, 1) - v(i, 2)
    f = Abs(gap / (L1 + L2))   'duty factor
    If f < 4 Then
        'join segments
        v(i, 2) = segm(j, 2)
    Else
        'add a new segment
        i = i + 1
        v(i, 1) = segm(j, 1)
        v(i, 2) = segm(j, 2)
    End If
Next j
m = i
ReDim segm(1 To m, 1 To 2)
For i = 1 To m
    segm(i, 1) = v(i, 1)
    segm(i, 2) = v(i, 2)
Next i

End Sub

'Quotient-Difference algorithm
Sub QD_iterate(a, q, d, e, IterMax, ErrLimit, RetErr)
Dim Iter&, Iter1&, IterMax1&, x0#, err_awg#, center#, n&, i&

n = UBound(a)
'performs a random shift for dissimmetrizing
x0 = 2 * Rnd
center = -a(n - 1) / n
If Abs(center) < 4 Then x0 = x0 - center
PolyShift_ a, x0
'initialize
ReDim q(n + 1), d(n + 1), e(n + 1)
q(1) = -a(n - 1) / a(n)
For i = 2 To n
    d(i) = a(n - i) / a(n - i + 1)
Next
'Quotient-Difference iterations begins
IterMax1 = IterMax / 10
Iter = 0
Do
    Iter1 = 0
    Do
        For i = 1 To n
            q(i) = q(i) + d(i + 1) - d(i)
        Next i
        For i = 2 To n
            d(i) = d(i) * q(i) / q(i - 1)
        Next i
        Iter1 = Iter1 + 1
    Loop Until Iter1 > IterMax1
    'estimate the relative error
    err_awg = 0
    For i = 1 To n
        e(i) = Abs(d(i)) + Abs(d(i + 1))
        If Abs(q(i)) > 1 Then e(i) = e(i) / Abs(q(i))
        err_awg = err_awg + e(i)
    Next i
    err_awg = err_awg / n  'average error
    Iter = Iter + IterMax1
Loop Until Iter > IterMax Or err_awg < ErrLimit
'back-shift
For i = 1 To n
    q(i) = q(i) + x0
Next i
End Sub

Private Function Next_Divisor(A0, x_min, x_max, Optional It_max)
'finds the first divisor of a0 starting from x_min
Dim i&, x, d, q, r
If IsMissing(It_max) Then It_max = 1000

If x_min = 0 Then x = 1 Else x = x_min
d = Abs(A0)
i = 0
Do
    q = Abs(d / x)
    If x > x_max Or i > It_max Then
        x = 0
        Exit Do
    End If
    r = q - Int(q)
    If r = 0 Then Exit Do
    x = x + 1
    i = i + 1
Loop
Next_Divisor = x
End Function

Private Function xNext_Divisor(A0, x_min, x_max, Optional It_max, Optional DgtMax)
'finds the first divisor of a0 starting from x_min
Dim i&, x, d, q, r, DgMx&
If IsMissing(It_max) Then It_max = 1000
If IsMissing(DgtMax) Then DgMx = 30 Else DgMx = DgtMax

If x_min = 0 Then x = 1 Else x = x_min
d = xAbsR(A0)
i = 0
Do
    q = xAbsR(xDivR(d, x, DgMx))
    If xComp(x, x_max) > 0 Or i > It_max Then
        x = 0
        Exit Do
    End If
    r = xSub(q, xInt(q), DgMx)
    If r = 0 Then Exit Do
    x = xIncr(x)
    i = i + 1
Loop
xNext_Divisor = x
End Function

Private Function GetDigitMax(a)
'get the max digits of a vector of numbers
Dim i&, dMax, d
dMax = 0
For i = LBound(a) To UBound(a)
    d = xDgt(a(i))
    If dMax < d Then dMax = d
Next i
GetDigitMax = dMax
End Function

Private Function Syntetic_Division(a, b, x) As Boolean
Dim i&, n&
    n = UBound(a)
    ReDim b(1 To n)
    b(1) = a(1)
    For i = 2 To n
        b(i) = a(i) + x * b(i - 1)
    Next i
    Syntetic_Division = (b(n) = 0)
End Function

Private Function xSyntetic_Division(a, b, x, DgtMax&) As Boolean
Dim i&, n&
    n = UBound(a)
    ReDim b(1 To n)
    b(1) = a(1)
    For i = 2 To n
        b(i) = xAdd(a(i), xMultR(x, b(i - 1), DgtMax), DgtMax)
    Next i
    xSyntetic_Division = (xCompZ(b(n)) = 0)
End Function


VBA Filename mdToolbarGen.bas Extracted Macro
Option Private Module
Option Explicit
'--------------------------------------------------------------------------------
' Dynamic ToolBar Generator
' v. 1.1, June 2005, by Foxes Team
'--------------------------------------------------------------------------------

Sub CommmandBar_Create()
'Dim MyBar As CommandBar, Ws As Worksheet
Dim ws As Worksheet, Macro$, i&, i1&, i2&, i3&, CmdBarName$, menu_1$, menu_2$, menu_3$
Dim CB1 As CommandBarPopup, CB2 As CommandBarPopup, CB3 As CommandBarButton, pic
CommandBar_Delete
Set ws = ThisWorkbook.Worksheets("CommandBarMenu")
i = 2
i1 = 0: menu_1 = vbNullString
i2 = 0: menu_2 = vbNullString
i3 = 0: menu_3 = vbNullString
CmdBarName = vbNullString
On Error Resume Next
Do While ws.Cells(i, 1) <> vbNullString
        CmdBarName = ws.Cells(i, 1)
        CommandBars.Add Name:=CmdBarName, Position:=msoBarTop, Temporary:=True
        CommandBars(CmdBarName).Visible = True
        Macro = ThisWorkbook.Name & "!" & ws.Cells(i, 5)
        If menu_1 <> ws.Cells(i, 2) Then
            menu_1 = ws.Cells(i, 2)
            i1 = i1 + 1
            i2 = 0: menu_2 = vbNullString
            i3 = 0: menu_3 = vbNullString
            Set CB1 = CommandBars(CmdBarName).Controls.Add(Type:=msoControlPopup)
            CB1.Caption = menu_1
            If IsBordered(ws.Cells(i, 2)) Then CB1.BeginGroup = True
        End If
            
        If menu_2 <> ws.Cells(i, 3) Then
            menu_2 = ws.Cells(i, 3)
            i2 = i2 + 1
            With CB1.Controls
                If ws.Cells(i, 4) = vbNullString Then
                    Set CB3 = .Add(Type:=msoControlButton)
                    .item(i2).OnAction = Macro
                    If IsBordered(ws.Cells(i, 3)) Then .item(i2).BeginGroup = True
                    If ws.Cells(i, 6) <> vbNullString Then
                        pic = ws.Cells(i, 6)
                        AddPicture ws, CB3, pic
                    End If
                    CB3 = Nothing
                Else
                    Set CB2 = .Add(Type:=msoControlPopup)
                    i3 = 0: menu_3 = vbNullString
                    If IsBordered(ws.Cells(i, 3)) Then CB2.BeginGroup = True
                End If
                .item(i2).Caption = menu_2
            End With
        End If
        
        If ws.Cells(i, 4) <> vbNullString Then
            menu_3 = ws.Cells(i, 4)
            i3 = i3 + 1
            With CB2.Controls
                Set CB3 = .Add(Type:=msoControlButton)
                .item(i3).Caption = menu_3
                .item(i3).OnAction = Macro
                If IsBordered(ws.Cells(i, 4)) Then .item(i3).BeginGroup = True
                If ws.Cells(i, 6) <> vbNullString Then
                    pic = ws.Cells(i, 6)
                    AddPicture ws, CB3, pic
                End If
                CB3 = Nothing
            End With
        End If
        
   i = i + 1
Loop

    ' remove the image icon from the clipborad
'    Ws.Range("G1").Copy
'    Application.CutCopyMode = False
    Call ClearClipboard

End Sub

Sub CommandBar_Delete()
Dim ws As Worksheet, i&, CmdBarName$
Set ws = ThisWorkbook.Worksheets("CommandBarMenu")
i = 2
CmdBarName = vbNullString
On Error Resume Next
Do While ws.Cells(i, 1) <> vbNullString
   If ws.Cells(i, 1) <> CmdBarName Then
        CmdBarName = ws.Cells(i, 1)
        CommandBars(CmdBarName).Delete
   End If
   i = i + 1
Loop
End Sub

Private Sub AddPicture(ws As Worksheet, ctrl As CommandBarButton, pic)
If Not IsNumeric(pic) Then
    ws.Shapes(pic).Copy
    ctrl.Style = msoButtonIconAndCaption
    ctrl.PasteFace
Else
    ctrl.Style = msoButtonIconAndCaption
    ctrl.FaceId = pic
End If
End Sub

Private Function IsBordered(r As Range) As Boolean
  If r.Borders(xlEdgeTop).LineStyle > 0 Then IsBordered = True
End Function

'Private Sub CheckBorder()
'    x = ActiveCell.Borders(xlEdgeTop).LineStyle
'    MsgBox x
'End Sub

VBA Filename frmODEsolver.frm Extracted Macro

Option Explicit

Dim ODE_Ord%, Maxsteps%, MaxError#, MaxLength As Double
Dim EvalCounter&, myRangeVar$, myRangeFun$, myStartVal
Dim ErrMsg, ActionRun As Boolean, FunSymb As Boolean
Dim Var() As Parametro, Param() As Parametro, myRangePar$
Dim Funct() As New xclsMathParser, strFunct()


Private Sub CommandButton_help_Click()
Application.Help XHelpFile, 311
End Sub

Private Sub CommandButton_run_Click()
Dim i, k, s, OK As Boolean

If ActionRun = True Then
    ActionRun = False
    Exit Sub
End If

'check input
If Len(Me.RefEdit1) = 0 Then
    MsgBox "Missing Differential Equation", vbCritical
    Me.RefEdit1.SetFocus
    Exit Sub
End If
If Len(Me.RefEdit2) = 0 And Me.OptionButton_w = True Then
    MsgBox "Missing variables", vbCritical
    Me.RefEdit2.SetFocus
    Exit Sub
End If
If Len(Me.RefEdit3) = 0 Then
    MsgBox "Missing starting values", vbCritical
    Me.RefEdit3.SetFocus
    Exit Sub
End If
If Len(Me.TextBox_N) = 0 Then
    MsgBox "Missing number of total steps", vbCritical
    Me.TextBox_N.SetFocus
    Exit Sub
End If
If Len(Me.TextBox_Length) = 0 Then
    MsgBox "Missing integration length", vbCritical
    Me.TextBox_Length.SetFocus
    Exit Sub
End If
If Len(Me.TextBox_ErrMax) = 0 Then
    MsgBox "Missing relative error max", vbCritical
    Me.TextBox_ErrMax.SetFocus
    Exit Sub
End If

FunSymb = Me.OptionButton_s
If FunSymb Then
    myRangeFun = Me.RefEdit1
    myRangeVar = Me.RefEdit3
    myStartVal = myRangeVar
    myRangePar = Me.RefEdit2
Else
    myRangeFun = Me.RefEdit1
    myRangeVar = Me.RefEdit2
    myStartVal = Me.RefEdit3
End If
ODE_Ord = Range(Me.RefEdit1).Cells.Count
Maxsteps = CInt_(Me.TextBox_N)
MaxError = CDbl_(Me.TextBox_ErrMax)
MaxLength = CDbl_(Me.TextBox_Length)

'check setting
If Range(Me.RefEdit1).Cells.Count <> (Range(Me.RefEdit3).Cells.Count - 1) Then
    MsgBox "number of equations <> number of dependent variables", vbInformation
    Exit Sub
End If
If ODE_Ord > 9 Or ODE_Ord <= 0 Then
    MsgBox "Ord must be 0< ord <10", vbCritical
    Exit Sub
End If
If Maxsteps >= 10000 Or Maxsteps <= 0 Then
    MsgBox "Total steps must be < 10000", vbCritical
    Me.TextBox_N.SetFocus
    Exit Sub
End If
If Abs(MaxLength) < 10 ^ -9 Then
    MsgBox "Length of x is to small", vbCritical
    Me.TextBox_Length.SetFocus
    Exit Sub
End If

'check if functions exist
If Me.OptionButton_w Then
    With Range(Me.RefEdit1)
    For i = 1 To .Cells.Count
        If .Cells(i).HasFormula = False Then
            MsgBox "Formula missing in cell: " & .Cells(i).Address(False, False), vbCritical
            Exit Sub
        End If
    Next i
    End With
Else
    Parameter_auto_labels_Add Range(myRangeVar), Var
    If Len(myRangePar) <> 0 Then
        Parameter_auto_labels_Add Range(myRangePar), Param
    Else
        ReDim Param(0 To 0)
    End If
    ReDim strFunct(1 To ODE_Ord), Funct(1 To ODE_Ord)
    For k = 1 To ODE_Ord
        strFunct(k) = Range(myRangeFun).Cells(k)
    Next k
    'split derivatives and functions
    For k = 1 To ODE_Ord
        s = strFunct(k)
        i = InStr(s, "=")
        If i > 0 Then
            strFunct(k) = Trim$(Right$(s, Len(s) - i))
        End If
    Next k
    'parse equations
    For k = 1 To UBound(Funct)
        OK = Funct(k).StoreExpression(strFunct(k))
        If Not OK Then
            ErrMsg = Funct(k).ErrorDescription
            MsgBox ErrMsg, vbCritical
            Exit Sub
        End If
    Next k
    
    'assign extra parameter if any
    If UBound(Param) > 0 Then
        Assign_Param Funct, Param
    End If

End If

ErrMsg = vbNullString
Me.Label_msg = "Running...................."
ActionRun = True
Me.CommandButton_Run.Caption = "Stop"
DoEvents
'
RKF45_run

ActionRun = False
Me.CommandButton_Run.Caption = "Run"
DoEvents

If Len(ErrMsg) = 0 Then
    'save setting for next time
    Setting_Manager "save"
Else
    MsgBox ErrMsg, vbCritical
End If

End Sub

Private Sub OptionButton_w_Change()
    If Me.OptionButton_w = True Then
        Me.Label2 = "Variables: x, y..."
    Else
        Me.Label2 = "Parameters"
    End If
End Sub

Private Sub UserForm_Initialize()
'header
Me.Label_header1 = "1st-order Vector Differential Equations Solver"
Me.Label_header2 = "Initial values"
'
'methods
Me.ComboBox1.AddItem "RKF-45"  'Runge-Kutta-Fehlberg 45
Me.ComboBox1.AddItem "PC-ABM-4" 'PC Adams-Bashfort-Moulton 4
Me.ComboBox1.ListIndex = 0

Setting_Manager "restore"
'setting input field (if possible)
Input_Setting

'setting labels
End Sub

Sub Setting_Manager(s$)
Dim OrigCalcStatus As Integer
With ThisWorkbook.Worksheets("setting")
If Left$(LCase$(s), 1) = "s" Then
    'save
On Error Resume Next
OrigCalcStatus = Application.Calculation
Application.Calculation = xlCalculationManual
    .Range("D101") = Me.ComboBox1.ListIndex
    .Range("D102") = CDbl_(Me.TextBox_ErrMax)
    .Range("D103") = CInt_(Me.TextBox_N)
    .Range("D104") = CDbl_(Me.TextBox_Length)
    .Range("D105") = Me.CheckBox_dery
Application.Calculation = OrigCalcStatus

ElseIf Left$(LCase$(s), 1) = "r" Then
    'restore
    If .Range("D101") <> vbNullString Then Me.ComboBox1.ListIndex = .Range("D101")
    If .Range("D102") <> vbNullString Then Me.TextBox_ErrMax = CStr(Format(.Range("D102"), "#E+#"))
    If .Range("D103") <> vbNullString Then Me.TextBox_N = CStr(.Range("D103"))
    If .Range("D104") <> vbNullString Then Me.TextBox_Length = CStr(.Range("D104"))
    If .Range("D105") <> vbNullString Then Me.CheckBox_dery = .Range("D105")
    
End If
End With
End Sub

'initialization input fields
Private Sub Input_Setting()
Dim C0, R0, cn, rn, tmp, cel, j, i, m
'a range is selected?
FunSymb = False
If Selection.Cells.Count < 2 Then Exit Sub
'continue
With Selection
    R0 = .Row
    C0 = .Column
    rn = .Rows.Count
    cn = .Columns.Count
End With

'ODE_Ord = (cn - 1) / 2

'select the first row containing value
If Not IsNumeric(Cells(R0, C0)) Then R0 = R0 + 1: rn = rn - 1
If Not IsNumeric(Cells(R0, C0)) Then
'    MsgBox "Starting values x0 missing", vbInformation
    Exit Sub
End If

'check for formulas
For i = 1 To cn
    If Cells(R0, C0 + i - 1).HasFormula = True Then j = j + 1
Next i
If j > 0 Then
    Me.OptionButton_w = True
    ODE_Ord = (cn - 1) / 2
    'select the equation range, variable range, starting range
    tmp = Range(Cells(R0, C0 + ODE_Ord + 1), Cells(R0, C0 + 2 * ODE_Ord)).Address(False, False)
    Me.RefEdit1 = tmp
    tmp = Range(Cells(R0, C0), Cells(R0, C0 + ODE_Ord)).Address(False, False)
    Me.RefEdit2 = tmp
    Me.RefEdit3 = tmp
Else
    Me.OptionButton_s = True
    derivative_finder tmp, m
    If Len(tmp) <> 0 Then
        Me.RefEdit1 = tmp
        ODE_Ord = m
        tmp = Range(Cells(R0, C0), Cells(R0, C0 + ODE_Ord)).Address(False, False)
        Me.RefEdit3 = tmp
    End If
End If
'select the number of points and integration length(if any)
If rn > 1 Then
    Maxsteps = rn - 1
    Me.TextBox_N = CStr(Maxsteps)
    If IsNumeric(Cells(rn + R0 - 1, C0)) Then
        MaxLength = roundrel(Cells(rn + R0 - 1, C0) - Cells(R0, C0), 6)
        Me.TextBox_Length = CStr(MaxLength)
    End If
End If

End Sub

Sub derivative_finder(s, m)
Dim R0, C0, rn, cn, n&, deri(), k&, Ref(), j&, i&, s1
R0 = Selection.Row
C0 = Selection.Column
n = Selection.Columns.Count
cn = n + C0 - 1
If R0 = 1 Then Exit Sub
rn = R0 - 1
R0 = R0 - 20
If R0 < 1 Then R0 = 1
ReDim deri(n), Ref(n)
With Range(Cells(R0, C0), Cells(rn, cn))
    For j = 1 To .Columns.Count
        For i = 1 To .Rows.Count
            If VarType(.Cells(i, j)) = vbString Then
                s = var_extract(.Cells(i, j))
                If Len(s) <> 0 Then
                    'it's a derivative
                    For k = 1 To n
                        s1 = Trim$(Cells(rn + 1, C0 + k))
                        If s1 = s Then
                            deri(k) = s
                            Ref(k) = .Cells(i, j).Address(False, False)
                        End If
                    Next k
                End If
            End If
        Next i
    Next j
End With
s = vbNullString: m = 0
For k = 1 To n
    If Len(Ref(k)) <> 0 Then
        If Len(s) <> 0 Then s = s & ","
        s = s & Ref(k)
        m = m + 1
    End If
Next k
End Sub

Private Function var_extract(s)
Dim i%
i = InStr(s, "'")
If i > 1 Then
    var_extract = Trim$(Left$(s, i - 1))
Else
    var_extract = vbNullString
End If
End Function

'------------------------------------------

'grid fixed step algorithm begins
Sub RKF45_run()
Dim x0#, dX#, n&, y#(), h#, relerr#, ierr&, y0, i&, j&, TOL#, aux, yd()
Dim R0, C0, flag_grid As Boolean, np&, xMax#, x#, k&, iMax&, m&, i0&
Dim OrigCalcStatus As Integer
On Error Resume Next
OrigCalcStatus = Application.Calculation
Application.Calculation = xlCalculationManual

Application.ScreenUpdating = False
On Error GoTo ErrorHandler

TOL = 2 * Ten_16
n = ODE_Ord
relerr = MaxError
np = Maxsteps     'panels

'take grid information
R0 = Range(myStartVal).Row
C0 = Range(myStartVal).Column
Range(Cells(R0 + 1, C0 + 1), Cells(R0 + np, C0 + 2 * n)).ClearContents
aux = Range(Cells(R0, C0), Cells(R0 + np, C0 + 2 * n))
'
'save initial x0 y0
x0 = aux(1, 1)
ReDim y(1 To n)
For i = 1 To n: y(i) = aux(1, i + 1): Next i
y0 = y

'searh for the integration lenght
xMax = x0 + MaxLength
If Len(aux(2, 1)) = 0 Then flag_grid = True

If flag_grid = True Then
    'initialize grid
    dX = (xMax - x0) / np   'tabulating step
    For i = 2 To UBound(aux)
        aux(i, 1) = x0 + (i - 1) * dX
    Next i
Else
    'check for the user-grid
    For i = 1 To UBound(aux) - 1
         If Sgn(MaxLength) * (aux(i + 1, 1) - aux(i, 1)) < 10 ^ -9 Then
            MsgBox "Incorrect x value " & aux(i, 1) & " at step: " & i, vbExclamation
            Exit Sub
         End If
    Next i
End If
'
'fixed step algorithm begins
EvalCounter = 0
x = x0
i = 1
k = 0
Do
    dX = aux(i + 1, 1) - x
    '
    Call FRKFSY1(x, dX, y, h, relerr, ierr)
    '
    If ierr > 1 And ierr <> 4 Then
        ErrMsg = "IERR =" & ierr
        Exit Do
    End If
    
    If ierr = 4 Then
        'algorithm is stopping. possible corner point
        If k > 9 Then
            ErrMsg = "IERR =" & ierr
            Exit Do 'nothing to do
        End If
        k = k + 1
        x = x + k * (0.01 * relerr * x + 10 * TOL)
    Else
        'save the y vector in the array
        i = i + 1
        For j = 1 To n
            aux(i, j + 1) = y(j)
        Next j
        k = 0 'algorithm is running. reset the counter
    End If
    
    'panel refresh  -------------------------------------------
        Me.Label_msg = "Running: steps = " & (i - 1)
        DoEvents
    'check user stop -------------------------------------------
    If ActionRun = False Then Exit Do
    '-----------------------------------------------------------
Loop Until i >= np + 1

iMax = i
'final statistic  -------------------------------------------
    Me.Label_msg = "steps=" & (iMax - 1) & "  x= " & roundrel(x, 3) & "  eval.= " & EvalCounter
    DoEvents
'------------------------------------------------------------

'complete with derivatives (if it needs)
If Me.CheckBox_dery = True Then
ReDim yd(1 To n)
For i = 1 To iMax
    x = aux(i, 1)
    For j = 1 To n
        y(j) = aux(i, j + 1)
    Next j
    Call DEQUAT(x, y, yd)
    For j = 1 To n
        aux(i, n + 1 + j) = yd(j)
    Next j
Next i
End If

'restore initial variables range
With Range(myRangeVar)
    .Cells(1) = x0
    For i = 1 To n
        .Cells(i + 1) = y0(i)
    Next i
End With


'output results
With Range(Cells(R0, C0), Cells(R0 + np, C0 + 2 * n))
If Me.CheckBox_dery = False Then k = n Else k = 2 * n
If Me.OptionButton_s Then i0 = 1 Else i0 = 2
For i = i0 To UBound(aux)
    If flag_grid = True Then .Cells(i, 1) = aux(i, 1)
    For j = 1 To k
        .Cells(i, j + 1) = aux(i, j + 1)
    Next j
Next i
End With

Application.ScreenUpdating = True
On Error Resume Next
Application.Calculation = OrigCalcStatus

Exit Sub

ErrorHandler:
    If Len(ErrMsg) = 0 Then ErrMsg = Err.Description
    'restore initial variables range
    With Range(myRangeVar)
        .Cells(1) = x0
        For i = 1 To n
            .Cells(i + 1) = y0(i)
        Next i
    End With
    Application.ScreenUpdating = True
On Error Resume Next
Application.Calculation = OrigCalcStatus
End Sub

Private Function roundrel(x, d)
Dim s
If Abs(x) <= 2 * Ten_16 Then
    roundrel = 0
Else
    s = d - Int(Log(Abs(x)) / dLn10_) - 1
    If s < 0 Then s = 0
    roundrel = Round(x, s)
End If
End Function

'*****************************************************************
'                                                                *
'  A system of ordinary differential equations of 1st order is   *
'  integrated by applying the RUNGE-KUTTA-FEHLBERG method        *
'  with estimates for the local error and step size control.     *
'                                                                *
'  sources : Shampine/Allen, see [SHAM73].                       *
'            Richard Reuter, [FRKFSY, ESFR Fortran 77 library]   *
'                                                                *
'*****************************************************************

Sub FRKFSY1(a, da, y, h, relerr, ierr)
'
Dim TOL, b, Hmax, LFD, IAD, hf, k1, K2, k3, K4, k5, K6, x, i, quot, n
Dim yt(), t(), r(), TR

n = UBound(y)
ReDim yt(n), t(n), r(n), k1(n), K2(n), k3(n), K4(n), k5(n), K6(n)

      TOL = 3 * Ten_16
'
'     check the input data
      If relerr <= 1000 * TOL Then ierr = 3: Exit Sub
      b = a + da
      If Abs(da) <= 13 * TOL * dmax1(Abs(a), Abs(b)) Then ierr = 4: Exit Sub
      Hmax = Abs(da) '
      If Abs(h) <= 13 * TOL * Abs(a) Then h = Hmax
'
      LFD = 0
      IAD = 0
'
Do
    h = Sgn(da) * DMIN1(Abs(h), Hmax)
    If Abs(b - a) <= 1.25 * Abs(h) Then
       hf = h
'        if IAD=1 and H=B-A acceptable, we stop after the next integration step.
       IAD = 1
       h = b - a
    End If
'     an integration step is executed
    Call DEQUAT(a, y, k1)
    LFD = LFD + 1
    Do
          x = 0.25 * h
          For i = 1 To n
             yt(i) = y(i) + x * k1(i)
          Next i
          x = a + x
          Call DEQUAT(x, yt, K2)
          For i = 1 To n
             yt(i) = y(i) + h * (k1(i) * (3 / 32) + K2(i) * (9 / 32))
          Next i
          x = a + h * (3 / 8)
          Call DEQUAT(x, yt, k3)
          For i = 1 To n
             yt(i) = y(i) + h * (k1(i) * (1932 / 2197) - K2(i) * (7200 / 2197) _
                        + k3(i) * (7296 / 2197))
          Next i
          x = a + h * (12 / 13)
          Call DEQUAT(x, yt, K4)
          For i = 1 To n
             yt(i) = y(i) + h * (k1(i) * (439 / 216) - 8 * K2(i) + k3(i) * (3680 / 513) _
                        - K4(i) * (845 / 4104))
          Next i
          x = a + h
          Call DEQUAT(x, yt, k5)
          For i = 1 To n
             yt(i) = y(i) + h * (-k1(i) * (8 / 27) + 2 * K2(i) - k3(i) * (3544 / 2565) _
                         + K4(i) * (1859 / 4104) - k5(i) * (11 / 40))
          Next i
          x = a + 0.5 * h
          Call DEQUAT(x, yt, K6)
          For i = 1 To n
             t(i) = k1(i) * (25 / 216) + k3(i) * (1408 / 2565) + K4(i) * (2197 / 4104) - k5(i) * 0.2
             yt(i) = y(i) + h * t(i)
          Next i
    '
          For i = 1 To n
             r(i) = k1(i) / 360 - k3(i) * (128 / 4275) - K4(i) * (2197 / 75240) _
                   + k5(i) / 50 + K6(i) * (2 / 55)
          Next i
    '
    '     Check accuracy
    '
          quot = 0
          For i = 1 To n
             TR = Abs(r(i)) / (relerr * Abs(yt(i)) + 10 ^ 3 * TOL)
             quot = dmax1(quot, TR)
          Next i
    '
          If quot <= 1 Then
    '        result is accepted
             For i = 1 To n
                y(i) = yt(i)
             Next i
             a = a + h
             If IAD = 1 Then
                ierr = 1
                h = hf
                Exit Sub
             End If
    '        prepare next step
             quot = dmax1(quot, 0.00065536)
          End If
          quot = DMIN1(quot, 4096)
          h = 0.8 * h / Sqr(Sqr(quot))
    '
    '     We just achieved that H was increased by at most a factor of 5,
    '     or alternatively, that it was decreased by a factor of 10
    '     at most
    '
          If Abs(h) <= 13 * TOL * Abs(a) Then
             ierr = 4
             Exit Sub
          End If
          LFD = LFD + 5
          If LFD >= 2000 Then
             ierr = 2
             Exit Sub
          End If
          If quot <= 1 Then
    '        the step was successful. Continue with another step.
                Exit Do  'inner loop
          Else
    '        the step is repeated for a smaller step.
             IAD = 0
          End If
    Loop  'inner loop

Loop
End Sub

Private Function dmax1(a, b)
If a > b Then dmax1 = a Else dmax1 = b
End Function

Private Function DMIN1(a, b)
If a < b Then DMIN1 = a Else DMIN1 = b
End Function

Sub DEQUAT(x, y, yd)
Dim i&, CreateIndex As Boolean, U()

If FunSymb = True Then
    GoSub Eval_Parse
Else
    GoSub Eval_Worksheet
End If
Exit Sub

Eval_Worksheet:
Dim OrigCalcStatus As Integer
On Error Resume Next
OrigCalcStatus = Application.Calculation
Application.Calculation = xlCalculationManual
    Range(myRangeVar).Cells(1) = x
    For i = 1 To UBound(y)
        Range(myRangeVar).Cells(1 + i) = y(i)
    Next i
Application.Calculate
Application.Calculation = OrigCalcStatus
    For i = 1 To UBound(y)
        yd(i) = Range(myRangeFun).Cells(i)
        EvalCounter = EvalCounter + 1
    Next i
Return

Eval_Parse:
    CreateIndex = False
    If EvalCounter = 0 Then CreateIndex = True
    Var(1).valr = x
    For i = 1 To UBound(y)
        Var(i + 1).valr = y(i)
    Next i
    Vector_Function_Eval Funct, Var, U, CreateIndex
    If Err Then ErrMsg = Err.Description
    For i = 1 To UBound(y)
        yd(i) = U(i)
        EvalCounter = EvalCounter + 1
    Next i
Return

End Sub



VBA Filename MultipSVD.bas Extracted Macro
Option Private Module
Option Explicit
Dim CS(1) As xNum

'===================================================================================================================0
'  SVD in multiprecision - 7-3-2005
'=======================================================================================================

Sub xSVD_decomp(a, w, v, Digit_Max, Optional ETA, Optional WantU As Boolean = True, Optional WantV As Boolean = True)
'-------------------------------------------------------------
' SVD Routine
'------------------------------------------------------------
'Given a matrix a(1:m,1:n), with physical dimensions mp by np, this routine computes its
'singular value decomposition, A = U * W * V ^t . The matrix U replaces A on output. The
'diagonal matrix of singular values W is output as a vector w(1:n). The matrix V (not the
'transpose V T ) is output as V(1:n,1:n).
Dim i%, its%, j%, jj%, k%, l%, NM%, DgMx&
Dim a_norma, f$, g, h, vn, t1, t2, t3 ', C, S
Dim scale_, x, y, z, m&, n&
Dim rv$()
'-------------------
SetDgMx DgMx, Digit_Max
If IsMissing(ETA) Then ETA = "1E-" & DgMx
m = UBound(a, 1)
n = UBound(a, 2)
ReDim w(1 To n) As String, rv$(1 To n)

'------------------------------------------------------
xHouseholder_reduction a, w, rv, DgMx
''------------------------------------------------------
If WantV Then
  ReDim v(1 To n, 1 To n) As String
  xAccum_right_hand a, v, rv, DgMx
End If
''-----------------------------------------------------
If WantU Then xAccum_left_hand a, w, DgMx
'--------------------------------------------------------

a_norma = 0
'a_norma = "1e2147483647"
For i = 1 To n
    f = xAbsR(w(i))
'  F = xAddR(xAbsR(W(i)), xAbsR(rv(i)), DgMx)
    If xComp(f, a_norma) > 0 Then a_norma = f
'    If xComp(F, a_norma) < 0 Then If xComp(F) <> 0 Then a_norma = F
Next i
a_norma = xMultR(a_norma, ETA, DgMx)

For k = n To 1 Step -1 'Diagonalization of the bidiagonal form: Loop over singular values, and over allowed iterations.
    For its = 1 To 30
       For l = k To 1 Step -1 'Test for splitting.
          NM = l - 1
          If xComp(xAbsR(rv(l)), a_norma) <= 0 Then GoTo Label2
          If xComp(xAbsR(w(NM)), a_norma) <= 0 Then Exit For
       Next l

'        C = 0 'Cancellation  if l > 1.
'        S = 1
        CS(0).ndgt = 0
        CS(1).ndgt = 1: CS(1).dgt(0) = 1: CS(1).Sign = False: CS(1).esp = 0
        For i = l To k
           SinCosMult rv(i), f, DgMx
           If xComp(xAbsR(f), a_norma) <= 0 Then Exit For
           
           g = w(i)
           xPythag h, f, g, DgMx
           w(i) = h
           CalcSinCos g, xNegR(f), h, DgMx
           If WantU Then
            For j = 1 To m
               xRotate_ a(j, NM), a(j, i), DgMx
            Next j
           End If
        Next i
Label2:
        z = w(k)
        If l = k Then 'Convergence.
           If xCompZ(z) < 0 Then 'Singular value is made nonnegative.
              w(k) = xNegR(z)
              If WantV Then
               For j = 1 To n
                  v(j, k) = xNegR(v(j, k))
               Next
              End If
           End If
           Exit For
        End If
        If its = 30 Then Exit Sub 'no convergence in svd_decomp'
        x = w(l) 'Shift from bottom 2-by-2 minor.
        NM = k - 1
        y = w(NM)
        g = rv(NM)
        h = rv(k)
        t1 = xMultR(xSubR(y, z, DgMx), xAddR(y, z, DgMx), DgMx)
        t2 = xMultR(xSubR(g, h, DgMx), xAddR(g, h, DgMx), DgMx)
        t3 = xMultR(xMultR(2, h, DgMx), y, DgMx)
        f = xDivR(xAddR(t1, t2, DgMx), t3, DgMx)
        g = xSqr(xIncrSq(f, DgMx), DgMx)
        If xCompZ(f) < 0 Then g = xNegR(g)
        t1 = xMultR(xSubR(x, z, DgMx), xAddR(x, z, DgMx), DgMx)
        t2 = xSubR(xDivR(y, xAddR(f, g, DgMx), DgMx), h, DgMx)
        f = xDivR(xAddR(t1, xMultR(h, t2, DgMx), DgMx), x, DgMx)
'        C = 1 'Next QR transformation:
'        S = 1
        CS(0).ndgt = 1: CS(0).dgt(0) = 1: CS(0).Sign = False: CS(0).esp = 0
        CS(1).ndgt = 1: CS(1).dgt(0) = 1: CS(1).Sign = False: CS(1).esp = 0
        For j = l To NM
           i = j + 1
           g = rv(i)
           y = w(i)
           SinCosMult g, h, DgMx
           xPythag z, f, h, DgMx
           rv(j) = z
           CalcSinCos f, h, z, DgMx
           xRotate x, g, f, g, DgMx
           SinCosMult y, h, DgMx
          If WantV Then
           For jj = 1 To n
              xRotate_ v(jj, j), v(jj, i), DgMx
           Next
          End If
           xPythag z, f, h, DgMx
           w(j) = z 'Rotation can be arbitrary if z = 0.
           If xCompZ(z) <> 0 Then CalcSinCos f, h, z, DgMx
           xRotate g, y, f, x, DgMx
          If WantU Then
           For jj = 1 To m
              xRotate_ a(jj, j), a(jj, i), DgMx
           Next
          End If
        Next
        rv(l) = 0
        rv(k) = f
        w(k) = x
    Next its
Next k

End Sub

Sub SinCosMult(x, y, DgMx&)
Cvt2xNum tXN(0), x, DgMx
SxMult_ tXN(1), CS(1), tXN(0), DgMx
y = xNum2str(tXN(1))
xMult_ tXN(0), CS(0), tXN(0), DgMx
x = xNum2str(tXN(0))
End Sub

Sub CalcSinCos(x, y, z, DgMx&)
Cvt2xNum tXN(1), z, DgMx: Cvt2xNum tXN(0), x, DgMx
xDiv_ CS(0), tXN(0), tXN(1), DgMx: Cvt2xNum tXN(0), y, DgMx
xDiv_ CS(1), tXN(0), tXN(1), DgMx
End Sub

Sub SetSinCos(s, c, DgMx&)
Cvt2xNum CS(0), c, DgMx: Cvt2xNum CS(1), s, DgMx
End Sub

Sub xRotate_(x, y, DgMx&)  'perform rotation
Cvt2xNum tXN(2), x, DgMx: Cvt2xNum tXN(1), y, DgMx
SxMult_ tXN(0), CS(1), tXN(1), DgMx
SxMult_ tXN(3), CS(0), tXN(2), DgMx
xAdd_ tXN(0), tXN(3), tXN(0), DgMx
x = xNum2str(tXN(0))
SxMult_ tXN(2), CS(1), tXN(2), DgMx
SxMult_ tXN(1), CS(0), tXN(1), DgMx
xSub_ tXN(1), tXN(1), tXN(2), DgMx
y = xNum2str(tXN(1))
End Sub

Sub xRotate(x1, x2, y1, y2, DgMx&)  'perform rotation
Cvt2xNum tXN(1), x1, DgMx: Cvt2xNum tXN(0), x2, DgMx
SxMult_ tXN(2), CS(1), tXN(0), DgMx
SxMult_ tXN(3), CS(0), tXN(1), DgMx
xAdd_ tXN(2), tXN(3), tXN(2), DgMx
y1 = xNum2str(tXN(2))
SxMult_ tXN(0), CS(0), tXN(0), DgMx
SxMult_ tXN(1), CS(1), tXN(1), DgMx
xSub_ tXN(0), tXN(0), tXN(1), DgMx
y2 = xNum2str(tXN(0))
End Sub

Sub xPythag(z, x, y, DgMx&)
Cvt2xNum tXN(0), x, DgMx: Cvt2xNum tXN(1), y, DgMx
xMult_ tXN(0), tXN(0), tXN(0), DgMx
xMult_ tXN(1), tXN(1), tXN(1), DgMx
xAdd_ tXN(0), tXN(0), tXN(1), DgMx
xSqr_ tXN(0), tXN(0), DgMx
z = xNum2str(tXN(0))
End Sub

Private Sub xHouseholder_reduction(a, w, rv, DgMx&)
Dim i%, j%, k%, l%, m%, n%
Dim f, g, h, s, scale_  ',anorm, sq

m = UBound(a, 1)
n = UBound(a, 2)
g = 0 'Householder reduction to bidiagonal form.
scale_ = 0
'anorm = 0
For i = 1 To n
  l = i + 1
  rv(i) = xMultR(scale_, g, DgMx)
  g = 0
  s = 0
  scale_ = 0
  If i <= m Then
    For k = i To m
      scale_ = xAddR(scale_, xAbsR(a(k, i)), DgMx)
    Next
    If xCompZ(scale_) <> 0 Then
      For k = i To m
        a(k, i) = xDivR(a(k, i), scale_, DgMx)
        s = xAddR(s, xMultSq((a(k, i)), DgMx), DgMx)
      Next
      f = a(i, i)
'      sq = xSqr(S, DgMx)
'      G = xNegR(xSign(sq, F))
      If xCompZ(f) < 0 Then g = xSqr(s, DgMx) Else g = xNegR(xSqr(s, DgMx))
      h = xSubR(xMultR(f, g, DgMx), s, DgMx)
      a(i, i) = xSubR(f, g, DgMx)
      For j = l To n
        s = 0
        For k = i To m
          s = xAddR(s, xMultR(a(k, i), a(k, j), DgMx), DgMx)
        Next
        f = xDivR(s, h, DgMx)
        For k = i To m
          a(k, j) = xAddR(a(k, j), xMultR(f, a(k, i), DgMx), DgMx)
        Next
      Next j
      For k = i To m
        a(k, i) = xMultR(scale_, a(k, i), DgMx)
      Next
    End If
  End If
  w(i) = xMultR(scale_, g, DgMx)
  g = 0
  s = 0
  scale_ = 0
  If i <= m And i <> n Then
    For k = l To n
      scale_ = xAddR(scale_, xAbsR(a(i, k)), DgMx)
    Next
    If xCompZ(scale_) <> 0 Then
      For k = l To n
        a(i, k) = xDivR(a(i, k), scale_, DgMx)
        s = xAddR(s, xMultSq(dCStr_(a(i, k)), DgMx), DgMx)
      Next
      f = a(i, l)
'      sq = xSqr(S, DgMx)
'      G = xNegR(xSign(sq, F))
      If xCompZ(f) < 0 Then g = xSqr(s, DgMx) Else g = xNegR(xSqr(s, DgMx))
      h = xSubR(xMultR(f, g, DgMx), s, DgMx)
      a(i, l) = xSubR(f, g, DgMx)
      For k = l To n
        rv(k) = xDivR(a(i, k), h, DgMx)
      Next
      For j = l To m
        s = 0
        For k = l To n
          s = xAddR(s, xMultR(a(j, k), a(i, k), DgMx), DgMx)
        Next
        For k = l To n
          a(j, k) = xAddR(a(j, k), xMultR(s, rv(k), DgMx), DgMx)
        Next
      Next j
      For k = l To n
        a(i, k) = xMultR(scale_, a(i, k), DgMx)
      Next
    End If
  End If
'  S = xAddR(xAbsR(W(i)), xAbsR(rv(i)), DgMx)
'  If xComp(S, anorm) > 0 Then anorm = S
Next i

End Sub

'Private Function xSign(X, Y) As String
'If xComp(Y) >= 0 Then xSign = xAbs(X) Else xSign = xNegR(xAbs(X))
'End Function

Private Sub xAccum_right_hand(a, v, rv, DgMx&)
Dim i&, j&, k&, n&, m&, l&
Dim g, s
m = UBound(a, 1)
n = UBound(a, 2)
g = 0
For i = n To 1 Step -1 'Accumulation of right-hand transformations.
   If i < n Then
      If xCompZ(g) <> 0 Then
         For j = l To n 'Double division to avoid possible under ow.
            v(j, i) = xDivR(xDivR(a(i, j), a(i, l), DgMx), g, DgMx)
         Next
         For j = l To n
            s = 0
            For k = l To n
               s = xAddR(s, xMultR(a(i, k), v(k, j), DgMx), DgMx)
            Next
            For k = l To n
               v(k, j) = xAddR(v(k, j), xMultR(s, v(k, i), DgMx), DgMx)
            Next
         Next
      End If
      For j = l To n
         v(i, j) = 0
         v(j, i) = 0
      Next
   End If
   v(i, i) = 1
   g = rv(i)
   l = i
Next

End Sub

Private Sub xAccum_left_hand(a, w, DgMx&)
Dim i&, j&, k&, n&, m&, l&, f$, s$
Dim g
m = UBound(a, 1)
n = UBound(a, 2)
For i = min_(m, n) To 1 Step -1 'Accumulation of left-hand transformations.
   l = i + 1
   g = w(i)
   For j = l To n
      a(i, j) = 0
   Next j
   If xCompZ(g) <> 0 Then
      g = xInvR(g, DgMx)
      For j = l To n
         s = 0
         For k = l To m
            s = xAddR(s, xMultR(a(k, i), a(k, j), DgMx), DgMx)
         Next
         f = xMultR(xDivR(s, a(i, i), DgMx), g, DgMx)
         For k = i To m
            a(k, j) = xAddR(a(k, j), xMultR(f, a(k, i), DgMx), DgMx)
         Next
      Next j
      For j = i To m
         a(j, i) = xMultR(a(j, i), g, DgMx)
      Next j
   Else
      For j = i To m
         a(j, i) = 0
      Next j
   End If
   a(i, i) = xIncr(a(i, i))
Next
End Sub

'Sub xSVD_sort(a, v, w)
''Descending Sort for mat A, V, w of SVD decomposition
'Dim Flag_exchanged As Boolean, c, a1$, a2$, i_min&, i_max&, i&, k&
'i_min = LBound(w, 1): i_max = UBound(w, 1)
'Do
'    Flag_exchanged = False
'    For i = i_min To i_max Step 2
'        k = i + 1
'        If k > i_max Then Exit For
'        a1 = xAbs(w(i))
'        a2 = xAbs(w(k))
'        If xComp(a1, a2) < 0 Then
'            'swap
'            c = w(k): w(k) = w(i): w(i) = c
'            SwapCol a, k, i
'            SwapCol v, k, i
'            Flag_exchanged = True
'        End If
'    Next
'    If i_min = LBound(w) Then
'        i_min = LBound(w) + 1
'    Else
'        i_min = LBound(w)
'    End If
'Loop Until Flag_exchanged = False And i_min = LBound(w)
'End Sub

Function MatTI(mat)
Mat_Transp mat, MatTI
End Function

Sub Mat_Transp(mat, Mat_t)
Dim n&, m&, i&, j&
n = UBound(mat, 1)
m = UBound(mat, 2)
ReDim Mat_t(1 To m, 1 To n)
For i = 1 To n
For j = 1 To m
    Mat_t(j, i) = mat(i, j)
Next j
Next i
End Sub

Sub xSVD_sortALL(ByVal a, ByVal v, ByVal w, U, oV, d, Digit_Max)
Dim i&, j&, m&, n&, DgMx&
m = UBound(a, 1): n = UBound(a, 2)
ReDim pa%(1 To n)
For i = 1 To n: pa(i) = i: d(i) = xAbsR(w(i)): Next
xQuickSort d, pa, 1, n
If Digit_Max < 0 Then ' unformatted strings with d/w = Inverted matrix(n,n) ,u/a=Transposed
  For i = 1 To n: For j = 1 To n: If pa(j) <> j Then oV(i, j) = v(i, pa(j))
  Next j, i
  DgMx = SMPadj - Digit_Max
  If n < m Then
    ReDim U(1 To n, 1 To m) As String
    For i = 1 To m: For j = 1 To n: U(j, i) = a(i, pa(j)): Next j, i
    ReDim d(1 To n, 1 To n) As String
    For i = 1 To n: For j = 1 To n
      If i = j And xCompZ(w(pa(i))) <> 0 Then d(i, j) = xInvR(w(pa(i)), DgMx) Else d(i, j) = 0
    Next j, i
  Else
    ReDim U(1 To m, 1 To m) As String
    For i = 1 To m: For j = 1 To m: U(j, i) = a(i, pa(j)): Next j, i
    ReDim d(1 To n, 1 To m) As String
    For i = 1 To n: For j = 1 To m
      If i = j And xCompZ(w(pa(i))) <> 0 Then d(i, j) = xInvR(w(pa(i)), DgMx) Else d(i, j) = 0
    Next j, i
  End If
ElseIf Digit_Max = 0 Then ' we want them converted to doubles
  ReDim d(1 To 1, 1 To n) As Double, U(1 To m, 1 To n) As Double, oV(1 To n, 1 To n) As Double
  For i = 1 To m: For j = 1 To n
    U(i, j) = a(i, pa(j))
  Next j, i
  For i = 1 To n: d(1, i) = w(pa(i))
    For j = 1 To n: oV(i, j) = v(i, pa(j))
  Next j, i
Else ' formatted strings with d a vector(1,n)
  ReDim d(1 To 1, 1 To n) As String, U(1 To m, 1 To n) As String, oV(1 To n, 1 To n) As String
  For i = 1 To m: For j = 1 To n
    U(i, j) = xFmtStr(a(i, pa(j)), Digit_Max)
  Next j, i
  For i = 1 To n: d(1, i) = xFmtStr(w(pa(i)), Digit_Max)
    For j = 1 To n: oV(i, j) = xFmtStr(v(i, pa(j)), Digit_Max)
  Next j, i
End If
End Sub

Sub xSVD_sortD(a, v, w, d, Digit_Max)
Dim n&, i&, j&, m&
n = UBound(w, 1)
ReDim pa%(1 To n), d(1 To n) As String
For i = 1 To n: pa(i) = i: d(i) = xAbsR(w(i)): Next
xQuickSort d, pa, 1, n
m = min_(UBound(a, 1), UBound(a, 2))
ReDim d(1 To m, 1 To n) As String
For i = 1 To m: For j = 1 To n
  If i = j And xCompZ(w(pa(i))) <> 0 Then d(i, j) = xFmtStr(w(pa(i)), Digit_Max) Else d(i, j) = 0
Next j, i
End Sub

Sub xSVD_sortU(a, v, w, U, Digit_Max)
Dim m&, n&, i&, j&
m = UBound(a, 1): n = UBound(a, 2)
ReDim pa%(1 To n)
For i = 1 To n: pa(i) = i: w(i) = xAbsR(w(i)): Next
xQuickSort w, pa, 1, n
ReDim U(1 To m, 1 To n) As String
For i = 1 To m: For j = 1 To n
  U(i, j) = xFmtStr(a(i, pa(j)), Digit_Max)
Next j, i
ReDim Preserve U(1 To m, 1 To min_(UBound(a, 2), UBound(a, 1))) As String
End Sub

Sub xSVD_sortV(a, v, w, oV, Digit_Max)
Dim n&, i&, j&
n = UBound(w, 1)
ReDim pa%(1 To n)
For i = 1 To n: pa(i) = i: w(i) = xAbsR(w(i)): Next
xQuickSort w, pa, 1, n
ReDim oV(1 To n, 1 To n) As String
For i = 1 To n: For j = 1 To n
  oV(i, j) = xFmtStr(v(i, pa(j)), Digit_Max)
Next j, i
End Sub

Private Sub xQuickSort(a, pa%(), intLeft&, intRight&)
'pa(pointer into a) must be initalized to [1,2,3,...UBound(a)] - unsorted
'only pa is altered to reflex the sorted order, in case a is long strings(slow to move)
Dim i&, j&, TstVal, intMid&, tmp%
If intLeft < intRight Then
  intMid = (intLeft + intRight) \ 2
  TstVal = a(pa(intMid))
  i = intLeft: j = intRight
  Do
    Do While xComp(a(pa(i)), TstVal) = 1
      i = i + 1
    Loop
    Do While xComp(a(pa(j)), TstVal) = -1
      j = j - 1
    Loop
    If i <= j Then
      tmp = pa(i): pa(i) = pa(j): pa(j) = tmp
      i = i + 1
      j = j - 1
    End If
  Loop Until i > j
  If j <= intMid Then
    Call xQuickSort(a, pa, intLeft, j)
    Call xQuickSort(a, pa, i, intRight)
  Else
    Call xQuickSort(a, pa, i, intRight)
    Call xQuickSort(a, pa, intLeft, j)
  End If
End If
End Sub
VBA Filename EllipticIntegrals.bas Extracted Macro
Option Explicit

Function xIElliptic1(phi, k, Optional AngleSet, Optional Digit_Max, Optional ArcLen As Boolean)
Attribute xIElliptic1.VB_Description = "Elliptic integral of 1st kind (array can return 2nd kind to 2nd cell)\nAngleSet is RAD(default), DEG, or GRAD\nDigit_Max  -1=quad prec, 0=double prec, >0 extended prec (default)\nArcLen as Boolean(default=FALSE)"
Attribute xIElliptic1.VB_HelpID = 290
Attribute xIElliptic1.VB_ProcData.VB_Invoke_Func = " \n14"
' complete or incomplete elliptic integral 1st and 2nd kind
If VarType(phi) < vbInteger Then Exit Function
Dim e(1)
If IsMissing(Digit_Max) Then Digit_Max = Digits_Def
  Select Case Sgn(Digit_Max)
    Case 1: Call xELIT(k, phi, e(0), e(1), AngleSet, Digit_Max, ArcLen)
    Case 0: Call dELIT(k, phi, e(0), e(1), AngleSet, ArcLen)
    Case Else: Call qELIT(k, phi, e(0), e(1), AngleSet, ArcLen)
  End Select
If ChkArrayRet Then PasteVector2 xIElliptic1, e Else xIElliptic1 = e(0)
End Function

Function xIElliptic2(phi, k, Optional AngleSet, Optional Digit_Max, Optional ArcLen As Boolean)
Attribute xIElliptic2.VB_Description = "Elliptic integral of 2nd kind (array can return 1st kind to 2nd cell)\nAngleSet is RAD(default), DEG, or GRAD\nDigit_Max  -1=quad prec, 0=double prec, >0 extended prec (default)\nArcLen as Boolean(default=FALSE)"
Attribute xIElliptic2.VB_HelpID = 290
Attribute xIElliptic2.VB_ProcData.VB_Invoke_Func = " \n14"
' complete or incomplete elliptic integral 2nd and 1st kind
If VarType(phi) < vbInteger Then Exit Function
Dim e(1)
If IsMissing(Digit_Max) Then Digit_Max = Digits_Def
  Select Case Sgn(Digit_Max)
    Case 1: Call xELIT(k, phi, e(1), e(0), AngleSet, Digit_Max, ArcLen)
    Case 0: Call dELIT(k, phi, e(1), e(0), AngleSet, ArcLen)
    Case Else: Call qELIT(k, phi, e(1), e(0), AngleSet, ArcLen)
  End Select
If ChkArrayRet Then PasteVector2 xIElliptic2, e Else xIElliptic2 = e(0)
End Function

Sub dELIT(ByVal k#, phi, FE, EE, Optional AngleSet, Optional ArcLen As Boolean)
' ==================================================
'       Purpose: Compute complete and incomplete elliptic
'                integrals F(k,phi) and E(k,phi)
'       Input  : k   --- Modulus  ( -1 <= k <= 1 )
'                Phi --- Angle, 90 degrees = complete
'                AngleSet ---  default="RAD","DEG", or "GRAD"
'                ArcLen --- TRUE or FALSE(default) for Periodic
'       Output : FE  --- F(k,phi)
'                EE  --- E(k,phi)
' ==================================================
Const Two# = 2, One# = 1
Dim g1#, A0#, B0#, a1#, b1#, c1#, D0#, d1#, FAC#, CK#, CE#, HK#, NC#
Dim n&, phi90 As Boolean, Tiny#, NegFlg As Boolean, NCisEVEN As Boolean
D0 = phi
If IsMissing(AngleSet) Then GoTo ItIsRAD
Select Case UCase(AngleSet)
  Case "RAD"
ItIsRAD: A0 = D0 / Pi2_
  Case "DEG": A0 = D0 / 90#: D0 = Pi_180 * D0
  Case Else: A0 = D0 / 100#: D0 = Pi_200 * D0 ' "GRAD"
End Select
NC = Fix(A0) 'Calc # of "complete"
If A0 = NC Then
  If ArcLen Then
    If NC = 0 Then GoTo ZeroExit
    NC = Abs(NC)
  Else
    A0 = NC / Two: If Fix(A0) = A0 Then GoTo ZeroExit
    A0 = Int(A0) / Two: If Fix(A0) = A0 Then NC = One Else NC = -One
  End If
  phi90 = True
Else 'Incomplete
  NC = Abs(NC)
  If Not ArcLen Then NegFlg = vIntMod(NC, 4) > One Xor D0 < 0
  D0 = Abs(D0)
  A0 = NC / Two
  If Int(A0) = A0 Then
    NCisEVEN = True
    D0 = D0 - NC * Pi2_
  Else 'compute complement
    NC = NC + One
    D0 = NC * Pi2_ - D0
  End If
End If

HK = k * k
If HK = One Then
  If Not phi90 Then
    FE = Cos(D0)
    EE = Sin(D0)
    If EE > 0.34 Then
      FE = Log(Abs((One + EE) / FE))
    Else
      HK = EE * EE
      If HK < 4.61720117268627E-16 Then
        FE = EE
      Else
        FE = HK / 39
        For n = 37 To 3 Step -2
          FE = HK * (One / n + FE)
        Next
        FE = EE * (One + FE)
  End If: End If: End If
  CK = CDbl(VbMax): CE = One
Else
  g1 = 0: A0 = One: FAC = One
  If HK > 0.25 Then B0 = Sqr((One - k) * (One + k)) Else B0 = Sqr(One - HK)
  Tiny = 3E-16
  For n = 1 To 40
     a1 = (A0 + B0) / Two
     b1 = Sqr(A0 * B0)
     c1 = (A0 - B0) / Two
     FAC = Two * FAC
     HK = HK + FAC * c1 * c1
     If Not phi90 Then
        d1 = D0 + Atn((B0 / A0) * Tan(D0))
        g1 = g1 + c1 * Sin(d1)
        D0 = d1 + Pi_ * Int(d1 / Pi_ + 0.5)
     End If
     If Abs(c1 / a1) < Tiny Then Exit For
     A0 = a1: B0 = b1
  Next n
  CK = Pi2_ / a1
  CE = CK * (One - HK / Two)
  If Not phi90 Then
    FE = d1 / (FAC * a1)
    EE = FE * CE / CK + g1
  End If
End If

On Error Resume Next
If phi90 Then
    EE = NC * CE: FE = NC * CK
ElseIf ArcLen Then
  If NCisEVEN Then
    EE = NC * CE + EE: FE = NC * CK + FE
  Else
    EE = NC * CE - EE: FE = NC * CK - FE
  End If
ElseIf NegFlg Then
  FE = -FE: EE = -EE
End If
If Err Then FE = CDbl(VbMax)
Exit Sub

ZeroExit: FE = 0#: EE = FE
End Sub

Sub qELIT(ByVal k, phi, FE, EE, Optional AngleSet, Optional ArcLen As Boolean)
Dim g1, A0, B0, a1, b1, c1, D0, d1, FAC, CK, CE, HK, NC
Dim n&, Tiny, NegFlg As Boolean, phi90 As Boolean
D0 = CDec_(phi): A0 = Abs(D0)
If IsMissing(AngleSet) Then GoTo ItIsRAD
Select Case UCase(AngleSet)
  Case "RAD"
ItIsRAD: If Not ArcLen Then D0 = qAdjPi(phi): A0 = Abs(D0)
  A0 = A0 / qPi2_
  Case "DEG": A0 = A0 / 90: D0 = q2Pi_ * (D0 / 360)
  Case Else: A0 = A0 / 100: D0 = q2Pi_ * (D0 / 400) ' "GRAD"
End Select
NC = Int(A0)
'If A0 = NC Then phi90 = True:
If Abs(A0 - Round(A0)) < 5E-28 Then phi90 = True: NC = Round(A0): _
  If Not ArcLen Then A0 = NC / 2: If Int(A0) = A0 Then GoTo ZeroExit
D0 = D0 - q2Pi_ * Int(D0 / q2Pi_)
If D0 >= qPi_ Then D0 = D0 - qPi_: NegFlg = True

k = CDec_(k): HK = k * k
If HK = 1 Then
  FE = qCos(D0)
  If Not phi90 And FE <> 0 Then
    EE = qSin(D0)
    If EE < CDec("5508838915234365952E-28") Then FE = EE Else _
      FE = qLn(Abs((1 + EE) / FE))
  End If
  CK = CDbl(VbMax): CE = 1
Else
  If D0 > qPi2_ Then D0 = qPi_ - D0
'  If Abs(Abs(D0) - qPi2_) < 1E-27 Then phi90 = True
  g1 = CDec(0): A0 = CDec(1): FAC = A0
  If HK > 0.25 Then B0 = qSqr((1 - k) * (1 + k)) Else B0 = qSqr(1 - HK)
  Tiny = 1E-16
  For n = 1 To 40
    a1 = (A0 + B0) / 2
    b1 = qSqr(A0 * B0)
    c1 = (A0 - B0) / 2
    FAC = 2 * FAC
    HK = HK + FAC * c1 * c1
    If Not phi90 Then
      d1 = D0 + qAtan((B0 / A0) * qTan(D0))
      g1 = g1 + c1 * qSin(d1)
      D0 = d1 + qPi_ * Int(d1 / qPi_ + 0.5)
    End If
    If Abs(c1 / a1) <= Tiny Then Exit For
    A0 = a1: B0 = b1
  Next n
  CK = qPi2_ / a1
'  CE = qPi4_ * (2 - HK) / A1
  CE = CK * (1 - HK / 2)
  If Not phi90 Then
    FE = d1 / (FAC * a1)
    EE = FE * CE / CK + g1
  End If
End If

If ArcLen Then
  On Error Resume Next
  If phi90 Then
    EE = NC * CE: FE = NC * CK
    If Err Then If NC = 0 Then FE = 0
  ElseIf Pari(NC) Then
    EE = NC * CE + EE: FE = NC * CK + FE
  Else
    NC = NC + 1
    EE = NC * CE - EE: FE = NC * CK - FE
  End If
  If Err Then If NC <> 0 Then FE = CK
ElseIf phi90 Then
  If NegFlg Then FE = -CK: EE = -CE Else FE = CK: EE = CE
ElseIf NegFlg Then
  FE = -FE: EE = -EE
End If
If Abs(FE) < 2E-27 Then FE = 0
If Abs(EE) < 2E-27 Then EE = 0
FE = CStr(FE): EE = CStr(EE)
Exit Sub

ZeroExit: FE = vbStr0: EE = FE: Exit Sub
End Sub

Sub xELIT(k, phi, FE, EE, Optional AngleSet, Optional Digit_Max, Optional ArcLen As Boolean)
Dim g1$, A0$, B0$, a1$, b1$, c1$, D0$, d1$, FAC$, CK$, CE$, HK$, NC$, Pi$, pi2$, k1$
Dim n&, DgMx&, phi90 As Boolean, Tiny$, NegFlg As Boolean, NCisEVEN As Boolean
SetDgMx DgMx, Digit_Max
Cvt2xNum tXN(0), phi, DgMx
If tXN(0).ndgt = 0 Then GoTo ZeroExit
D0 = xNum2str(tXN(0))
DgMx = min_(DgMx + xNumberLength(tXN(0)), DIGITS_LIMIT)
pi2 = BC(xPi2_, DgMx)
If IsMissing(AngleSet) Then GoTo ItIsRAD
Select Case UCase(AngleSet)
  Case "RAD"
ItIsRAD: xDivQr D0, pi2, NC, g1, phi90: D0 = xAbs(g1): GoTo UseIncomplete
  Case "DEG": A0 = 90
  Case Else: A0 = 100 ' "GRAD"
End Select
xDivQr D0, A0, NC, g1, phi90
If phi90 Then 'Complete
  If ArcLen Then
    NC = xAbs(NC)
  Else
    A0 = xDivR(NC, 2, DgMx): If xIsInteger(A0) Then GoTo ZeroExit
    A0 = xDivR(xInt(A0), 2, DgMx): If xIsInteger(A0) Then NC = 1 Else NC = -1
  End If
Else 'Incomplete
  D0 = xMultR(xDivR(xAbs(g1), A0, DgMx), pi2, DgMx)
UseIncomplete: NC = xAbs(NC)
  If Not ArcLen Then NegFlg = xIntMod(NC, 4) > 1 Xor Asc(g1) = vbKeyMinus
  A0 = xDivR(NC, 2, DgMx)
  If xIsInteger(A0) Then
    NCisEVEN = True
  Else 'compute complement
    NC = xIncr(NC)
    D0 = xAngleC(D0, DgMx)
  End If
End If

k1 = xAbsR(k): HK = xMultSq(k1, DgMx)
If HK = vbStr1 Then
  CK = "1E+2147483648": CE = vbStr1
  If Not phi90 Then
    EE = xSin(D0, DgMx)
    If CDbl(EE) = 1 Then FE = xLn(xAbsR(xDivR(xIncr(EE), xCos(D0, DgMx), DgMx)), DgMx) Else _
      FE = xAtanh(EE, DgMx)
  End If
Else
  Pi = BC(xPi_, DgMx)
  g1 = 0: A0 = 1: FAC = 1
  If HK > 0.25 Then _
    B0 = xSqr(xMultR(xIncr("-" & k1), xIncr(k1), DgMx), DgMx) Else _
    B0 = xSqr(xIncr("-" & HK), DgMx)
  Tiny = "1E-" & Int((DgMx + 1) / 2)
  For n = 1 To Int(40 * (DgMx / 15) ^ 2)
     a1 = xDivR(xAddR(A0, B0, DgMx), 2, DgMx)
     b1 = xSqr(xMultR(A0, B0, DgMx), DgMx)
     c1 = xDivR(xSubR(A0, B0, DgMx), 2, DgMx)
     FAC = xMultR(2, FAC, DgMx)
     HK = xAddR(HK, xMultR(FAC, xMultSq(c1, DgMx), DgMx), DgMx)
     If Not phi90 Then
        d1 = xAddR(D0, xAtan(xMultR(xDivR(B0, A0, DgMx), xTan(D0, DgMx), DgMx), DgMx), DgMx)
        g1 = xAddR(g1, xMultR(c1, xSin(d1, DgMx), DgMx), DgMx)
        D0 = xAddR(d1, xMultR(Pi, xInt(xAddR(xDivR(d1, Pi, DgMx), 0.5, DgMx)), DgMx), DgMx)
     End If
     If xComp(xAbsR(xDivR(c1, a1, DgMx)), Tiny) < 0 Then Exit For
     A0 = a1: B0 = b1
  Next n
  CK = xDivR(pi2, a1, DgMx)
  CE = xMultR(CK, xIncr(xDivR(HK, -2, DgMx)), DgMx)
  If Not phi90 Then
    FE = xDivR(d1, xMultR(FAC, a1, DgMx), DgMx)
    EE = xAddR(xMultR(FE, xDivR(CE, CK, DgMx), DgMx), g1, DgMx)
  End If
End If
OverFlowFlg = False
If phi90 Then
    EE = xMultR(NC, CE, DgMx)
    FE = xMultR(NC, CK, DgMx)
ElseIf ArcLen Then
  If NCisEVEN Then
    EE = xAddR(xMultR(NC, CE, DgMx), EE, DgMx)
    FE = xAddR(xMultR(NC, CK, DgMx), FE, DgMx)
  Else
    EE = xSubR(xMultR(NC, CE, DgMx), EE, DgMx)
    FE = xSubR(xMultR(NC, CK, DgMx), FE, DgMx)
  End If
ElseIf NegFlg Then
  EE = xNegR(EE)
  FE = xNegR(FE)
End If
If OverFlowFlg Then If NC <> vbStr0 Then If Asc(NC) = vbKeyMinus Then FE = xNegR(CK) Else FE = CK
EE = xFmtStr(EE, Digit_Max)
FE = xFmtStr(FE, Digit_Max)
Exit Sub

ZeroExit: FE = vbStr0: EE = FE
End Sub

'****************************************
'All routines below should be considered as "work in progress"

Function xIElliptic3(phi, k, n, Optional AngleSet, Optional Digit_Max, Optional ArcLen As Boolean)
Attribute xIElliptic3.VB_Description = "Elliptic integral of 3rd kind\nAngleSet is RAD(default), DEG, or GRAD\nDigit_Max  -1=quad prec, 0=double prec, >0 extended prec (default)\nArcLen as Boolean(default=FALSE)"
Attribute xIElliptic3.VB_HelpID = 290
Attribute xIElliptic3.VB_ProcData.VB_Invoke_Func = " \n14"
' incomplete elliptic integral 3rd kind
If VarType(phi) < vbInteger Then Exit Function
Dim phi_rad
If IsMissing(Digit_Max) Then Digit_Max = Digits_Def
If IsMissing(AngleSet) Then AngleSet = "RAD"
Select Case Sgn(Digit_Max)
  Case 1
    Select Case UCase(AngleSet)
      Case "RAD": phi_rad = dCStr_(phi)
      Case "DEG": phi_rad = xMultR(BC(x2Pi_, Digit_Max * 2), xDivR(phi, 360, Digit_Max * 2), Digit_Max * 2)
      Case Else: phi_rad = xMultR(BC(x2Pi_, Digit_Max * 2), xDivR(phi, 400, Digit_Max * 2), Digit_Max * 2)
    End Select
    xIElliptic3 = xCarlson_P(phi_rad, k, n, ArcLen, Digit_Max)
  Case 0
    Select Case UCase(AngleSet)
      Case "RAD": phi_rad = phi
      Case "DEG": phi_rad = Pi_180 * phi
      Case Else: phi_rad = Pi_200 * phi
    End Select
    xIElliptic3 = dCarlson_P(phi_rad, k, n, ArcLen)
  Case Else
    Select Case UCase(AngleSet)
      Case "RAD": phi_rad = CDec_(phi)
      Case "DEG": phi_rad = q2Pi_ * (CDec_(phi) / 360)
      Case Else: phi_rad = q2Pi_ * (CDec_(phi) / 400)
    End Select
    xIElliptic3 = qCarlson_P(phi_rad, k, n, ArcLen)
End Select
End Function


Function dCarlson_P(phi_rad, ByVal k#, ByVal n#, Optional ArcLen As Boolean) As Double
If VarType(phi_rad) < vbInteger Then Exit Function
Dim sp#, ksp#, nsp#, NC#, NegFlg As Boolean
If Abs(k) > 1 Then ErrRaise: Exit Function
If ArcLen Then
  sp = phi_rad
  If Abs(sp) > Pi2_ Then
    NC = Int(sp / Pi_)
    sp = sp - NC * Pi_
    If sp > Pi2_ Then NegFlg = True: NC = NC + 1
  End If
  sp = Sin(sp)
Else
  sp = Sin(dAdjPi(phi_rad))
End If
ksp = k * sp
If Abs(ksp) <> 1 Then
  nsp = n * sp * sp
  Select Case Sgn(nsp - 1)
   Case -1
   Case 0: If sp = 1 Then dCarlson_P = VbMax: Exit Function
   Case 1: dCarlson_P = VbMax: Exit Function
  End Select
  ksp = sp * (dRF(kc(sp), kc(ksp), 1, 0.0001) + nsp / _
      3 * dRJ(kc(sp), kc(ksp), 1, 1 - nsp, 0.0001))
Else
  If n > 1 Then dCarlson_P = -CDbl(VbMax) Else dCarlson_P = CDbl(VbMax)
  Exit Function
End If
If ArcLen Then
  If NC Then
    sp = 2 * NC * dCarlson_P(Pi2_, k, n)
    If NegFlg Then ksp = -ksp
    ksp = Abs(sp + ksp)
  Else
    ksp = Abs(ksp)
  End If
End If
dCarlson_P = ksp
End Function

Function dCarlson_E(phi_rad, ByVal k#) As Double
If VarType(phi_rad) < vbInteger Then Exit Function
Dim sp#, ksp#
If Abs(k) > 1 Then ErrRaise: Exit Function

sp = Sin(phi_rad)
ksp = k * sp
If Abs(ksp) = 1 Then
  dCarlson_E = ksp
Else
  dCarlson_E = sp * (dRF(kc(sp), kc(ksp), 1, 0.0001) - _
    ksp * ksp / 3 * dRE(kc(sp), kc(ksp), 1, 0.0001))
End If
End Function

Function dCarlson_F(phi_rad, ByVal k#) As Double
If VarType(phi_rad) < vbInteger Then Exit Function
Dim sp#, ksp#
If Abs(k) > 1 Then ErrRaise: Exit Function

sp = Sin(phi_rad)
ksp = k * sp
If Abs(ksp) = 1 Then
  dCarlson_F = ksp * VbMax
Else
  dCarlson_F = sp * dRF(kc(sp), kc(ksp), 1, 0.0001)
End If
End Function

Function qCarlson_P(phi_rad, k, n, Optional ArcLen As Boolean)
If VarType(phi_rad) < vbInteger Then Exit Function
Dim sp, ksp, nsp, NC, NegFlg As Boolean
If Abs(k) > 1 Then qCarlson_P = "Carlson_P error: parameter out of range!": Exit Function
If ArcLen Then
  sp = CDec_(phi_rad)
  If Abs(sp) > qPi2_ Then
    NC = Int(sp / qPi_)
    sp = sp - NC * qPi_
    If sp > qPi2_ Then NegFlg = True: NC = NC + 1
  End If
  sp = qSin(sp)
Else
  sp = qSin(qAdjPi(phi_rad))
End If
ksp = CDec_(k) * sp
If Abs(ksp) <> 1 Then
  nsp = CDec_(n) * sp * sp
  Select Case Sgn(nsp - 1)
   Case -1
   Case 0: If sp = 1 Then qCarlson_P = "1E+2147483648": Exit Function
   Case 1: qCarlson_P = "Imaginary": Exit Function
  End Select
'  If nsp > 1 Then qCarlson_P = "Imaginary": Exit Function
  ksp = sp * (qRF(kc(sp), kc(ksp), CDec(1), CDec(0.000001)) + _
    nsp / 3 * qRJ(kc(sp), kc(ksp), CDec(1), 1 - nsp, CDec(0.000001)))
  If Abs(ksp) = 1E-28 Then ksp = 0
Else
  If n > 1 Then qCarlson_P = "-1E+2147483648" Else qCarlson_P = "1E+2147483648"
  Exit Function
End If
If ArcLen Then
  If NC Then
    sp = 2 * NC * CDec(qCarlson_P(Pi2_, k, n))
    If NegFlg Then ksp = -ksp
    ksp = Abs(sp + ksp)
  Else
    ksp = Abs(ksp)
  End If
End If
qCarlson_P = CStr(ksp)
End Function

Function qCarlson_E(phi_rad, k)
If VarType(phi_rad) < vbInteger Then Exit Function
Dim sp, ksp
If Abs(k) > 1 Then qCarlson_E = "Carlson_E error: parameter out of range!": Exit Function

sp = qSin(qAdjPi(CDec_(phi_rad)))
ksp = CDec_(k) * sp
If Abs(ksp) <> 1 Then
  ksp = sp * (qRF(kc(sp), kc(ksp), CDec(1), CDec(0.00000001)) - _
    ksp * ksp / 3 * qRE(kc(sp), kc(ksp), CDec(1), CDec(0.00000001)))
  If Abs(ksp) = 1E-28 Then ksp = 0
End If
qCarlson_E = CStr(ksp)
End Function

Function qCarlson_F(phi_rad, k)
If VarType(phi_rad) < vbInteger Then Exit Function
Dim sp, ksp
If Abs(k) > 1 Then qCarlson_F = "Carlson_F error: parameter out of range!": Exit Function

sp = qSin(qAdjPi(CDec_(phi_rad)))
ksp = CDec_(k) * sp
If Abs(ksp) = 1 Then
  sp = CDbl(ksp) * CDbl(VbMax)
Else
  sp = sp * qRF(kc(sp), kc(ksp), CDec(1), CDec(0.00000001))
  If Abs(sp) = 1E-28 Then sp = 0
End If
qCarlson_F = CStr(sp)
End Function

Private Function qAdjPi(x)
On Error GoTo UseX
qAdjPi = x - q2Pi_ * Int(x / q2Pi_)
If qAdjPi >= qPi_ Then qAdjPi = qAdjPi - q2Pi_
If qAdjPi = 0 Then
UseX: qAdjPi = CDec(xAdjPi(x, 30))
End If
End Function

Private Function dAdjPi(x) As Double
dAdjPi = x - TPi_ * Int(x / TPi_)
If dAdjPi >= Pi_ Then dAdjPi = dAdjPi - TPi_
If dAdjPi = 0 Then dAdjPi = xAdjPi(x, 20)
End Function

Private Function kc(k)
If Abs(k) > 0.5 Then kc = (1 - k) * (1 + k) Else kc = 1 - k * k
End Function

Private Function qRF(ByVal xN, ByVal YN, ByVal ZN, ByVal ERRTOL)
Dim LAMDA, MU, e2, e3, XNDEV, XNROOT, YNDEV, YNROOT, ZNDEV, ZNROOT

Do
  MU = (xN + YN + ZN) / 3
  XNDEV = 2 - (MU + xN) / MU
  YNDEV = 2 - (MU + YN) / MU
  ZNDEV = 2 - (MU + ZN) / MU
  If Abs(XNDEV) < ERRTOL Then If Abs(YNDEV) < ERRTOL Then If Abs(ZNDEV) < ERRTOL Then Exit Do
  XNROOT = qSqr(xN)
  YNROOT = qSqr(YN)
  ZNROOT = qSqr(ZN)
  LAMDA = XNROOT * (YNROOT + ZNROOT) + YNROOT * ZNROOT
  xN = (xN + LAMDA) * 0.25
  YN = (YN + LAMDA) * 0.25
  ZN = (ZN + LAMDA) * 0.25
Loop

e2 = XNDEV * YNDEV - ZNDEV * ZNDEV
e3 = XNDEV * YNDEV * ZNDEV
qRF = (1 + (e2 / 24 - 0.1 - 3 * e3 / 44) * e2 + e3 / 14) / qSqr(MU)
End Function

Private Function qRE(ByVal xN, ByVal YN, ByVal ZN, ByVal ERRTOL)
Dim LAMDA, MU, SIGMA, POWER4, XNDEV, XNROOT, YNDEV, s1, s2
Dim YNROOT, ZNDEV, ZNROOT, EA, EB, EC, ED, EF
SIGMA = 0: POWER4 = CDec(1)

Do
  MU = (xN + YN + 3 * ZN) * 0.2
  XNDEV = (MU - xN) / MU
  YNDEV = (MU - YN) / MU
  ZNDEV = (MU - ZN) / MU
  If Abs(XNDEV) < ERRTOL Then If Abs(YNDEV) < ERRTOL Then If Abs(ZNDEV) < ERRTOL Then Exit Do
  XNROOT = qSqr(xN)
  YNROOT = qSqr(YN)
  ZNROOT = qSqr(ZN)
  LAMDA = XNROOT * (YNROOT + ZNROOT) + YNROOT * ZNROOT
  SIGMA = SIGMA + POWER4 / (ZNROOT * (ZN + LAMDA))
  POWER4 = POWER4 * 0.25
  xN = (xN + LAMDA) * 0.25
  YN = (YN + LAMDA) * 0.25
  ZN = (ZN + LAMDA) * 0.25
Loop

EA = XNDEV * YNDEV
EB = ZNDEV * ZNDEV
EC = EA - EB
ED = EA - 6 * EB
EF = ED + EC + EC
s1 = ED * (CDec(-3) / 14 + 2.25 * ED / 22 - ZNDEV * 4.5 * EF / 26)
s2 = ZNDEV * (EF / 6 + ZNDEV * (-9 * EC / 22 + ZNDEV * 3 * EA / 26))
qRE = 3 * SIGMA + POWER4 * (1 + s1 + s2) / (MU * qSqr(MU))
End Function

Private Function dRF(ByVal xN#, ByVal YN#, ByVal ZN#, ByVal ERRTOL#) As Double
Const C25# = 0.25
Dim LAMDA#, MU#, e2#, e3#, XNDEV#, XNROOT#, YNDEV#, YNROOT#, ZNDEV#, ZNROOT#

Do
  MU = (xN + YN + ZN) / 3
  XNDEV = 2 - (MU + xN) / MU
  YNDEV = 2 - (MU + YN) / MU
  ZNDEV = 2 - (MU + ZN) / MU
  If Abs(XNDEV) < ERRTOL Then If Abs(YNDEV) < ERRTOL Then If Abs(ZNDEV) < ERRTOL Then Exit Do
  XNROOT = Sqr(xN)
  YNROOT = Sqr(YN)
  ZNROOT = Sqr(ZN)
  LAMDA = XNROOT * (YNROOT + ZNROOT) + YNROOT * ZNROOT
  xN = (xN + LAMDA) * C25
  YN = (YN + LAMDA) * C25
  ZN = (ZN + LAMDA) * C25
Loop

e2 = XNDEV * YNDEV - ZNDEV * ZNDEV
e3 = XNDEV * YNDEV * ZNDEV
dRF = (1 + (e2 / 24 - 0.1 - 3 * e3 / 44) * e2 + e3 / 14) / Sqr(MU)
End Function

Private Function dRE(ByVal xN#, ByVal YN#, ByVal ZN#, ByVal ERRTOL#) As Double
Const C25# = 0.25
Dim LAMDA#, MU#, SIGMA#, POWER4#, XNDEV#, YNDEV#, ZNDEV#
Dim XNROOT#, YNROOT#, ZNROOT#, EA#, EB#, EC#, ED#, EF#, s1#, s2#
SIGMA = 0: POWER4 = 1

Do
  MU = (xN + YN + 3 * ZN) * 0.2
  XNDEV = (MU - xN) / MU
  YNDEV = (MU - YN) / MU
  ZNDEV = (MU - ZN) / MU
  If Abs(XNDEV) < ERRTOL Then If Abs(YNDEV) < ERRTOL Then If Abs(ZNDEV) < ERRTOL Then Exit Do
  XNROOT = Sqr(xN)
  YNROOT = Sqr(YN)
  ZNROOT = Sqr(ZN)
  LAMDA = XNROOT * (YNROOT + ZNROOT) + YNROOT * ZNROOT
  SIGMA = SIGMA + POWER4 / (ZNROOT * (ZN + LAMDA))
  POWER4 = POWER4 * C25
  xN = (xN + LAMDA) * C25
  YN = (YN + LAMDA) * C25
  ZN = (ZN + LAMDA) * C25
Loop

EA = XNDEV * YNDEV
EB = ZNDEV * ZNDEV
EC = EA - EB
ED = EA - 6 * EB
EF = ED + EC + EC
s1 = ED * (-3 / 14# + 2.25 * ED / 22 - ZNDEV * 4.5 * EF / 26)
s2 = ZNDEV * (EF / 6 + ZNDEV * (-9 * EC / 22 + ZNDEV * 3 * EA / 26))
dRE = 3 * SIGMA + POWER4 * (1 + s1 + s2) / (MU * Sqr(MU))
End Function

Private Function dRJ(ByVal xN#, ByVal YN#, ByVal ZN#, ByVal PN#, ByVal ERRTOL#) As Double
Const C25# = 0.25
Dim ALFA#, BETA#, EA#, EB#, EC#, e2#, e3#, ETOLRC#, LAMDA#, MU#
Dim PNDEV#, POWER4#, SIGMA#, s1#, s2#, s3#, XNDEV#, XNROOT#, YNDEV#, YNROOT#, ZNDEV#, ZNROOT#
SIGMA = 0: POWER4 = 1: ETOLRC = 0.5 * ERRTOL

Do
  MU = (xN + YN + ZN + PN + PN) * 0.2
  XNDEV = (MU - xN) / MU
  YNDEV = (MU - YN) / MU
  ZNDEV = (MU - ZN) / MU
  PNDEV = (MU - PN) / MU
  If Abs(XNDEV) < ERRTOL Then If Abs(YNDEV) < ERRTOL Then If Abs(ZNDEV) < ERRTOL Then If Abs(PNDEV) < ERRTOL Then Exit Do
  XNROOT = Sqr(xN)
  YNROOT = Sqr(YN)
  ZNROOT = Sqr(ZN)
  LAMDA = XNROOT * (YNROOT + ZNROOT) + YNROOT * ZNROOT
  ALFA = PN * (XNROOT + YNROOT + ZNROOT) + XNROOT * YNROOT * ZNROOT
  ALFA = ALFA * ALFA
  BETA = PN * (PN + LAMDA) * (PN + LAMDA)
  SIGMA = SIGMA + POWER4 * dRC(ALFA, BETA, ETOLRC)
  POWER4 = POWER4 * C25
  xN = (xN + LAMDA) * C25
  YN = (YN + LAMDA) * C25
  ZN = (ZN + LAMDA) * C25
  PN = (PN + LAMDA) * C25
Loop

EA = XNDEV * (YNDEV + ZNDEV) + YNDEV * ZNDEV
EB = XNDEV * YNDEV * ZNDEV
EC = PNDEV * PNDEV
e2 = EA - 3 * EC
e3 = EB + 2 * PNDEV * (EA - EC)
s1 = 1 + e2 * (-3 / 14# + 9 * (e2 / 22 - e3 / 52))
s2 = EB * (1# / 6 - 6 * PNDEV / 22 + 3 * EC / 26)
s3 = PNDEV * EA * (1 / 3# - 3 * PNDEV / 22) - PNDEV * EC / 3
dRJ = 3 * SIGMA + POWER4 * (s1 + s2 + s3) / (MU * Sqr(MU))
End Function

Private Function dRC(ByVal xN#, ByVal YN#, ByVal ERRTOL#) As Double
Dim LAMDA#, MU#, SN#
Do
  MU = (xN + YN + YN) / 3
  SN = (YN + MU) / MU - 2
  If Abs(SN) <= ERRTOL Then Exit Do
  LAMDA = 2 * Sqr(xN) * Sqr(YN) + YN
  xN = (xN + LAMDA) * 0.25
  YN = (YN + LAMDA) * 0.25
Loop
SN = SN * SN * (0.3 + SN * (1# / 7 + SN * (0.375 + 9 * SN / 22)))
dRC = (1 + SN) / Sqr(MU)
End Function

Private Function qRJ(ByVal xN, ByVal YN, ByVal ZN, ByVal PN, ByVal ERRTOL)
Dim ALFA, BETA, c1, c2, C3, C4, EA, EB, EC, e2, e3, ETOLRC, LAMDA, MU
Dim PNDEV, POWER4, SIGMA, s1, s2, s3, XNDEV, XNROOT, YNDEV, YNROOT, ZNDEV, ZNROOT
SIGMA = 0: POWER4 = CDec(1): ETOLRC = 0.5 * ERRTOL

Do
  MU = (xN + YN + ZN + PN + PN) * 0.2
  XNDEV = (MU - xN) / MU
  YNDEV = (MU - YN) / MU
  ZNDEV = (MU - ZN) / MU
  PNDEV = (MU - PN) / MU
  If Abs(XNDEV) < ERRTOL Then If Abs(YNDEV) < ERRTOL Then If Abs(ZNDEV) < ERRTOL Then If Abs(PNDEV) < ERRTOL Then Exit Do
  XNROOT = qSqr(xN)
  YNROOT = qSqr(YN)
  ZNROOT = qSqr(ZN)
  LAMDA = XNROOT * (YNROOT + ZNROOT) + YNROOT * ZNROOT
  ALFA = PN * (XNROOT + YNROOT + ZNROOT) + XNROOT * YNROOT * ZNROOT
  ALFA = ALFA * ALFA
  BETA = PN * (PN + LAMDA) * (PN + LAMDA)
  SIGMA = SIGMA + POWER4 * qRC(ALFA, BETA, ETOLRC)
  POWER4 = POWER4 * 0.25
  xN = (xN + LAMDA) * 0.25
  YN = (YN + LAMDA) * 0.25
  ZN = (ZN + LAMDA) * 0.25
  PN = (PN + LAMDA) * 0.25
Loop
C4 = CDec(3): c1 = C4 / 14: c2 = 1 / C4: C3 = C4 / 22: C4 = C4 / 26
EA = XNDEV * (YNDEV + ZNDEV) + YNDEV * ZNDEV
EB = XNDEV * YNDEV * ZNDEV
EC = PNDEV * PNDEV
e2 = EA - 3 * EC
e3 = EB + 2 * PNDEV * (EA - EC)
s1 = 1 + e2 * (-c1 + 0.75 * C3 * e2 - 1.5 * C4 * e3)
s2 = EB * (0.5 * c2 + PNDEV * (-C3 - C3 + PNDEV * C4))
s3 = PNDEV * EA * (c2 - PNDEV * C3) - c2 * PNDEV * EC
qRJ = 3 * SIGMA + POWER4 * (s1 + s2 + s3) / (MU * qSqr(MU))
End Function

Private Function qRC(ByVal xN, ByVal YN, ByVal ERRTOL)
Dim LAMDA, MU, SN
'    xN = CDec_(xN): YN = CDec_(YN)
Do
  MU = (xN + YN + YN) / 3
  SN = (YN + MU) / MU - 2
  If Abs(SN) <= ERRTOL Then Exit Do
  LAMDA = 2 * qSqr(xN) * qSqr(YN) + YN
  xN = (xN + LAMDA) * 0.25
  YN = (YN + LAMDA) * 0.25
Loop
SN = SN * SN * (0.3 + SN * (CDec(1) / 7 + SN * (0.375 + 9 * SN / 22)))
qRC = (1 + SN) / qSqr(MU)
'    qRC = CStr(qRC)
End Function

Private Function xRC(x$, y$, ERRTOL$, d&) As String
Const C25$ = 0.25
Dim LAMDA$, MU$, SN$, xN$, YN$, n&
xN = x: YN = y
Do
  MU = xDivR(xAddR(xAddR(xN, YN, d), YN, d), 3, d)
  SN = xSubR(xDivR(xAddR(YN, MU, d), MU, d), 2, d)
  If xComp(xAbs(SN), ERRTOL) <= 0 Then Exit Do
  LAMDA = xAddR(xMultR(xMultR(2, xSqr(xN, d), d), xSqr(YN, d), d), YN, d)
  xN = xMultR(xAddR(xN, LAMDA, d), C25, d)
  YN = xMultR(xAddR(YN, LAMDA, d), C25, d)
  n = n + 1
Loop While n < 3 * d
xRC = xDivR(xIncr(xMultR(xMultSq(SN, d), xAddR("3E-1", xMultR(SN, xAddR(xInvR(7, d), _
  xMultR(SN, xAddR("375E-3", xDivR(xMultR(9, SN, d), 22, d), d), d), d), d), d), d)), xSqr(MU, d), d)
End Function

Private Function xRF(x$, y$, z$, ERRTOL$, d&) As String
Const C25$ = 0.25
Dim LAMDA$, MU$, e2$, e3$, XNDEV$, XNROOT$, YNDEV$, YNROOT$, ZNDEV$, ZNROOT$
Dim xN$, YN$, ZN$
xN = x: YN = y: ZN = z
Do
  MU = xDivR(xAddR(xAddR(xN, YN, d), ZN, d), 3, d)
  XNDEV = xSubR(2, xDivR(xAddR(MU, xN, d), MU, d), d)
  YNDEV = xSubR(2, xDivR(xAddR(MU, YN, d), MU, d), d)
  ZNDEV = xSubR(2, xDivR(xAddR(MU, ZN, d), MU, d), d)
  If xComp(xAbs(XNDEV), ERRTOL) < 0 Then _
    If xComp(xAbs(YNDEV), ERRTOL) < 0 Then _
      If xComp(xAbs(ZNDEV), ERRTOL) < 0 Then Exit Do
  XNROOT = xSqr(xN, d)
  YNROOT = xSqr(YN, d)
  ZNROOT = xSqr(ZN, d)
  LAMDA = xAddR(xMultR(XNROOT, xAddR(YNROOT, ZNROOT, d), d), xMultR(YNROOT, ZNROOT, d), d)
  xN = xMultR(xAddR(xN, LAMDA, d), C25, d)
  YN = xMultR(xAddR(YN, LAMDA, d), C25, d)
  ZN = xMultR(xAddR(ZN, LAMDA, d), C25, d)
Loop

e2 = xSubR(xMultR(XNDEV, YNDEV, d), xMultR(ZNDEV, ZNDEV, d), d)
e3 = xMultR(xMultR(XNDEV, YNDEV, d), ZNDEV, d)
xRF = xDivR(xAddR(xAddR(1, xMultR(xSubR(xSubR(xDivR(e2, 24, d), "1e-1", d), _
  xDivR(xMultR(3, e3, d), 44, d), d), e2, d), d), xDivR(e3, 14, d), d), xSqr(MU, d), d)
End Function

Private Function xRJ(x$, y$, z$, p$, ERRTOL$, d&) As String
Const C25$ = 0.25
Dim xN$, YN$, ZN$, PN$
Dim ALFA$, BETA$, c1$, c2$, C3$, C4$, EA$, EB$, EC$, e2$, e3$, ETOLRC$, LAMDA$, MU$
Dim PNDEV$, POWER4$, SIGMA$, s1$, s2$, s3$, XNDEV$, XNROOT$, YNDEV$, YNROOT$, ZNDEV$, ZNROOT$
xN = x: YN = y: ZN = z: PN = p
SIGMA = 0: POWER4 = 1: ETOLRC = xDivR(ERRTOL, 2, d)

Do
  MU = xDivR(xAddR(xAddR(xAddR(xAddR(xN, YN, d), ZN, d), PN, d), PN, d), 5, d)
  XNDEV = xDivR(xSubR(MU, xN, d), MU, d)
  YNDEV = xDivR(xSubR(MU, YN, d), MU, d)
  ZNDEV = xDivR(xSubR(MU, ZN, d), MU, d)
  PNDEV = xDivR(xSubR(MU, PN, d), MU, d)
  If xComp(xAbs(XNDEV), ERRTOL) < 0 Then _
    If xComp(xAbs(YNDEV), ERRTOL) < 0 Then _
      If xComp(xAbs(ZNDEV), ERRTOL) < 0 Then _
        If xComp(xAbs(PNDEV), ERRTOL) < 0 Then Exit Do
  XNROOT = xSqr(xN, d)
  YNROOT = xSqr(YN, d)
  ZNROOT = xSqr(ZN, d)
  LAMDA = xAddR(xMultR(XNROOT, xAddR(YNROOT, ZNROOT, d), d), xMultR(YNROOT, ZNROOT, d), d)
  ALFA = xAddR(xMultR(PN, xAddR(xAddR(XNROOT, YNROOT, d), ZNROOT, d), d), _
    xMultR(xMultR(XNROOT, YNROOT, d), ZNROOT, d), d)
  ALFA = xMultSq(ALFA, d)
  BETA = xAddR(PN, LAMDA, d)
  BETA = xMultR(PN, xMultSq(BETA, d), d)
  SIGMA = xAddR(SIGMA, xMultR(POWER4, xRC(ALFA, BETA, ETOLRC, d), d), d)
  POWER4 = xMultR(POWER4, C25, d)
  xN = xMultR(xAddR(xN, LAMDA, d), C25, d)
  YN = xMultR(xAddR(YN, LAMDA, d), C25, d)
  ZN = xMultR(xAddR(ZN, LAMDA, d), C25, d)
  PN = xMultR(xAddR(PN, LAMDA, d), C25, d)
Loop

C4 = 3: c1 = xDivR(C4, 14, d): c2 = xDivR(1, C4, d)
C3 = xDivR(C4, 22, d): C4 = xDivR(C4, 26, d)
EA = xAddR(xMultR(XNDEV, xAddR(YNDEV, ZNDEV, d), d), xMultR(YNDEV, ZNDEV, d), d)
EB = xMultR(xMultR(XNDEV, YNDEV, d), ZNDEV, d)
EC = xMultR(PNDEV, PNDEV, d)
e2 = xSubR(EA, xMultR(3, EC, d), d)
e3 = xAddR(EB, xMultR(xMultR(2, PNDEV, d), xSubR(EA, EC, d), d), d)
s1 = xAddR(1, xMultR(e2, xSubR(xAddR(xNegR(c1), xMultR(xMultR("75E-2", C3, d), e2, d), d), _
  xMultR(xMultR("15E-1", C4, d), e3, d), d), d), d)
s2 = xMultR(EB, xAddR(xMultR("5e-1", c2, d), xMultR(PNDEV, _
  xSubR(xSubR(xMultR(PNDEV, C4, d), C3, d), C3, d), d), d), d)
s3 = xSubR(xMultR(xMultR(PNDEV, EA, d), xSubR(c2, xMultR(PNDEV, C3, d), d), d), _
  xMultR(xMultR(c2, PNDEV, d), EC, d), d)
xRJ = xAddR(xMultR(3, SIGMA, d), xDivR(xMultR(POWER4, _
  xAddR(xAddR(s1, s2, d), s3, d), d), xMultR(MU, xSqr(MU, d), d), d), d)
End Function

Function xCarlson_P(phi_rad, k, n, Optional ArcLen As Boolean, Optional Digit_Max) As String
If VarType(phi_rad) < vbInteger Then Exit Function
Dim sp$, ksp$, nsp$, DgMx&, kcsp$, ERRTOL$, NC$, NegFlg As Boolean
If xComp1(k) > 0 Then xCarlson_P = "Carlson_P error: parameter out of range!": Exit Function
SetDgMx DgMx, Digit_Max
If ArcLen Then
  sp = dCStr_(phi_rad)
  If xComp(xAbsR(sp), BC(xPi2_, DgMx)) > 0 Then
    NC = xInt(xDivR(sp, BC(xPi_, DgMx), DgMx))
    sp = xSubR(sp, xMultR(NC, BC(xPi_, DgMx), DgMx), DgMx)
    If xComp(sp, BC(xPi2_, DgMx)) > 0 Then NegFlg = True: NC = xIncr(NC)
  End If
  sp = xSin(sp, DgMx)
Else
'  sp = xSin(xAdjPi(phi_rad, DgMx), DgMx)
  sp = xSin(phi_rad, DgMx)
End If
ksp = xMultR(k, sp, DgMx)
If xComp1(ksp) <> 0 Then
  kcsp = xMultSq(sp, DgMx)
  nsp = xMultR(kcsp, n, DgMx)
  Select Case xComp(nsp, 1)
   Case -1
   Case 0: If sp = "1" Then xCarlson_P = "1E+2147483648": Exit Function
   Case 1: xCarlson_P = "Imaginary": Exit Function
  End Select
'  If xComp(nsp, 1) > 0 Then xCarlson_P = "Imaginary": Exit Function
  kcsp = xIncr("-" & kcsp)
  ksp = xIncrSq(ksp, DgMx, True)
  ERRTOL = "1E-" & Int(Digit_Max / 5)
  ksp = xMultR(sp, xAddR(xRF(kcsp, ksp, 1, ERRTOL, DgMx), _
    xMultR(xDivR(nsp, 3, DgMx), xRJ(kcsp, ksp, 1, xIncr(xNeg(nsp)), ERRTOL, DgMx), DgMx), DgMx), DgMx)
Else
  If xComp(n, 1) > 0 Then xCarlson_P = "-1E+2147483648" Else xCarlson_P = "1E+2147483648"
  Exit Function
End If
If ArcLen Then
  If xComp(NC) Then
    sp = xCarlson_P(BC(xPi2_, DgMx), k, n, , DgMx)
    If sp = "Imaginary" Then xCarlson_P = sp: Exit Function
    sp = xMultR(xMultR(2, NC, DgMx), sp, DgMx)
    If NegFlg Then ksp = xNegR(ksp)
    ksp = xAbsR(xAddR(sp, ksp, DgMx))
  Else
    ksp = xAbsR(ksp)
  End If
End If
xCarlson_P = xFmtStr(ksp, Digit_Max)
End Function

Function Buli_el1(PhiRad, k)
Dim e#, g#, m#, y#, ca#, cb#, kc#, x#
Dim l%, numiter%
'
' EI 1st kind
'
' In order to obtain about D correct dec. figures, use
' ca = 10 ^ (-D / 2) And cb = 10 ^ (-(D + 2))
'
' we want D=20 => ca=1E-10, cb=1E-22
ca = 0.0000000001
cb = 1E-22

x = Tan(PhiRad)
If Abs(x) < 1E-307 Then Buli_el1 = 0#: Exit Function

kc = Abs(k)
If kc > 0.5 Then kc = Sqr((1# - kc) * (1# + kc)) Else kc = Sqr(1 - kc * kc)
' k=1 => kc=0
'If (Abs(kc) < 1E-307) Then
'   Buli_el1 = Log(x + Sqr(1# + x * x))
'              '==ArSinH(x) ; according to mathlib
'   Exit Function
'End If

y = Abs(1# / x)
m = 1#
l = 0
numiter = 0
Do
  numiter = numiter + 1
  e = m * kc
  g = m
  m = kc + m
  y = -e / y + y
  If y = 0 Then y = cb * Sqr(e)
  If Abs(g - kc) <= ca * g Then Exit Do
  kc = 2 * Sqr(e)
  l = 2 * l
  If y < 0 Then l = 1 + l
Loop While numiter < 200
If numiter >= 200 Then Buli_el1 = "Error: no convergence. Most likely, kc is too small.": Exit Function

If y < 0 Then l = 1 + l
e = (Atn(m / y) + l * Pi_) / m
If PhiRad < 0 Then Buli_el1 = -e Else Buli_el1 = e
End Function
VBA Filename frmPolyHortoZero.frm Extracted Macro

Option Explicit
'Public Variables only avail through this Form
Public MacroSel As Integer

Private Sub CommandButton_OK_Click()
If Len(Me.RefEdit1) = 0 Then
    MsgBox "select a starting cell for data output", vbExclamation
    Me.RefEdit1.SetFocus
    Exit Sub
End If

If Me.ListBox1.ListIndex < 0 Then
    MsgBox "select a polynomial", vbExclamation
    Me.ListBox1.SetFocus
    Exit Sub
End If

If MacroSel = 1 Then
    Select Case Me.ListBox1
    Case "Legendre":    testLegendre
    Case "Jacobi":      testJacobi
    Case "Hermite":     testHermite
    Case "Laguerre":    testLaguerre
    Case "Chebychev 1st":    testChebychevT
    Case "Chebychev 2nd":    testChebychevU
    Case "Gegenbauer":       testGegenbauer
    End Select
ElseIf MacroSel = 2 Then
    Select Case Me.ListBox1
    Case "Legendre":    Coef_Legendre
    Case "Jacobi":      Coef_Jacobi
    Case "Hermite":     Coef_Hermite
    Case "Laguerre":    Coef_Laguerre
    Case "Chebychev 1st":    Coef_Chebychecv1
    Case "Chebychev 2nd":    Coef_Chebychecv2
    Case "Gegenbauer":       Coef_Gegenbauer
    End Select

End If
Unload Me
End Sub

Private Sub CommandButton1_Click()
If MacroSel = 1 Then
    Application.Help XHelpFile, 276
ElseIf MacroSel = 2 Then
    Application.Help XHelpFile, 277
End If
End Sub

Private Sub ListBox1_Click()

Select Case Me.ListBox1
Case "Legendre"
    Switch_Field "Degree:", vbNullString, vbNullString
Case "Jacobi"
    Switch_Field "Degree:", "a:", "b:"
    Me.TextBox2 = -0.5: Me.TextBox3 = -0.5
Case "Hermite"
    Switch_Field "Degree:", vbNullString, vbNullString
Case "Laguerre"
    Switch_Field "Degree:", "m:", vbNullString
    Me.TextBox2 = 0
Case "Chebychev 1st"
    Switch_Field "Degree:", vbNullString, vbNullString
Case "Chebychev 2nd"
    Switch_Field "Degree:", vbNullString, vbNullString
Case "Gegenbauer"
    Switch_Field "Degree:", "Lambda:", vbNullString
    Me.TextBox2 = 1
End Select
End Sub

Private Sub Switch_Field(lbtxt1, lbtxt2, lbtxt3)
If Len(lbtxt1) <> 0 Then
    Me.Label1.Visible = True
    Me.Label1 = lbtxt1
    Me.TextBox1.Visible = True
Else
    Me.Label1.Visible = False
    Me.TextBox1.Visible = False
End If

If Len(lbtxt2) <> 0 Then
    Me.Label2.Visible = True
    Me.Label2 = lbtxt2
    Me.TextBox2.Visible = True
Else
    Me.Label2.Visible = False
    Me.TextBox2.Visible = False
End If

If Len(lbtxt3) <> 0 Then
    Me.Label3.Visible = True
    Me.Label3 = lbtxt3
    Me.TextBox3.Visible = True
Else
    Me.Label3.Visible = False
    Me.TextBox3.Visible = False
End If

End Sub

Private Sub SpinButton1_Change()
Me.TextBox1 = SpinButton1.Value
End Sub

Private Sub UserForm_Activate()
Select Case MacroSel
    Case 1: Me.Label_Title = "Zeros of Orthogonal Polynomials"
    Case 2: Me.Label_Title = "Coefficients of Orthogonal Polynomials"
End Select
Me.TextBox1 = 20
End Sub

Private Sub UserForm_Initialize()

With Me.ListBox1
.AddItem "Legendre"
.AddItem "Jacobi"
.AddItem "Hermite"
.AddItem "Laguerre"
.AddItem "Chebychev 1st"
.AddItem "Chebychev 2nd"
.AddItem "Gegenbauer"
End With

SpinButton1_Change
Me.RefEdit1 = ActiveCell.Address(False, False)

End Sub

'===========================================================================================

Sub testChebychevU()
'2 classe
Dim i&, n&, z#(), Pol#(), Dpol#()
n = Me.TextBox1
If n = 0 Then Exit Sub
ReDim z(n), Pol(n), Dpol(n)
    Call ZerosChebychevU(n, z)
    For i = 1 To n
        Call EvalChebychevU(n, z(i), Pol(i), Dpol(i))
    Next
Output_HortoPolyZero "Zeros of Chebychev polynomials of 2nd class", _
  z, Pol, Dpol
End Sub

Sub testChebychevT()
' 1 classe
Dim i&, n&, z#(), Pol#(), Dpol#()
n = Me.TextBox1
If n = 0 Then Exit Sub
ReDim z(n), Pol(n), Dpol(n)
    Call ZerosChebychevT(n, z)
    For i = 1 To n
        Call EvalChebychevT(n, z(i), Pol(i), Dpol(i))
    Next
Output_HortoPolyZero "Zeros of Chebychev polynomials of 1st class", _
  z, Pol, Dpol
End Sub

Sub testHermite()
Dim i&, n&, z#(), Pol#(), Dpol#()
n = Me.TextBox1
If n = 0 Then Exit Sub
ReDim z(n), Pol(n), Dpol(n)
    Call ZerosHermite(n, z)
    For i = 1 To n
        Call EvalHermite(n, z(i), Pol(i), Dpol(i))
    Next
Output_HortoPolyZero "Zeros of Hermite polynomials", _
  z, Pol, Dpol
End Sub

Sub testJacobi()
Dim i&, a#, b#, n&, z#(), Pol#(), Dpol#()
n = Me.TextBox1
If n = 0 Then Exit Sub
ReDim z(n), Pol(n), Dpol(n)
    a = Me.TextBox2
    b = Me.TextBox3
    Call ZerosJacobi(a, b, n, z)
    For i = 1 To n
        Call EvalJacobi(a, b, n, z(i), Pol(i), Dpol(i))
    Next
Output_HortoPolyZero "Zeros of Jacobi polynomials", _
  z, Pol, Dpol, Array("a", a, "b", b)
End Sub

Sub testLaguerre()
Dim i&, m&, n&, z#(), Pol#(), Dpol#()
n = Me.TextBox1
If n = 0 Then Exit Sub
ReDim z(n), Pol(n), Dpol(n)
    m = Me.TextBox2
    Call ZerosLaguerre(m, n, z)
    For i = 1 To n
        Call EvalLaguerre(m, n, z(i), Pol(i), Dpol(i))
    Next
Output_HortoPolyZero "Zeros of Laguerre polynomials", _
  z, Pol, Dpol, Array("m", m)
End Sub

Sub testLegendre()
Dim i&, n&, z#(), Pol#(), Dpol#()
n = Me.TextBox1
If n = 0 Then Exit Sub
ReDim z(n), Pol(n), Dpol(n)
    Call ZerosLegendre(n, z)
    For i = 1 To n
        Call EvalLegendre(n, z(i), Pol(i), Dpol(i))
    Next
Output_HortoPolyZero "Zeros of Legendre polynomials", _
  z, Pol, Dpol
End Sub

Sub testGegenbauer()
Dim i&, lambda#, n&, z#(), Pol#(), Dpol#()
n = Me.TextBox1
If n = 0 Then Exit Sub
ReDim z(n), Pol(n), Dpol(n)
    lambda = Me.TextBox2
    Call ZerosGegenbauer(n, lambda, z)
    For i = 1 To n
        Call EvalGegenbauer(lambda, n, z(i), Pol(i), Dpol(i))
    Next
Output_HortoPolyZero "Zeros of Gegenbauer polynomials", _
  z, Pol, Dpol, Array("Lambda", lambda)
End Sub

Private Sub Output_HortoPolyZero(l, z, Pol, Dpol, Optional Params)
Dim i&, n&, i0&, C0&, OrigCalcStatus%
On Error Resume Next
OrigCalcStatus = Application.Calculation
Application.Calculation = xlCalculationManual
i0 = Range(Me.RefEdit1).Row
C0 = Range(Me.RefEdit1).Column
Cells(i0, C0) = l
i0 = i0 + 1
If IsArray(Params) Then
  For i = LBound(Params) To UBound(Params) Step 2
    Cells(i0, C0) = Params(i) & " ="
    Cells(i0, C0 + 1) = Params(i + 1)
    i0 = i0 + 1
  Next
End If
n = UBound(z)
Cells(i0, C0) = "Degree ="
Cells(i0, C0 + 1) = n
i0 = i0 + 1
Cells(i0, C0) = "i"
Cells(i0, C0 + 1) = "root"
Cells(i0, C0 + 2) = "poly"
Cells(i0, C0 + 3) = "derivative"

For i = 1 To n
    Cells(i0 + i, C0) = i
    Cells(i0 + i, C0 + 1) = z(i)
    Cells(i0 + i, C0 + 2) = Pol(i)
    Cells(i0 + i, C0 + 3) = Dpol(i)
Next i
Range(Cells(i0 + n + 1, C0), Cells(i0 + n + 1, C0 + 3)).ClearContents
Application.Calculation = OrigCalcStatus
End Sub


Sub Coef_Legendre()
Dim n&, Coef(), kd
n = Me.TextBox1
If n = 0 Then Exit Sub
Poly_Legendre_Builder n, Coef, kd
Output_HortoPolyCoeff "Coefficients of Legendre polynomials", _
  Poly_Weight_Legendre(n), Coef, Array("kd", kd)
End Sub

Sub Coef_Chebychecv1()
Dim n&, Coef()
n = Me.TextBox1
If n = 0 Then Exit Sub
Poly_Chebychev_Builder1 n, Coef, 1
Output_HortoPolyCoeff "Coefficients of Chebychecv 1st polynomials", _
  Poly_Weight_ChebychevT(n), Coef
End Sub

Sub Coef_Chebychecv2()
Dim n&, Coef()
n = Me.TextBox1
If n = 0 Then Exit Sub
Poly_Chebychev_Builder1 n, Coef, 2
Output_HortoPolyCoeff "Coefficients of Chebychecv 2nd polynomials", _
  Poly_Weight_ChebychevU(n), Coef
End Sub

Sub Coef_Hermite()
Dim n&, Coef()
n = Me.TextBox1
If n = 0 Then Exit Sub
Poly_Hermite_Builder n, Coef
Output_HortoPolyCoeff "Coefficients of Hermite polynomials", _
  Poly_Weight_Hermite(n), Coef
End Sub

Sub Coef_Laguerre()
Dim n&, Coef(), kd, m&
n = Me.TextBox1
m = Me.TextBox2
If n = 0 Then Exit Sub
Poly_Laguerre_Builder n, Coef, kd, m
Output_HortoPolyCoeff "Coefficients of Laguerre polynomials", _
  Poly_Weight_Laguerre(n, m), Coef, Array("m", m, "kd", kd)
End Sub

Sub Coef_Gegenbauer()
Dim n&, Coef(), lambda#
n = Me.TextBox1
lambda = Me.TextBox2
If n = 0 Then Exit Sub
Poly_Gegenbauer_Builder n, lambda, Coef
Output_HortoPolyCoeff "Coefficients of Gegenbauer polynomials", _
  Poly_Weight_Gegenbauer(n, lambda), Coef, Array("Lambda", lambda)
End Sub

Sub Coef_Jacobi()
Dim n&, Coef(), a#, b#
n = Me.TextBox1
a = Me.TextBox2
b = Me.TextBox3
If n = 0 Then Exit Sub
Poly_Jacobi_Builder n, a, b, Coef
Output_HortoPolyCoeff "Coefficients of Jacobi polynomials", _
  Poly_Weight_Jacobi(n, a, b), Coef, Array("a", a, "b", b)
End Sub

Private Sub Output_HortoPolyCoeff(l$, w, Coef, Optional Params)
Dim n&, i&, OrigCalcStatus%, i0&, C0&
On Error Resume Next
OrigCalcStatus = Application.Calculation
Application.Calculation = xlCalculationManual
i0 = Range(Me.RefEdit1).Row
C0 = Range(Me.RefEdit1).Column
Cells(i0, C0) = l
i0 = i0 + 1
If IsArray(Params) Then
  For i = LBound(Params) To UBound(Params) Step 2
    Cells(i0, C0) = Params(i) & " ="
    Cells(i0, C0 + 1) = Params(i + 1)
    i0 = i0 + 1
  Next
End If
Cells(i0, C0) = "weight ="
If VarType(w) = vbString Then Cells(i0, C0 + 1) = "'" & w Else Cells(i0, C0 + 1) = w
i0 = i0 + 1
n = UBound(Coef)
Cells(i0, C0) = "Degree ="
Cells(i0, C0 + 1) = n
i0 = i0 + 1
Cells(i0, C0) = "i"
Cells(i0, C0 + 1) = "coeff"
i0 = i0 + 1
If VarType(Coef(0)) < vbString Then
  For i = 0 To n
      Cells(i0 + i, C0) = i
      Cells(i0 + i, C0 + 1) = Coef(i)
  Next i
Else
  For i = 0 To n
      Cells(i0 + i, C0) = i
      Cells(i0 + i, C0 + 1) = "'" & CStr(Coef(i))
  Next i
End If
Range(Cells(i0 + n + 1, C0), Cells(i0 + n + 1, C0 + 1)).ClearContents
Application.Calculation = OrigCalcStatus
End Sub
VBA Filename primeFunction.bas Extracted Macro
Option Explicit

'Code written by:       Richard Huxtable
'Last updated on:       03 June 2002 at 8:52 pm

Function Prime(Num)  'States whether a number is prime or returns the lowest factor of a number.  Works by trial division.
Attribute Prime.VB_Description = "States whether a number is prime or returns the lowest factor of a number"
Attribute Prime.VB_HelpID = 75
Attribute Prime.VB_ProcData.VB_Invoke_Func = " \n14"
                        'Increase the ceiling to find bigger primes - the function will be slower.

    Dim pdiv            As Long           'the primes to be used as divisors
    Dim sqroot          As Double           'the square root of the number
    Dim number          As Double
    Const ceiling       As Long = 500000    'a limit on the size of divisor it will try

    number = CDbl(Num)
    If number <> Int(number) Or number < 1 Then ErrRaise: Exit Function
    
    If number = 1 Then
        Prime = 1
        Exit Function
    ElseIf number = 2 Then
        Prime = "P"
        Exit Function
    End If
    If number / 2 = Int(CDbl(number / 2)) Then    'Using "Mod" would be an obvious choice here but it limits the number to 2,147,483,000.
        Prime = 2
        Exit Function
    End If

    pdiv = 3
    sqroot = (number ^ 0.5)
    Do While pdiv <= sqroot
        If number / pdiv = Int(CDbl(number / pdiv)) Then
            Prime = pdiv
            Exit Function
        End If
        pdiv = pdiv + 2
        If pdiv > ceiling Then
            Prime = "?"
            Exit Function
        End If
    Loop
    Prime = "P"
End Function

Function NextPrime(Num)                  'Returns the next prime bigger than any number.
Attribute NextPrime.VB_Description = "Returns the first prime number after 'num', for all primes less than 2^53"
Attribute NextPrime.VB_HelpID = 76
Attribute NextPrime.VB_ProcData.VB_Invoke_Func = " \n14"
    Dim pdiv            As Double
    Dim sqroot          As Double
    Dim possPrime       As Double
    Dim number          As Double

    number = CDbl(Num)
    If number <> Int(number) Or number < 0 Then ErrRaise: Exit Function
    Select Case number
    Case Is = 0
        NextPrime = 1
        Exit Function
    Case Is = 1
        NextPrime = 2
        Exit Function
    Case Is > CDbl("9007199254740846")
        NextPrime = CDbl("9007199254740881")
        Exit Function
    End Select
    If number / 2 = Int(CDbl(number / 2)) Then
        possPrime = number + 1
    Else
        possPrime = number + 2
    End If

    sqroot = possPrime ^ 0.5
    pdiv = 3

    Do Until pdiv > sqroot
        pdiv = 3
        Do Until pdiv > sqroot
            If possPrime / pdiv = Int(CDbl(possPrime / pdiv)) Then
                possPrime = possPrime + 2
                sqroot = possPrime ^ 0.5
                Exit Do
            End If
            pdiv = pdiv + 2
        Loop
    Loop
    NextPrime = possPrime
End Function

Function PrevPrime(Num)
Attribute PrevPrime.VB_Description = "Returns the first prime number less than 'num', for all primes less than 2^53"
Attribute PrevPrime.VB_HelpID = 76
Attribute PrevPrime.VB_ProcData.VB_Invoke_Func = " \n14"
    Dim pdiv            As Double
    Dim sqroot          As Double
    Dim possPrime       As Double
    Dim number          As Double

    number = CDbl(Num)
    If number <> Int(number) Or number < 2 Then ErrRaise: Exit Function
    Select Case number
    Case Is = 2
        PrevPrime = 1
        Exit Function
    Case Is = 3
        PrevPrime = 2
        Exit Function
    Case Is > CDbl("9007199254740881")
        PrevPrime = CDbl("9007199254740881")
        Exit Function
    End Select
    If number / 2 = Int(CDbl(number / 2)) Then
        possPrime = number - 1
    Else
        possPrime = number - 2
    End If

    sqroot = possPrime ^ 0.5
    pdiv = 3

    Do Until pdiv > sqroot
        pdiv = 3
        Do Until pdiv > sqroot
            If possPrime / pdiv = Int(CDbl(possPrime / pdiv)) Then
                possPrime = possPrime - 2
                sqroot = possPrime ^ 0.5
                Exit Do
            End If
            pdiv = pdiv + 2
        Loop
    Loop
    PrevPrime = possPrime
End Function

'Eratostene's Sieve. by Foxes Team 1.1.2005
Sub StartSieve(ByVal MinPrime&, ByVal MaxPrime&, StackPrime())
    'Cand = 3,5,7,9,11,13,
    'Cand = Index*2+1
    'Index = 1,2,3,4,5,
    'Index=(Cand-1)/2
    Dim Prime() As Boolean
    Dim MaxIndex As Long
    Dim Cand As Long
    Dim Index As Long
    Dim Remove As Long
    Dim Sqrt As Double
    Dim Pointer As Long
    
    MaxIndex = (MaxPrime - 1) / 2
    ReDim Prime(1 To MaxIndex) As Boolean
    ReDim StackPrime(1 To MaxIndex)
    If MinPrime < 2 Then Pointer = Pointer + 1: StackPrime(Pointer) = 1
    If MinPrime < 3 Then Pointer = Pointer + 1: StackPrime(Pointer) = 2
    If MinPrime < 4 Then Pointer = Pointer + 1: StackPrime(Pointer) = 3
    
    For Index = 1 To MaxIndex
        Prime(Index) = True
    Next Index
    Sqrt = Sqr(MaxPrime)
    Cand = 3
    Do While Cand < MaxPrime
        If Cand <= Sqrt Then
            Remove = Cand * Cand
            While Remove <= MaxPrime
                Prime((Remove - 1) / 2) = False
                Remove = Remove + 2 * Cand
            Wend
        End If
        Cand = Cand + 2
        If Cand >= MaxPrime Then
            'MsgBox (CStr(Pointer) & " primes found")
            Exit Do
        End If
        While Not Prime((Cand - 1) / 2)
            Cand = Cand + 2
            If Cand >= MaxPrime Then
                'MsgBox (CStr(Pointer) & " primes found")
                Exit Do
            End If
        Wend
        If Cand > MinPrime Then
            Pointer = Pointer + 1
            StackPrime(Pointer) = Cand
        End If
    Loop
    ReDim Preserve StackPrime(1 To Pointer)
End Sub


'perform the probabilistic Fermat's prime test
'v. 2.1.2005 by Foxes Team
Sub Fermat_Prime_Test(n, Msg, Optional trials = 100)
Dim m, BASE, bmax, i, j, y$, DgMx&, l

l = Len(CStr(n))
DgMx = 2 * l + 2
If DgMx > DIGITS_LIMIT Then
    Msg = "Sorry. Number too long"
    Exit Sub
End If


If xIntMod(n, 2) = 0 Then
    Msg = "composite"
    Exit Sub
End If

bmax = (n - 1) / 2 - 2
Const cmax# = 10 ^ 7
If bmax > cmax Then bmax = cmax
m = xAdd(n, -1, DgMx)
For i = 1 To trials
    'take a random base between 3 and bmax
    j = Int(bmax * Rnd + 1)
    BASE = j * 2 + 1  'odd base
    '--------------------------------------
    Pow_Module BASE, m, n, y, DgMx
    If y <> vbStr1 Then
        Msg = "composite"
        Exit Sub
    End If
Next i

Msg = "pseudo-prime"
End Sub

'Totient Euler's function
'
Function Totient(n)
Attribute Totient.VB_Description = "Euler's Totient function"
Attribute Totient.VB_HelpID = 310
Attribute Totient.VB_ProcData.VB_Invoke_Func = " \n14"
Dim i&, q, ErrMsg$
Dim p() As Long, k() As Long
If n = 1 Then Totient = 1: Exit Function
Call Integer_Factorize(n, p, k, ErrMsg)
q = 1
For i = 1 To UBound(p)
    q = q * (p(i) - 1) * p(i) ^ (k(i) - 1)
Next i
Totient = q
End Function


Private Function NextFactor(Num, Optional num1 = 2, Optional num2 = 500000)

    Dim pdiv            As Long           'the primes to be used as divisors
    Dim sqroot          As Double           'the square root of the number
    Dim number          As Double

    number = CDbl(Num)
    If number <> Int(number) Or number < 1 Then ErrRaise: Exit Function
    
    If num1 < 3 Then
        If number = 1 Then
            NextFactor = 1
            Exit Function
        ElseIf number = 2 Then
            NextFactor = "P"
            Exit Function
        End If
        If number / 2 = Int(CDbl(number / 2)) Then    'Using "Mod" would be an obvious choice here but it limits the number to 2,147,483,000.
            NextFactor = 2
            Exit Function
        End If
    End If
    
    If num1 / 2 = Int(CDbl(num1 / 2)) Then pdiv = num1 + 1 Else pdiv = num1
    
    sqroot = (number ^ 0.5)
    Do While pdiv <= sqroot
        If number / pdiv = Int(CDbl(number / pdiv)) Then
            NextFactor = pdiv
            Exit Function
        End If
        pdiv = pdiv + 2
        If pdiv > num2 Then
            NextFactor = "?"
            Exit Function
        End If
    Loop
    NextFactor = "P"
End Function


'fermat-lehman algorithm
Sub factor_fermat_lehman(n, a, b, Optional Itmax = 10001)
'trova un fattore fra n^1/3 < a < n^1/2
Dim x#, k&, m&, r#, y#, klimit&
Dim t, t1, t2, tmp
'
'chek perfect square
r = Round(Sqr(n))
If r * r = n Then
    a = r
    b = r
    Exit Sub
End If
'
r = Int(CDbl(n ^ (1 / 3)))
k = 1
Do While k <= r And k < Itmax
    t1 = 4 * k * CDec(n)
    x = Int(CDec(Sqr(t1))) + 1
    m = 0
    Do While m < Int(CDec(Sqr(r / k)))
'        t = (x + m) * (x + m) - 4 * k * n  'overflow for n > 1E11
        t2 = CDec(x + m) * (x + m)
        t = t2 - t1
        If t > 0 Then
            y = Sqr(t)
            If y = Int(y) Then
                x = x + m
                a = MCD_2(x + y, n)
                b = MCD_2(x - y, n)
                If b > a Then
                    tmp = a: a = b: b = tmp
                End If
                Exit Sub
            End If
        End If
        m = m + 1
    Loop
    k = k + 1
Loop
If k = r + 1 Then
    'prime
    a = n
    b = 1
ElseIf k = Itmax Then
    'do not know
    a = "?"
    b = "?"
End If
end_sub:
End Sub

'Private Function MCD_2(a, b)
''Find the MCD between two integer numbers
''by the Euclid method
'Dim y#, x#, r#
'y = a: x = b
'Do Until x = 0
'    r = y - x * Int(CDbl(y / x))
'    y = x: x = r
'Loop
'MCD_2 = y
'End Function

Sub Integer_Factorize(n, Factr, Expo, ErrMsg)
'Factorizes an integer number n
Dim i&, f, m#, f0#, nMax, a, b
ReDim Factr(1 To 100), Expo(1 To 100)
ErrMsg = vbNullString
nMax = 100000
i = 1
If n > Ten15 Then
    Factr(i) = "?": Expo(i) = "?": ErrMsg = "?"
    ReDim Preserve Factr(1 To 1), Expo(1 To 1)
    Exit Sub
End If

'try first with the brute force attack
m = n
f = NextFactor(m, 2, nMax)
If IsNumeric(f) Then
     f0 = f
    Do While IsNumeric(f)
        If f <> f0 Then i = i + 1
        Factr(i) = f
        Expo(i) = Expo(i) + 1
        m = m / f
        f0 = f
        f = NextFactor(m, f, nMax)
    Loop
    If f = "P" And m <> 1 Then
        If m <> f0 Then i = i + 1
        Factr(i) = m
        Expo(i) = Expo(i) + 1
'        GoTo Exit_
    End If

ElseIf f = "P" Then
    Factr(i) = m
    Expo(i) = 1
End If

If f = "?" Then
    'try with fermat-lehman attak
    Call factor_fermat_lehman(m, a, b)
    If b = "?" Then
        'no factor found
        If Len(Factr(i)) <> 0 Then i = i + 1
        Factr(i) = "?": Expo(i) = "?": ErrMsg = "?"
    Else
        If b > 1 Then
            If Factr(i) <> b And Len(Factr(i)) <> 0 Then i = i + 1
            Factr(i) = b
            Expo(i) = Expo(i) + 1
        End If
        If a > 1 Then
            If Factr(i) <> a And Len(Factr(i)) <> 0 Then i = i + 1
            Factr(i) = a
            Expo(i) = Expo(i) + 1
        End If
    End If
End If

ReDim Preserve Factr(1 To i)
ReDim Preserve Expo(1 To i)
End Sub


Function Factor(n)
Attribute Factor.VB_Description = "Returns the prime factors = [factor, exponent] of integer number"
Attribute Factor.VB_HelpID = 98
Attribute Factor.VB_ProcData.VB_Invoke_Func = " \n14"
'Factorizes an integer number n
'returns a matrices of factors: [factor, exponent]
Dim Factr(), Expo(), tmp(), MaxFact%, ErrMsg, i&
If n > 0 Then
    Call Integer_Factorize(n, Factr, Expo, ErrMsg)
    MaxFact = UBound(Factr)
End If
'load an return array
ReDim tmp(0 To MaxFact, 1 To 2)
tmp(0, 1) = "factor": tmp(0, 2) = "exp"
For i = 1 To MaxFact
    tmp(i, 1) = Factr(i)
    tmp(i, 2) = Expo(i)
Next i
Factor = PasteVector_(tmp)
End Function


'perform the probabilistic Miller-Rabin's prime test
'v. 19.2.2007 by Foxes Team
' the probability of fault is 1/4^trials
' with trials = 50 , the probability is about 1E-31, the same of the Fermat with trials=100
Sub Miller_Rabin_Test(n, Msg, Optional trials = 50)
Dim i&, j&, k&, q, y, w, m, dgt_max, b#

Msg = "composite"
dgt_max = xDgt(n) + xBASE
'test against the first primes
If xIntMod(n, 2) = vbStr0 Then Exit Sub
If xIntMod(n, 3) = vbStr0 Then Exit Sub
If xIntMod(n, 5) = vbStr0 Then Exit Sub
If xIntMod(n, 7) = vbStr0 Then Exit Sub
'Miller-Rabin test begins

'm = n - 1
m = xAdd(n, -1, dgt_max)
q = m
Do While xIntMod(q, 2) = vbStr0
    q = xDivInt(q, 2)
    k = k + 1
Loop
'now we have the relation   n-1 = q*2^k
Randomize
b = CDbl(m)
Const bmax# = Ten6
If b > bmax Then b = bmax
For i = 1 To trials
    w = Int(b * Rnd + 2)
    y = xPowMod(w, q, n)
    If y <> vbStr1 And y <> m Then
        For j = 1 To k
            y = xPowMod(y, 2, n)
            If y = m Then Exit For
        Next j
        If j > k Then Exit Sub      'composite
    End If
Next i
Msg = "pseudo-prime"
End Sub

'Solves the Brouncker/Pell Equation x^2 - D*y^2 = +1 given D.
Sub Pell_Solve(x, y, d1, Optional n = 1)
Dim i&, iMax&, d#
Dim r, R1, U1, v, v1, a, U, p1, p, s%, t, b, Num(1 To 3), Den(1 To 3)
Dim k%, w, dgt1, dgt2, DgtMax&
On Error GoTo Error_Handler
iMax = DIGITS_LIMIT * 2&
ReDim x(1 To n), y(1 To n)
'initialization
x(n) = "?": y(n) = "?": d = d1
Num(2) = CDec(0): Num(3) = CDec(1)
Den(2) = CDec(1): Den(3) = CDec(0)
r = Int(CDbl(Sqr(d)))
a = r
'compute fraction
GoSub Compute_Fraction 'compute fraction
''solution check
If w = 1 Then GoSub Add_Solution
R1 = 2 * r
U1 = R1
v = d - r ^ 2
If v = 0 Then  'n is perfect square
    x(1) = 1
    y(1) = 0
    Exit Sub
End If
'continued fraction algorithm begins
v1 = 1
a = Int(CDbl(R1 / v))
GoSub Compute_Fraction 'compute fraction
'solution check
If w = 1 Then GoSub Add_Solution
U = R1 - modulus(R1, v)
p1 = r
p = modulus(a * r + 1, d)
s = 1
i = 1
Do
    i = i + 1
    t = v
    v = a * (U1 - U) + v1
    v1 = t
    a = Int(CDbl(U / v))
    GoSub Compute_Fraction
    
    'solution check
    If w = 1 Then GoSub Add_Solution
    U1 = U
    U = R1 - modulus(U, v)
    s = 1 - s
    t = p
    p = modulus(a * p + p1, d)
    p1 = t
Loop Until i = iMax
If i >= iMax Then GoTo Error_Handler
Exit Sub
'internal rouitine
Add_Solution:
    k = k + 1
    x(k) = Num(3)
    y(k) = Den(3)
    If k = n Then Exit Sub
Return
Compute_Fraction:
    Num(1) = Num(2): Num(2) = Num(3)
    Den(1) = Den(2): Den(2) = Den(3)
    
    dgt1 = NumLenInt(Num(2)) + NumLenInt(a)
    DgtMax = dgt1 + 4
    If DgtMax > DIGITS_LIMIT Then GoTo Error_Handler
    If DgtMax < 30 Then
        Num(3) = Num(2) * a + Num(1)
    Else
        Num(3) = xAdd(xMultR(Num(2), a, DgtMax), Num(1), DgtMax)
    End If
    
    dgt1 = NumLenInt(Den(2)) + NumLenInt(a)
    DgtMax = dgt1 + 4
    If DgtMax > DIGITS_LIMIT Then GoTo Error_Handler
    If DgtMax < 30 Then
        Den(3) = Den(2) * a + Den(1)
    Else
        Den(3) = xAdd(xMultR(Den(2), a, DgtMax), Den(1), DgtMax)
    End If
    
    dgt1 = NumLenInt(Num(3))
    dgt2 = NumLenInt(Den(3))
    DgtMax = 2 * max_(dgt1, dgt2) + 2
    If DgtMax > DIGITS_LIMIT Then GoTo Error_Handler
    If DgtMax < 30 Then
        w = Num(3) * Num(3) - d * Den(3) * Den(3)
    Else
        w = CDbl(xSubR(xMultSq(dCStr_(Num(3)), DgtMax), xMultR(d, xMultSq(dCStr_(Den(3)), DgtMax), DgtMax), DgtMax))
    End If
Return
Error_Handler:
    k = k + 1
    x(k) = "?"
    y(k) = "?"
    Exit Sub
End Sub

'functions gi\xe0 presenti in Xnumbers

Private Function modulus(a, b)
modulus = Round(a - b * Int(a / b))
End Function

'return the continued fraction of a square root of integer number
Function FractContSqr(n)
Attribute FractContSqr.VB_Description = "Continued fraction of the square root of n."
Attribute FractContSqr.VB_HelpID = 315
Attribute FractContSqr.VB_ProcData.VB_Invoke_Func = " \n14"
Dim q(), i&, iMax&, Qmax&, tmp()
If xNumInvAppCallFlg Then
  iMax = xNumACRows * xNumACCols
Else
  iMax = Application.Caller.Count
End If
Cont_Fract_Radix_Expansion n, q
Qmax = UBound(q)
If iMax = 0 Then iMax = Qmax
ReDim tmp(iMax)
For i = 0 To iMax
    If i > Qmax Then Exit For
    tmp(i) = q(i)
Next i
FractContSqr = PasteVector_(tmp)
End Function

'continued fraction expansion of a number square-root
'returns the vector q=[q0,q1,q2...qn] representing n^(1/2)
'the lenght-1 of the vector q represents the period of the continued fraction
Sub Cont_Fract_Radix_Expansion(n, q)
Dim i&, iMax&
Dim r, R1, U1, v, v1, a, U, p1, p, s%, t, b, xa, xb

iMax = 10000
ReDim q(iMax)
r = Int(CDbl(Sqr(n)))
q(0) = r
R1 = 2 * r
U1 = R1
v = n - r ^ 2
If v = 0 Then  'n is perfect square
    ReDim Preserve q(0)
    Exit Sub
End If
v1 = 1
a = Int(CDbl(R1 / v))
q(1) = a
U = R1 - modulus(R1, v)
p1 = r
p = modulus(a * r + 1, n)
s = 1
i = 1
Do
    If q(i) = 2 * q(0) Then Exit Do
    i = i + 1
    t = v
    v = a * (U1 - U) + v1
    v1 = t
    a = Int(CDbl(U / v))
    q(i) = a
    U1 = U
    U = R1 - modulus(U, v)
    s = 1 - s
    t = p
    p = modulus(a * p + p1, n)
    p1 = t
Loop Until i = iMax
ReDim Preserve q(i)
End Sub

'returns the fractions array from the continued fraction vector [a0, a1, a2...]
Sub Continued_Fraction_Conv(q, f)
Dim i&, n&, s(), t(), L1, L2, DgtMax&
n = UBound(q)
ReDim f(n, 1 To 2), s(n + 2), tn(n + 2)
'initialization
s(0) = CDec(0): s(1) = CDec(1) 'numerator
t(0) = CDec(1): t(1) = CDec(0) 'denominator
For i = 0 To n
    L1 = NumLenInt(s(i + 1))
    L2 = NumLenInt(t(i + 1))
    If L1 < 27 And L2 < 27 Then
        s(i + 2) = q(i) * s(i + 1) + s(i)
        t(i + 2) = q(i) * t(i + 1) + t(i)
    Else
        DgtMax = max_(L1, L2) + xBASE
        s(i + 2) = xAdd(xMultR(q(i), s(i + 1), DgtMax), s(i), DgtMax)
        t(i + 2) = xAdd(xMultR(q(i), t(i + 1), DgtMax), t(i), DgtMax)
    End If
    f(i, 1) = s(i + 2)
    f(i, 2) = t(i + 2)
Next i

End Sub
VBA Filename frmDigits.frm Extracted Macro

Option Explicit

'Public Variables only avail through this Form
Public HitOK As Boolean

Private Sub CommandButtonOK_Click()
HitOK = True
Unload Me
End Sub
VBA Filename PolyOrtho.bas Extracted Macro
'=====================================================================================
' Orthogonal Polynomials VB library
' by Leonardo Volpi &  Luis Isaac Ramos Garcia
' v. 12.12.2004                                                             Foxes Team
'=====================================================================================

Option Explicit

Sub EvalJacobi(a#, b#, n&, x#, Pol#, Dpol#)
' Rutina para calcular el polinomio ortonormal de Jacovi de orden n y su derivada en x
' pol valor del polinomio en x; dpol valor de la derivada del polinomio en x
' Bibliografia: Abramowitz M et al.; "Handbook of Mathematical Functions...",Dover
'               Press et al.; "Numerical recipies in fotran77", Cambridge U Press
    If n = 0 Then
        Pol = 1
        Dpol = 0
    ElseIf n = 1 Then
        Pol = 0.5 * (2 * (a + 1) + (a + b + 2) * (x - 1))
        Dpol = 0.5 * (a + b + 2)
    Else
        Pol = PolJacobi(a, b, n, x)
        Dpol = 0.5 * (n + a + b + 1) * PolJacobi(a + 1, b + 1, n - 1, x)
    End If
End Sub

Private Function PolJacobi(a#, b#, n&, x#)
' Funcion para calcular el polinomio de Jacovi de orden n en x
' Bibliografia: Abramowitz M et al.; "Handbook of Mathematical Functions...",Dover
'               Press et al.; "Numerical recipies in fotran77", Cambridge U Press
    Dim j&, p#(0 To 2), dp#, cj#, dj#, ej#, fj#
    
    If n = 0 Then
        PolJacobi = 1
    ElseIf n = 1 Then
        PolJacobi = 0.5 * (a - b + (2 + a + b) * x)
    Else
        p(0) = 1
        p(1) = 0.5 * (a - b + (2 + a + b) * x)
        For j = 1 To n - 1
            cj = 2 * (j + 1) * (j + a + b + 1) * (2 * j + a + b)
            dj = (2 * j + a + b + 1) * (a ^ 2 - b ^ 2)
            ej = (2 * j + a + b) * (2 * j + a + b + 1) * (2 * j + a + b + 2)
            fj = 2 * (j + a) * (j + b) * (2 * j + a + b + 2)
        
            p(2) = ((dj + ej * x) * p(1) - fj * p(0)) / cj      ' Polinomio de orden k+1 en x
            p(0) = p(1)                                         ' (***)
            p(1) = p(2)
        Next
        PolJacobi = p(2)
    End If
End Function

Sub EvalLegendre(n&, x#, Pol#, Dpol#)
' Rutina para calcular el polinomio ortonormal de Legendre de orden n y su derivada en x
' Los polinomios de Legendre son un caso especial de los de Jacobi con a = b = 0
' Pol valor del polinomio en x; DPol valor de la derivada del polinomio en x
' Bibliografia: Abramowitz M et al.; "Handbook of Mathematical Functions...",Dover
'               Press et al.; "Numerical recipies in fotran77", Cambridge U Press
'mod. 12.4.04 VL
    Dim k&, p#(0 To 2), dp#(0 To 2)
    
    If n = 0 Then
        Pol = 1
        Dpol = 0
    ElseIf n = 1 Then
        Pol = x
        Dpol = 1
    Else
        p(0) = 1
        p(1) = x
        If Abs(x - 1) < 0.1 Or Abs(x + 1) < 0.1 Then
            dp(0) = 0
            dp(1) = 1
            For k = 1 To n - 1
                p(2) = ((2 * k + 1) * x * p(1) - k * p(0)) / (k + 1)             'Polinomio de orden k+1 en x
                dp(2) = ((2 * k + 1) * (p(1) + x * dp(1)) - k * dp(0)) / (k + 1) 'Derivata del polinomio di ordine k+1 in x .VL
                p(0) = p(1)
                p(1) = p(2)
                dp(0) = dp(1)
                dp(1) = dp(2)
            Next
            Pol = p(2)
            Dpol = dp(2)
        Else
            For k = 1 To n - 1
                p(2) = ((2 * k + 1) * x * p(1) - k * p(0)) / (k + 1)                    ' Polinomio de orden k+1 en x
                p(0) = p(1)                                                             ' (***)
                p(1) = p(2)
            Next
            Pol = p(2)
            Dpol = n * (x * p(2) - p(0)) / (x ^ 2 - 1)      ' Derivada del polinomio de orden k+1 en x
        End If
    End If
End Sub

Sub EvalGegenbauer(l#, n&, x#, Pol#, Dpol#)
' Rutina para calcular el polinomio de ortonormal Gegenbauer asdociado l de orden n y su derivada en x
' Los polinomios de Gegenbauer son un caso especial de los de Jacobi con a = b = l-1/2
' Cuando l=1/2 aparecen los polinomios de Legendre
' Pol valor del polinomio en x; DPol valor de la derivada del polinomio en x
' Bibliografia: Abramowitz M et al.; Handbook of Mathematical Functions...,Dover
' mod.  ve. 12.12.2004 VL
    Dim k&, p#(0 To 2), dp#(0 To 2)
    
    If l = 0 Then
        EvalChebychevT n, x, Pol, Dpol
        Pol = Pol * 2 / n
        Dpol = Dpol * 2 / n
        Exit Sub
    End If
    
    If l = 1 Then
        EvalChebychevU n, x, Pol, Dpol
        Exit Sub
    End If
    
    If n = 0 Then
        Pol = 1
        Dpol = 0
    ElseIf n = 1 Then
        Pol = 2 * l * x
        Dpol = 2 * l
    Else
        p(0) = 1
        p(1) = 2 * l * x
        If Abs(x - 1) < 0.1 Or Abs(x + 1) < 0.1 Then
            dp(0) = 0
            dp(1) = 2 * l
             For k = 1 To n - 1
                p(2) = (2 * (k + l) * x * p(1) - (k + 2 * l - 1) * p(0)) / (k + 1)  ' Polinomio de orden k+1 en x
                dp(2) = (2 * (k + l) * p(1) + 2 * (k + l) * x * dp(1) - (k + 2 * l - 1) * dp(0)) / (k + 1)
                p(0) = p(1)
                p(1) = p(2)
                dp(0) = dp(1)
                dp(1) = dp(2)
            Next
            Pol = p(2)
            Dpol = dp(2)      ' Derivada del polinomio de orden k+1 en x
        Else
            For k = 1 To n - 1
                p(2) = (2 * (k + l) * x * p(1) - (k + 2 * l - 1) * p(0)) / (k + 1)  ' Polinomio de orden k+1 en x
                p(0) = p(1)                                                         ' (***)
                p(1) = p(2)
            Next
            Pol = p(2)
            Dpol = (n * x * p(2) - n * p(0)) / (x ^ 2 - 1)      ' Derivada del polinomio de orden k+1 en x
        End If                                                           ' Se usa p(0) y no p(1) por (***)
    End If
End Sub

Sub EvalLaguerre(m&, n&, x#, Pol#, Dpol#)
' Rutina para calcular el polinomio ortonormal de Laguerre asociado m de orden n y su derivada en x
' Pol valor del polinomio en x; DPol valor de la derivada del polinomio en x
' Bibliografia: Abramowitz M et al.; "Handbook of Mathematical Functions...",Dover
'               Press et al.; "Numerical recipies in fotran77", Cambridge U Press
'mod 2.12.04 VL
    Dim k&, p#(0 To 2), dp#(0 To 2)

    If n = 0 Then
        Pol = 1
        Dpol = 0
    ElseIf n = 1 Then
        Pol = m + 1 - x
        Dpol = -1
    Else
        p(0) = 1
        p(1) = m + 1 - x
        If Abs(x) < 0.1 Then
            dp(0) = 0
            dp(1) = -1
            For k = 1 To n - 1
                p(2) = ((-x + 2 * k + 1 + m) * p(1) - (k + m) * p(0)) / (k + 1)     ' Polinomio de orden k+1 en x
                dp(2) = (-p(1) + (-x + 2 * k + 1 + m) * dp(1) - (k + m) * dp(0)) / (k + 1)   ' Derivata ordine k+1 in x (VL 2.12.04)
                p(0) = p(1)
                p(1) = p(2)
                dp(0) = dp(1)
                dp(1) = dp(2)
            Next
            Pol = p(2)
            Dpol = dp(2)
        Else
            For k = 1 To n - 1
                p(2) = ((-x + 2 * k + 1 + m) * p(1) - (k + m) * p(0)) / (k + 1)             ' Polinomio de orden k+1 en x
                p(0) = p(1)                                                                 ' (***)
                p(1) = p(2)
            Next
            Pol = p(2)
            Dpol = (n * p(2) - (n + m) * p(0)) / x                  ' Derivada del polinomio de orden k+1 en x
        End If
    End If
End Sub

Sub EvalHermite(n&, x#, Pol#, Dpol#)
'Hermite Polynomials H(x, n), H'(x, n)
    Dim k&, p#(0 To 2), dp#(0 To 2)
    
    If n = 0 Then
        Pol = 1
        Dpol = 0
    ElseIf n = 1 Then
        Pol = 2 * x
        Dpol = 2
    Else
        p(0) = 1
        p(1) = 2 * x
        For k = 1 To n - 1
            p(2) = 2 * x * p(1) - 2 * k * p(0)
            p(0) = p(1)
            p(1) = p(2)
        Next
        Pol = p(2)
        Dpol = 2 * n * p(0)
    End If
End Sub

Sub EvalChebychevT(n&, x#, Pol#, Dpol#)
'Chebychev Polynomials of 1st kind T(x, n), and Derivative T'(x, n)
    Dim k&, p#(0 To 2), dp#(0 To 2)
    
    If n = 0 Then
        Pol = 1: Dpol = 0
    ElseIf n = 1 Then
        Pol = x: Dpol = 1
    Else
        p(0) = 1: p(1) = x
        dp(0) = 0: dp(1) = 1
        For k = 1 To n - 1
            p(2) = 2 * x * p(1) - p(0)
            dp(2) = 2 * p(1) + 2 * x * dp(1) - dp(0)
            p(0) = p(1)
            p(1) = p(2)
            dp(0) = dp(1)
            dp(1) = dp(2)
        Next
        Pol = p(2)
        Dpol = dp(2)
    End If
End Sub

Sub EvalChebychevU(n&, x#, Pol#, Dpol#)
'Chebychev Polynomials of 2nd kind U(x,n), and Derivative U'(x,n)
    Dim k&, p#(0 To 2), dp#(0 To 2)
    
    If n = 0 Then
        Pol = 1: Dpol = 0
    ElseIf n = 1 Then
        Pol = 2 * x: Dpol = 2
    Else
        p(0) = 1: p(1) = 2 * x
        dp(0) = 0: dp(1) = 2
        For k = 1 To n - 1
            p(2) = 2 * x * p(1) - p(0)
            dp(2) = 2 * p(1) + 2 * x * dp(1) - dp(0)
            p(0) = p(1)
            p(1) = p(2)
            dp(0) = dp(1)
            dp(1) = dp(2)
        Next
        Pol = p(2)
        Dpol = dp(2)
    End If
End Sub

Sub ZerosJacobi(a#, b#, n&, z#())
Dim k&, x1#, x2#, OrthPol&
x1 = -1
x2 = 1
OrthPol = 4 'Jacobi
Call OrthoPolyZero(OrthPol, n, z, k, x1, x2, , a, b)
End Sub

Sub ZerosLegendre(n&, z#())
Dim k&, x1#, x2#, OrthPol&
x1 = -1
x2 = 1
OrthPol = 1 'Legendre
Call OrthoPolyZero(OrthPol, n, z, k, x1, x2)
End Sub

Sub ZerosChebychevT(n&, z#())
' Rutina para calcular los ceros del polinomio ortogonal de Chebychev de primera especie de orden n
' Bibliografia: Press et al.; "Numerical recipies in fotran77", Cambridge U Press
'               Abramowitz M et al.; "Handbook of Mathematical Functions...",Dover
    Dim i&
    ReDim z(1 To n)
    
    For i = 1 To n
        z(i) = Cos(Pi_ * (i - 0.5) / n)
    Next
End Sub

Sub ZerosChebychevU(n&, z#())
' Rutina para calcular los ceros del polinomio ortogonal de Chebychev de primera especie de orden n
' Bibliografia: Abramowitz M et al.; "Handbook of Mathematical Functions...",Dover
    Dim i&
    ReDim z(1 To n)
    
    For i = 1 To n
        z(i) = Cos(Pi_ * i / (n + 1))
    Next
End Sub

Sub ZerosLaguerre(m&, n&, z#())
Dim k&, x1#, x2#, OrthPol&
x1 = 0
x2 = 1.1 * (n * m / 50 + 6 / 5 * m + 18 / 5 * n - 5)
OrthPol = 3 'Laguerre
Call OrthoPolyZero(OrthPol, n, z, k, x1, x2, m)
End Sub

Sub ZerosHermite(n&, z#())
Dim k&, x1#, x2#, OrthPol&
x1 = -0.75 * (n - 1)
x2 = -x1
OrthPol = 2 'Hermite
Call OrthoPolyZero(OrthPol, n, z, k, x1, x2)
End Sub

Sub ZerosGegenbauer(n&, lambda#, z#())
'mod. 11.12.04 VL
Dim k&, x1#, x2#, OrthPol&
x1 = -1
x2 = 1
OrthPol = 5 'Gegenbauer
Call OrthoPolyZero(OrthPol, n, z, k, x1, x2, , lambda)
End Sub

Sub OrthoPolyZero(OrthPol&, n&, z#(), its&, xMin#, xMax#, Optional m&, Optional a#, Optional b#)
'Robust Rootfinder for orthogonal polynomials using the ADK algorithm (Aberth_Durand_Kerner)
'v.12.12.2004  by LV
Dim x0#, x#, s#, xErr#, i&, j&, p#, dp#, f#, Tiny#, h#, Itmax&
Tiny = Ten_15
ReDim z(1 To n)
Itmax = n * 50
h = (xMax - xMin) / n
x = xMax: x0 = x: its = 0
For i = 1 To n
    Do
        its = its + 1
        Select Case OrthPol
            Case 1: EvalLegendre n, x, p, dp
            Case 2: EvalHermite n, x, p, dp
            Case 3: EvalLaguerre m, n, x, p, dp
            Case 4: EvalJacobi a, b, n, x, p, dp
            Case 5: EvalGegenbauer a, n, x, p, dp
            Case Else: Err.Raise 1001, , "Missing polynomial type"
        End Select
        s = 0
        For j = 1 To i - 1
            s = s + 1 / (x - z(j))
        Next j
        x0 = x
        If dp <> 0 Then
            f = p / dp
        Else
            f = Tiny * Ten6
        End If
        x = x - f / (1 - f * s)
        xErr = Abs(x - x0)
    Loop Until xErr < Tiny Or its > Itmax
    z(i) = x
    x = x + 0.1 * h
Next i
End Sub

Function Poly_Legendre(x, Optional n)
Attribute Poly_Legendre.VB_Description = "Evaluates the Legendre orthogonal polynomial"
Attribute Poly_Legendre.VB_HelpID = 268
Attribute Poly_Legendre.VB_ProcData.VB_Invoke_Func = " \n14"
Dim Pol#, Dpol#, k&, z#
If IsMissing(n) Then k = 1 Else k = n
z = x
Call EvalLegendre(k, z, Pol, Dpol)
Poly_Legendre = PasteVector_(Array(Pol, Dpol))
End Function

Function Poly_ChebychevT(x, Optional n)
Attribute Poly_ChebychevT.VB_Description = "Evaluates the Chebychev orthogonal polynomial of 1st kind"
Attribute Poly_ChebychevT.VB_HelpID = 268
Attribute Poly_ChebychevT.VB_ProcData.VB_Invoke_Func = " \n14"
Dim Pol#, Dpol#, k&, z#
If IsMissing(n) Then k = 1 Else k = n
z = x
Call EvalChebychevT(k, z, Pol, Dpol)
Poly_ChebychevT = PasteVector_(Array(Pol, Dpol))
End Function

Function Poly_ChebychevU(x, Optional n)
Attribute Poly_ChebychevU.VB_Description = "Evaluates the Chebychev orthogonal polynomial of 2nd kind"
Attribute Poly_ChebychevU.VB_HelpID = 268
Attribute Poly_ChebychevU.VB_ProcData.VB_Invoke_Func = " \n14"
Dim Pol#, Dpol#, k&, z#
If IsMissing(n) Then k = 1 Else k = n
z = x
Call EvalChebychevU(k, z, Pol, Dpol)
Poly_ChebychevU = PasteVector_(Array(Pol, Dpol))
End Function

Function Poly_Hermite(x, Optional n)
Attribute Poly_Hermite.VB_Description = "Evaluates the Hermite orthogonal polynomial"
Attribute Poly_Hermite.VB_HelpID = 268
Attribute Poly_Hermite.VB_ProcData.VB_Invoke_Func = " \n14"
Dim Pol#, Dpol#, k&, z#
If IsMissing(n) Then k = 1 Else k = n
z = x
Call EvalHermite(k, z, Pol, Dpol)
Poly_Hermite = PasteVector_(Array(Pol, Dpol))
End Function

Function Poly_Laguerre(x, Optional n, Optional m)
Attribute Poly_Laguerre.VB_Description = "Evaluates the generalized Laguerre orthogonal polynomial"
Attribute Poly_Laguerre.VB_HelpID = 268
Attribute Poly_Laguerre.VB_ProcData.VB_Invoke_Func = " \n14"
Dim Pol#, Dpol#, k&, i&, z#
If IsMissing(n) Then k = 1 Else k = n
If IsMissing(m) Then i = 0 Else i = m
z = x
Call EvalLaguerre(i, k, z, Pol, Dpol)
Poly_Laguerre = PasteVector_(Array(Pol, Dpol))
End Function

Function Poly_Gegenbauer(ByVal lambda#, x, Optional n)
Attribute Poly_Gegenbauer.VB_Description = "Evaluates the Gegenbauer orthogonal polynomial"
Attribute Poly_Gegenbauer.VB_HelpID = 268
Attribute Poly_Gegenbauer.VB_ProcData.VB_Invoke_Func = " \n14"
Dim Pol#, Dpol#, k&, z#
If IsMissing(n) Then k = 1 Else k = n
z = x
Call EvalGegenbauer(lambda, k, z, Pol, Dpol)
Poly_Gegenbauer = PasteVector_(Array(Pol, Dpol))
End Function

Function Poly_Jacobi(a, b, x, Optional n)
Attribute Poly_Jacobi.VB_Description = "Evaluates the Jacobi orthogonal polynomial"
Attribute Poly_Jacobi.VB_HelpID = 268
Attribute Poly_Jacobi.VB_ProcData.VB_Invoke_Func = " \n14"
Dim Pol#, Dpol#, k&, U#, v#, z#
If IsMissing(n) Then k = 1 Else k = n
z = x: U = a: v = b
Call EvalJacobi(U, v, k, z, Pol, Dpol)
Poly_Jacobi = PasteVector_(Array(Pol, Dpol))
End Function

Sub Poly_Legendre_Builder(Degree&, Coef(), kd)
'compute the coefficients of the Legendre polynomial
' degree < 24  in standard 32-bit precision
Dim nMax&, n&, i&, l#(), Ld#(), a#, b#, c#
nMax = Degree
ReDim l(nMax, 2), Ld(2)
l(0, 0) = 1
l(1, 1) = 1
Ld(0) = 1
Ld(1) = 1
n = 2
Do Until n > nMax
    'iterate
    a = Ld(0) * (2 * n - 1)
    b = (n - 1) * Ld(1)
    l(0, 2) = -b * l(0, 0)
    For i = 1 To n
        l(i, 2) = a * l(i - 1, 1) - b * l(i, 0)
    Next i
    'compute the GCD
    c = n * Ld(1) * Ld(0)
    Ld(2) = c
    For i = 1 To n
        c = MCD_2(c, l(i, 2))
    Next i
    'reduce terms
    Ld(2) = Ld(2) / c
    For i = 0 To n
        l(i, 2) = l(i, 2) / c
    Next i
    'shift
    For i = 0 To n
        l(i, 0) = l(i, 1)
        l(i, 1) = l(i, 2)
        l(i, 2) = 0
    Next i
    Ld(0) = Ld(1)
    Ld(1) = Ld(2)
    n = n + 1
Loop

ReDim Coef(nMax)
For i = 0 To nMax
    Coef(i) = l(i, 1)
Next i
kd = Ld(1)
End Sub

Sub Poly_Chebychev_Builder1(Degree&, Coef(), ByVal kind&)
'compute the coefficients of the Chebychev polynomial 1st and 2nd kind
' degree < 44 in standard 32-bit precision
' degree < 78 96-bit variant decimal
' degree > 77 slow high precision
Dim nMax&, n&, i&, z, Two
nMax = Degree
ReDim l(nMax, 2), Coef(nMax)
If nMax > 77 Then
  l(0, 0) = vbStr1: z = vbStr0: Two = vbStr2
ElseIf nMax > 43 Then
  l(0, 0) = CDec(1): z = CDec(0): Two = CDec(2)
Else
  l(0, 0) = 1#: z = 0#: Two = 2#
End If
If kind = 1 Then  '1st kind
  l(1, 1) = l(0, 0)
Else '2nd kind
  l(1, 1) = Two
End If
l(0, 1) = z
n = 2
Do Until n > nMax
  'iterate
  If nMax > 77 Then
    l(0, 2) = xNeg(l(0, 0))
    For i = 1 To n: l(i, 2) = xSub(xMultR(2, l(i - 1, 1), DIGITS_LIMIT), l(i, 0), DIGITS_LIMIT): Next
  Else
    l(0, 2) = -l(0, 0)
    For i = 1 To n: l(i, 2) = Two * l(i - 1, 1) - l(i, 0): Next
  End If
  'shift
  For i = 0 To n
    l(i, 0) = l(i, 1)
    l(i, 1) = l(i, 2)
    l(i, 2) = z
  Next i
  n = n + 1
Loop

For i = 0 To nMax: Coef(i) = l(i, 1): Next
End Sub

Sub Poly_Hermite_Builder(Degree&, Coef())
'compute the coefficients of the Hermite polynomial
' degree < 23  in standard 32-bit precision
' degree < 37 96-bit variant decimal
' degree > 36 slow high precision
Dim nMax&, n&, i&, z, Two
nMax = Degree
ReDim l(nMax, 2), Coef(nMax)
If nMax > 36 Then
  l(0, 0) = vbStr1: z = vbStr0: Two = vbStr2
ElseIf nMax > 22 Then
  l(0, 0) = CDec(1): z = CDec(0): Two = CDec(2)
Else
  l(0, 0) = 1#: z = 0#: Two = 2#
End If
l(1, 1) = Two: l(0, 1) = z
n = 2
Do Until n > nMax
    'iterate
  If nMax > 36 Then
    l(0, 2) = xMult(xMultR(-(n - 1), l(0, 0), DIGITS_LIMIT), Two, DIGITS_LIMIT)
    For i = 1 To n: l(i, 2) = xSub(xMultR(Two, l(i - 1, 1), DIGITS_LIMIT), _
      xMultR(xMultR(Two, l(i, 0), DIGITS_LIMIT), (n - 1), DIGITS_LIMIT), DIGITS_LIMIT): Next
  Else
    l(0, 2) = (n - 1) * l(0, 0) * -Two
    For i = 1 To n: l(i, 2) = Two * l(i - 1, 1) - Two * l(i, 0) * (n - 1): Next
  End If
    'shift
    For i = 0 To n
        l(i, 0) = l(i, 1)
        l(i, 1) = l(i, 2)
        l(i, 2) = z
    Next i
    n = n + 1
Loop

For i = 0 To nMax: Coef(i) = l(i, 1): Next
End Sub

Sub Poly_Laguerre_Builder(Degree&, Coef(), kd, Optional m As Long = 0)
Dim l#(), Ld#(), nMax&, n&, i&
Dim a, b, c

nMax = Degree
ReDim l(nMax, 2), Ld(2)
l(0, 0) = 1
l(0, 1) = 1 + m
l(1, 1) = -1
Ld(0) = 1
Ld(1) = 1

n = 2
Do Until n > nMax
    'iterate
    a = Ld(0) * (2 * n - 1 + m)
    b = (n - 1 + m) * Ld(1)
    For i = 0 To n
        l(i, 2) = a * l(i, 1) - b * l(i, 0)
    Next i
    For i = 1 To n
        l(i, 2) = l(i, 2) - Ld(0) * l(i - 1, 1)
    Next i
    'compute the GCD
    c = n * Ld(1) * Ld(0)
    Ld(2) = c
    For i = 1 To n
        c = MCD_2(c, l(i, 2))
    Next i
    'reduce terms
    Ld(2) = Ld(2) / c
    For i = 0 To n
        l(i, 2) = l(i, 2) / c
    Next i
    'shift
    For i = 0 To n
        l(i, 0) = l(i, 1)
        l(i, 1) = l(i, 2)
        l(i, 2) = 0
    Next i
    Ld(0) = Ld(1)
    Ld(1) = Ld(2)
    n = n + 1
Loop

ReDim Coef(nMax)
For i = 0 To nMax
    Coef(i) = l(i, 1)
Next i
kd = Ld(1)
End Sub

Sub Poly_Gegenbauer_Builder(Degree&, lambda#, Coef())
'compute the coefficients of the Gegembauer polynomial
' degree < ?  in standard 32-bit precision
Dim nMax&, n&, i&, l#(), a#, b#
nMax = Degree
ReDim l(nMax, 2), Coef(nMax)
l(0, 0) = 1
l(1, 1) = 2 * lambda
n = 2
Do Until n > nMax
    'iterate
    a = 2 * (n + lambda - 1) / n
    b = -(n + 2 * lambda - 2) / n
    l(0, 2) = b * l(0, 0)
    For i = 1 To n
        l(i, 2) = a * l(i - 1, 1) + b * l(i, 0)
    Next i
    'shift
    For i = 0 To n
        l(i, 0) = l(i, 1)
        l(i, 1) = l(i, 2)
        l(i, 2) = 0
    Next i
    n = n + 1
Loop

For i = 0 To nMax: Coef(i) = l(i, 1): Next
End Sub

Sub Poly_Jacobi_Builder(Degree&, a#, b#, Coef())
'compute the coefficients of the jacobi polynomial
' degree < ?  in standard 32-bit precision
Dim nMax&, n&, i&, l#()
Dim f1, f2, f3, fd
nMax = Degree
ReDim l(nMax, 2)
l(0, 0) = 1
l(1, 0) = (a - b) / 2
l(1, 1) = (a + b + 2) / 2
n = 2
Do Until n > nMax
    'iterate
    fd = 2 * n * (n + a + b) * (2 * n - 2 + a + b)
    f1 = (2 * n - 1 + a + b) * (a ^ 2 - b ^ 2) / fd
    f2 = Pochammer(2 * n - 2 + a + b, 3) / fd
    f3 = -2 * (n - 1 + a) * (n - 1 + b) * (2 * n + a + b) / fd
    For i = 0 To n
        l(i, 2) = f1 * l(i, 1) + f3 * l(i, 0)
    Next i
    For i = 1 To n
        l(i, 2) = l(i, 2) + f2 * l(i - 1, 1)
    Next i
    'shift
    For i = 0 To n
        l(i, 0) = l(i, 1)
        l(i, 1) = l(i, 2)
        l(i, 2) = 0
    Next i
    n = n + 1
Loop

ReDim Coef(nMax)
For i = 0 To nMax
    Coef(i) = l(i, 1)
Next i
End Sub

Private Function Pochammer(x, n)
Dim i&, y#
y = x
For i = 1 To n - 1
    y = y * (x + i)
Next i
Pochammer = y
End Function

Function Poly_Weight_Legendre(n)
Attribute Poly_Weight_Legendre.VB_Description = "Weight of the Legendre orthogonal polynomial"
Attribute Poly_Weight_Legendre.VB_HelpID = 275
Attribute Poly_Weight_Legendre.VB_ProcData.VB_Invoke_Func = " \n14"
'Legendre polynomial weight
    Poly_Weight_Legendre = 2 / (2 * n + 1)
End Function

Function Poly_Weight_ChebychevT(n)
Attribute Poly_Weight_ChebychevT.VB_Description = "Weight of the Chebychev orthogonal polynomial of 1st kind"
Attribute Poly_Weight_ChebychevT.VB_HelpID = 275
Attribute Poly_Weight_ChebychevT.VB_ProcData.VB_Invoke_Func = " \n14"
'Chebyshev polynomial of the first kind weight
Select Case n
  Case 0: Poly_Weight_ChebychevT = Pi_
  Case Is < 44: Poly_Weight_ChebychevT = Pi2_
  Case Is < 78: Poly_Weight_ChebychevT = CStr(qPi2_)
  Case Else: Poly_Weight_ChebychevT = BC(xPi2_, n)
End Select
End Function

Function Poly_Weight_ChebychevU(n)
Attribute Poly_Weight_ChebychevU.VB_Description = "Weight of the Chebychev orthogonal polynomial of 2nd kind"
Attribute Poly_Weight_ChebychevU.VB_HelpID = 275
Attribute Poly_Weight_ChebychevU.VB_ProcData.VB_Invoke_Func = " \n14"
'Chebyshev polynomial of the second kind weight
Select Case n
  Case Is < 44: Poly_Weight_ChebychevU = Pi2_
  Case Is < 78: Poly_Weight_ChebychevU = CStr(qPi2_)
  Case Else: Poly_Weight_ChebychevU = BC(xPi2_, n)
End Select
End Function

Function Poly_Weight_Laguerre(ByVal n&, ByVal m&)
Attribute Poly_Weight_Laguerre.VB_Description = "Weight of the generalized Laguerre orthogonal polynomial"
Attribute Poly_Weight_Laguerre.VB_HelpID = 275
Attribute Poly_Weight_Laguerre.VB_ProcData.VB_Invoke_Func = " \n14"
'generalized Laguerre polynomial weight
Dim i&, p#
p = 1
For i = n + 1 To n + m
    p = p * i
Next i
Poly_Weight_Laguerre = p
End Function

Function Poly_Weight_Hermite(ByVal n&)
Attribute Poly_Weight_Hermite.VB_Description = "Weight of the Hermite orthogonal polynomial"
Attribute Poly_Weight_Hermite.VB_HelpID = 275
Attribute Poly_Weight_Hermite.VB_ProcData.VB_Invoke_Func = " \n14"
'Hermite polynomial weight (mod. 7.9.06)
Dim i&, p, d&
If n > 22 Then
  p = vbStr1
  For i = 1 To n: p = xMultR(p, i, DIGITS_LIMIT): Next
  d = Len(p) * 2
  Poly_Weight_Hermite = xMult(BC(xSqPi_, d), xMultR(xPow2Int(n, d), p, DIGITS_LIMIT), d)
Else
  p = 1#
  For i = 1 To n: p = p * i: Next
  Poly_Weight_Hermite = SqPi_ * 2 ^ n * p
End If
End Function

Function Poly_Weight_Gegenbauer(ByVal n#, ByVal l#)
Attribute Poly_Weight_Gegenbauer.VB_Description = "Weight of the Gegenbauer orthogonal polynomial"
Attribute Poly_Weight_Gegenbauer.VB_HelpID = 275
Attribute Poly_Weight_Gegenbauer.VB_ProcData.VB_Invoke_Func = " \n14"
'Gegenbauer polynomial weight
Dim p#
p = Log(Pi_) + (1 - 2 * l) * dLn2_ - Log(n + 1)
With Application.WorksheetFunction
    p = p + .GammaLn(n + 2 * l) - .GammaLn(n + 1) - 2 * .GammaLn(l)
End With
    Poly_Weight_Gegenbauer = Exp(p)
End Function

Function Poly_Weight_Jacobi(ByVal n#, ByVal a#, ByVal b#)
Attribute Poly_Weight_Jacobi.VB_Description = "Weight of the Jacobi orthogonal polynomial"
Attribute Poly_Weight_Jacobi.VB_HelpID = 275
Attribute Poly_Weight_Jacobi.VB_ProcData.VB_Invoke_Func = " \n14"
'Jacobi polynomial weight
Dim p#
p = (a + b + 1) * dLn2_ - Log(2 * n + a + b + 1)
With Application.WorksheetFunction
    p = p + .GammaLn(n + a + 1) + .GammaLn(n + b + 1) - .GammaLn(n + 1) - .GammaLn(n + a + b + 1)
End With
    Poly_Weight_Jacobi = Exp(p)
End Function

VBA Filename frmD2integr.frm Extracted Macro

Option Explicit
'Public UserChoice As Long
Public Layout As Long
Dim R0, C0

Private Sub CheckBox_polar_Click()
    Variable_Label_set
End Sub

Private Sub CommandButton_help_Click()
Application.Help XHelpFile, 182
End Sub

Private Sub CommandButton_run_Click()
'UserChoice = 1
If Len(Me.RefEdit_Fxy) = 0 Then
    MsgBox "polynomial missing", vbExclamation
    Me.RefEdit_Fxy.SetFocus
    Exit Sub
ElseIf Len(Me.RefEdit_Xmax) = 0 Then
    MsgBox "X bounding limit missing", vbExclamation
    Me.RefEdit_Xmax.SetFocus
    Exit Sub
ElseIf Len(Me.RefEdit_Xmin) = 0 Then
    MsgBox "X bounding limit missing", vbExclamation
    Me.RefEdit_Xmin.SetFocus
    Exit Sub
ElseIf Len(Me.RefEdit_Ymax) = 0 Then
    MsgBox "Y bounding limit missing", vbExclamation
    Me.RefEdit_Ymax.SetFocus
    Exit Sub
ElseIf Len(Me.RefEdit_Ymin) = 0 Then
    MsgBox "Y bounding limit missing", vbExclamation
    Me.RefEdit_Ymin.SetFocus
    Exit Sub
End If

If Len(Me.RefEdit_Out) = 0 Then Set_Default_Output_Cell
Me.Label_msg = "running..."

Integration_start

Me.Label_msg = "elaboration end"

End Sub

Private Sub UserForm_Activate()
Me.Label_msg = vbNullString
Me.CheckBox_polar = False
If Not ActiveCell Is Nothing Then
  If Not IsEmpty(ActiveCell) Then
    Me.RefEdit_Fxy = ActiveCell.Address
    Set_output_range
  End If
End If
Variable_Label_set
End Sub

Private Sub UserForm_Initialize()
'nothing to do
End Sub


Private Sub Set_output_range()
Dim myRange As Range, s$
    Set myRange = Range(Me.RefEdit_Fxy)
    R0 = myRange.Row
    C0 = myRange.Column
    If Not IsEmpty(Cells(R0, C0 + 1)) Then 'guess layout horizontal
        Layout = 0
        Me.RefEdit_Xmin = Cells(R0, C0 + 1).Address
        If IsEmpty(Cells(R0, C0 + 2)) Then GoTo SetOutCell
        Me.RefEdit_Xmax = Cells(R0, C0 + 2).Address
        If IsEmpty(Cells(R0, C0 + 3)) Then GoTo SetOutCell
        Me.RefEdit_Ymin = Cells(R0, C0 + 3).Address
        If IsEmpty(Cells(R0, C0 + 4)) Then GoTo SetOutCell
        Me.RefEdit_Ymax = Cells(R0, C0 + 4).Address
  If Not IsEmpty(Cells(R0, C0 + 5)) Then If R0 <> 1 Then _
    If Not IsEmpty(Cells(R0 - 1, C0 + 5)) Then _
      Param_Address_Right R0 - 1, C0 + 5, s: Me.RefEdit_Param = s
    ElseIf Not IsEmpty(Cells(R0 + 1, C0)) Then
        Layout = 1
        Me.RefEdit_Xmin = Cells(R0 + 1, C0).Address
        If IsEmpty(Cells(R0 + 2, C0)) Then GoTo SetOutCell
        Me.RefEdit_Xmax = Cells(R0 + 2, C0).Address
        If IsEmpty(Cells(R0 + 3, C0)) Then GoTo SetOutCell
        Me.RefEdit_Ymin = Cells(R0 + 3, C0).Address
        If IsEmpty(Cells(R0 + 4, C0)) Then GoTo SetOutCell
        Me.RefEdit_Ymax = Cells(R0 + 4, C0).Address
  If Not IsEmpty(Cells(R0 + 5, C0)) Then If C0 <> 1 Then _
    If Not IsEmpty(Cells(R0 + 5, C0 - 1)) Then _
      Param_Address_Down R0 + 5, C0 - 1, s: Me.RefEdit_Param = s
    End If
SetOutCell: Set_Default_Output_Cell
End Sub

Sub Set_Default_Output_Cell()
    If Layout = 1 Then
        Me.RefEdit_Out = Cells(R0, C0 + 2).Address
    Else
        Me.RefEdit_Out = Cells(R0 + 2, C0).Address
    End If
End Sub

Private Sub Variable_Label_set()
If Me.CheckBox_polar Then
    Me.Label_1.Font = "Symbol"
    Me.Label_1 = "r"
    Me.Label_2.Font = "Symbol"
    Me.Label_2 = "q"
Else
    Me.Label_1.Font = "Tahoma"
    Me.Label_1 = "x"
    Me.Label_2.Font = "Tahoma"
    Me.Label_2 = "y"
End If
End Sub

Sub Integration_start()
Dim Fxy$, kMax&, ErrMax#, PolarCoor As Boolean, Param, ParamRange
Dim Bound_min(1 To 2), Bound_max(1 To 2), results(), ErrMsg$, Out_Range, Lay
Dim U(1 To 2, 1 To 5), v, Ret, t0, t1, i&, R0, C0, j&, ErrMsgEval$
'
    'set input parameter
    'get ouptut parameter
With Me
    Bound_min(1) = .RefEdit_Xmin   'lower bound function  h1(y)
    Bound_max(1) = .RefEdit_Xmax   'upper bound function  h2(y)
    Bound_min(2) = .RefEdit_Ymin   'lower bound function  h1(y)
    Bound_max(2) = .RefEdit_Ymax   'upper bound function  h2(y)
    Fxy = .RefEdit_Fxy             'integration function  f(x,y)
    PolarCoor = .CheckBox_polar    'polar coordinate
    ErrMax = .TextBox_Error
    kMax = .TextBox_Kmax
    Out_Range = .RefEdit_Out
    Lay = .Layout
    ParamRange = .RefEdit_Param
End With  '---------------------------------------------

t0 = Timer
'substitute cell references with their values
If InStr(Fxy, "$") Then Fxy = Range(Fxy).Value
For i = 1 To 2
    If InStr(Bound_min(i), "$") Then Bound_min(i) = Range(Bound_min(i)).Value
    If InStr(Bound_max(i), "$") Then Bound_max(i) = Range(Bound_max(i)).Value
Next

'substitutes the coordinate system variables (if any)
For i = 1 To 2
    Bound_min(i) = Replace_SysVar(Bound_min(i))
    Bound_max(i) = Replace_SysVar(Bound_max(i))
Next i
'
If Len(ParamRange) <> 0 Then
    If IsNumeric(ParamRange) Then Param = ParamRange Else Param = Range(ParamRange)
    Integral_2D_N Fxy, Bound_min, Bound_max, results, kMax, ErrMax, ErrMsg, ErrMsgEval, PolarCoor, Param
Else
    Integral_2D_N Fxy, Bound_min, Bound_max, results, kMax, ErrMax, ErrMsg, ErrMsgEval, PolarCoor
End If
'
t1 = Timer - t0
GoSub Write_Results
Exit Sub
'
'internal routine ------------
Write_Results:
Dim OrigCalcStatus As Integer
On Error Resume Next
OrigCalcStatus = Application.Calculation
Application.Calculation = xlCalculationManual
    'setting results for output
    R0 = Range(Out_Range).Row
    C0 = Range(Out_Range).Column
    If Len(ErrMsg) = 0 Or ErrMsg = "Evaluation error" Then
        If Len(ErrMsg) <> 0 Then ErrMsg = "Singularity: dubious accuracy -- " & ErrMsgEval
        U(1, 1) = "Integral"
        U(1, 2) = "Err. rel."
        U(1, 3) = "Points"
        U(1, 4) = "Time"
        U(1, 5) = vbNullString
        U(2, 1) = results(1)
        U(2, 2) = results(2)
        U(2, 3) = results(3)
        U(2, 4) = t1
        U(2, 5) = ErrMsg
    Else
        U(1, 1) = ErrMsg
    End If
    v = U
    If Lay = 1 Then v = Application.WorksheetFunction.Transpose(v)
    For i = 1 To UBound(v, 1)
    For j = 1 To UBound(v, 2)
        Cells(R0 + i - 1, C0 + j - 1) = v(i, j)
    Next j, i
Application.Calculation = OrigCalcStatus
Return
End Sub

'substitutes the polar and cylindrical variables (r, q, f) -> ( x, y, z)
'or (ro, theta, phi) -> (x, y, z)
Private Function Replace_SysVar(ByVal sFormula)
    replace_substr sFormula, "r", "x"
    replace_substr sFormula, "q", "y"
    replace_substr sFormula, "f", "z"
    replace_substr sFormula, "ro", "x"
    replace_substr sFormula, "theta", "y"
    replace_substr sFormula, "phi", "z"
    Replace_SysVar = sFormula
End Function

'check if it is a letter
Private Function IsLetter(ByVal char$) As Boolean
  Dim code As Integer
  code = Asc(char)
  IsLetter = (65 <= code And code <= 90) Or (97 <= code And code <= 122) Or char = "_"
End Function

Private Sub replace_substr(s, s1, s2)
Dim i%, c1$, c2$, ss1$, ss2$
i = 1
Do
    i = InStr(i, s, s1, vbTextCompare)
    If i = 0 Then Exit Do
    If i > 1 Then c1 = Mid$(s, i - 1, 1) Else c1 = " "
    If i < Len(s) Then c2 = Mid$(s, i + Len(s1), 1) Else c2 = " "
    If Not IsLetter(c1) And Not IsLetter(c2) And Not IsNumeric(c2) Then
        ss1 = Left$(s, i - 1)
        ss2 = Right$(s, Len(s) - Len(s1) - i + 1)
        s = ss1 + s2 + ss2
    End If
    i = i + 1
Loop

End Sub

VBA Filename Matrix.bas Extracted Macro
Option Explicit
' Notes: Nesting Matrix function with non-square result Matrix MIGHT be problematic.
'        Only perfect swap requests will be honored(output#of rows and columns exactly reversed)
'        Single cell matrix returns(1,1) are translated to non-arrays to accommodate nesting with non-array functions

Function xRegrL(y, x, Optional Digit_Max, Optional Intcpt, Optional ETA)
Attribute xRegrL.VB_Description = "Returns the coefficients of the linear regression\ny = a0 + a1*x1 + a2*x2 + a3*x3 + ... + am*Xm\nwith SVD, where y(n): range of dependent variables, x(n,m): range of independent variables, Intcpt = 0 for curve through origin, otherwise Intcpt = 1 (default)"
Attribute xRegrL.VB_HelpID = 502
Attribute xRegrL.VB_ProcData.VB_Invoke_Func = " \n14"
'Returns the coefficients of the linear regression
'y = a0 + a1 * x1 + a2 * x2 + a3 * x3 + \x85 + am * Xm
'computed with singular value decomposition, where
'y(n): range of dependent variables, x(n,m): range of
'independent variables, Intcpt = 0 for curve through
'origin, otherwise Intcpt = 1 (default).
Dim a, b, c, n&, i&, m&, j&
If IsMissing(Intcpt) Then Intcpt = 1 Else Intcpt = Intcpt
LoadMatrix b, n, m, x
LoadMatrix c, i, j, y
If i = 1 Then c = MatTI(c): a = i: i = j: j = a
If i <> n Then If i = m Then b = MatTI(b): a = m: m = n: n = a
If j <> 1 Or i <> n Then ErrRaise , "xRegrL: Invalid Dimensions"
  ReDim a(1 To n, 1 To m + 1)
  For i = 1 To n: a(i, 1) = Intcpt
    For j = 1 To m: a(i, j + 1) = b(i, j)
  Next j, i
xRegrL = xMatMult(xMPseudoinv(a, Digit_Max, ETA), c, Digit_Max)
End Function

Function xMPseudoinv(mat, Optional Digit_Max, Optional ETA)
Attribute xMPseudoinv.VB_Description = "Moore-Penrose Pseudo-Inverse of SVD decomposition\nDefault ETA= '1E- & Digit_Max'"
Attribute xMPseudoinv.VB_HelpID = 502
Attribute xMPseudoinv.VB_ProcData.VB_Invoke_Func = " \n14"
'Moore-Penrose Pseudo-Inverse A+ = V*Di*Ut of SVD decomposition A = U*D*Vt
Dim a, w, v, n&, m&
LoadMatrix a, m, n, mat
xSVD_decomp a, w, v, Digit_Max, ETA
xSVD_sortALL a, v, w, a, v, w, -Digit_Max ' -Digit_Max for matrix return of xMatInv(w), Transposed a
xMPseudoinv = xMatMult(v, xMatMult(w, a, Digit_Max), Digit_Max)
End Function

Function xMCond(mat, Optional Digit_Max, Optional ETA) As String
Attribute xMCond.VB_Description = "Multi-precision Condition number of a Matrix\nusing Singular Value Decomposition. Default ETA= '1E- & Digit_Max'"
Attribute xMCond.VB_HelpID = 502
Attribute xMCond.VB_ProcData.VB_Invoke_Func = " \n14"
'condition number of SVD decomposition
Dim a, w, v, n&, m&
LoadMatrix a, n, m, mat
xSVD_decomp a, w, v, Digit_Max, ETA, False, False
xSVD_sortD a, v, w, v, Digit_Max
If n < m Then m = n
xMCond = xDiv(v(1, 1), v(m, m), Digit_Max)
End Function

Function xMpCond(mat, Optional Digit_Max, Optional ETA) As String
Attribute xMpCond.VB_Description = "Multi-precision -log10 of Condition number of a Matrix\nusing Singular Value Decomposition. Default ETA= '1E- & Digit_Max'"
Attribute xMpCond.VB_HelpID = 502
Attribute xMpCond.VB_ProcData.VB_Invoke_Func = " \n14"
'-log10 of condition number (suggested from Bob de Levie)
Dim y$
y = xMCond(mat, Digit_Max, ETA)
xMpCond = xNeg(xLog(y, 10, Digit_Max))
End Function

Function xSVDD(mat, Optional Digit_Max, Optional ETA)
Attribute xSVDD.VB_Description = "Singular Value Decomposition: returns D matrix in Multi-Precision\nDefault ETA= '1E- & Digit_Max'"
Attribute xSVDD.VB_HelpID = 502
Attribute xSVDD.VB_ProcData.VB_Invoke_Func = " \n14"
'returns the second matrix of SVD decomposition 'A = U*D*V^t
Dim a, w, v, n&, m&
LoadMatrix a, m, n, mat
xSVD_decomp a, w, v, Digit_Max, ETA, False, False
xSVD_sortD a, v, w, xSVDD, Digit_Max
End Function

Function xSVDV(mat, Optional Digit_Max, Optional ETA)
Attribute xSVDV.VB_Description = "Singular Value Decomposition: returns V matrix in Multi-Precision\nDefault ETA= '1E- & Digit_Max'"
Attribute xSVDV.VB_HelpID = 502
Attribute xSVDV.VB_ProcData.VB_Invoke_Func = " \n14"
'returns the third matrix of SVD decomposition 'A = U*D*V^t
Dim a, w, v, n&, m&
LoadMatrix a, n, m, mat
xSVD_decomp a, w, v, Digit_Max, ETA, False
xSVD_sortV a, v, w, xSVDV, Digit_Max
End Function

Function xSVDU(mat, Optional Digit_Max, Optional ETA)
Attribute xSVDU.VB_Description = "Singular Value Decomposition: returns U matrix in Multi-Precision\nDefault ETA= '1E- & Digit_Max'"
Attribute xSVDU.VB_HelpID = 502
Attribute xSVDU.VB_ProcData.VB_Invoke_Func = " \n14"
'returns the first matrix of SVD decomposition 'A = U*D*V^t
Dim a, w, v, n&, m&
LoadMatrix a, n, m, mat
xSVD_decomp a, w, v, Digit_Max, ETA, , False
xSVD_sortU a, v, w, xSVDU, Digit_Max
End Function

Function xMDet(mat, Optional Digit_Max) As String: xMatDet_ xMDet, mat, Digit_Max: End Function
Attribute xMDet.VB_Description = "returns the determinant of a square matrix in multiprecision"
Attribute xMDet.VB_HelpID = 87
Attribute xMDet.VB_ProcData.VB_Invoke_Func = " \n14"
Function xMatDet(mat, Optional Digit_Max) As String: xMatDet_ xMatDet, mat, Digit_Max: End Function
Attribute xMatDet.VB_Description = "returns the determinant of a square matrix in multiprecision"
Attribute xMatDet.VB_HelpID = 87
Attribute xMatDet.VB_ProcData.VB_Invoke_Func = " \n14"
Function xMDetMCM(mat, Optional Digit_Max, Optional IsIntMat) As String: xMatDet_ xMDetMCM, mat, Digit_Max, True, IsIntMat: End Function
Attribute xMDetMCM.VB_Description = "returns the determinant of a square matrix in multiprecision\nIf IsIntMat is missing,  tests for integer matrix."
Attribute xMDetMCM.VB_HelpID = 87
Attribute xMDetMCM.VB_ProcData.VB_Invoke_Func = " \n14"

Sub xMatDet_(OMat$, mat, Optional Digit_Max, Optional UseMCM As Boolean, Optional IsIntMat)
' returns the determinant of a square matrix
Dim xa() As xNum, a, m&, n&, Det, DgMx&
LoadMatrix a, n, m, mat
If m <> n Then ErrRaise , "xMatDet: The input matrix must be square.": Exit Sub
SetDgMx DgMx, Digit_Max
If m = 1 Then Det = a(1, 1): GoTo xMx
If UseMCM Then
  xGJ_MCM a, n, m, Det, "T", DgMx, xa, IsIntMat
Else
  xGaussJordan a, n, m, Det, "T", DgMx, xa
End If
xMx: OMat = xFmtStr(Det, Digit_Max)
End Sub

Function xMInv(mat, Optional Digit_Max): xMatInv_ xMInv, mat, Digit_Max: End Function
Attribute xMInv.VB_Description = "returns the Inverse of a square matrix in mutli-precision"
Attribute xMInv.VB_HelpID = 86
Attribute xMInv.VB_ProcData.VB_Invoke_Func = " \n14"
Function xMatInv(mat, Optional Digit_Max): xMatInv_ xMatInv, mat, Digit_Max: End Function
Attribute xMatInv.VB_Description = "returns the Inverse of a square matrix in mutli-precision"
Attribute xMatInv.VB_HelpID = 86
Attribute xMatInv.VB_ProcData.VB_Invoke_Func = " \n14"
Function xMInvMCM(mat, Optional Digit_Max): xMatInv_ xMInvMCM, mat, Digit_Max, True: End Function
Attribute xMInvMCM.VB_Description = "returns the Inverse of a square matrix in mutli-precision"
Attribute xMInvMCM.VB_HelpID = 86
Attribute xMInvMCM.VB_ProcData.VB_Invoke_Func = " \n14"

Sub xMatInv_(OMat, mat, Optional Digit_Max, Optional UseMCM As Boolean)
'Returns the inverse of square matrix
Dim xa() As xNum, m&, n&, Det, i&, j&, DgMx&
SetDgMx DgMx, Digit_Max
'load matrix from range
LoadMatrix OMat, n, m, mat
If m <> n Then ErrRaise , "xMatInv: The input matrix must be square.": Exit Sub
If m = 1 Then OMat = xInv(OMat(1, 1), Digit_Max): Exit Sub
'build full matrix
m = 2 * n
ReDim Preserve OMat(1 To n, 1 To m)
For i = 1 To n: OMat(i, n + i) = 1: Next i
If UseMCM Then
  xGJ_MCM OMat, n, m, Det, "D", DgMx, xa
Else
  xGaussJordan OMat, n, m, Det, "D", DgMx, xa
End If
If Det = vbStr0 Then OMat = "Singular": Exit Sub
'save inverse
ReDim OMat(1 To n, 1 To n) As String
For i = 1 To n: For j = 1 To n
  OMat(i, j) = CvtxNum2str(xa(i, n + j), Digit_Max)
Next j, i
End Sub

Function xMAbs(mat, Optional Digit_Max) As String: xMAbs = xMatAbs(mat, Digit_Max): End Function
Attribute xMAbs.VB_Description = "returns the modulus of a matrix or a vector || V || in multi-precision"
Attribute xMAbs.VB_HelpID = 88
Attribute xMAbs.VB_ProcData.VB_Invoke_Func = " \n14"
Function xMatAbs(mat, Optional Digit_Max) As String
Attribute xMatAbs.VB_Description = "returns the modulus of a matrix or a vector || V || in multi-precision"
Attribute xMatAbs.VB_HelpID = 88
Attribute xMatAbs.VB_ProcData.VB_Invoke_Func = " \n14"
'returns the module of a vector or matrix
Dim i&, j&, a, n&, m&, DgMx&
SetDgMx DgMx, Digit_Max
LoadMatrix a, n, m, mat
tXN(1).ndgt = 0
For i = 1 To n: For j = 1 To m
    Cvt2xNum tXN(0), a(i, j), DgMx
    xMult_ tXN(0), tXN(0), tXN(0), DgMx
    xAdd_ tXN(1), tXN(1), tXN(0), DgMx
Next j, i
xSqr_ tXN(1), tXN(1), DgMx
xMatAbs = CvtxNum2str(tXN(1), Digit_Max)
End Function

Sub SwapRow(a, k&, i&)
'Swaps rows k and i
Dim j&, Temp
    For j = LBound(a, 2) To UBound(a, 2)
        Temp = a(i, j)
        a(i, j) = a(k, j)
        a(k, j) = Temp
    Next
End Sub

Sub SwapCol(a, k&, j&)
'Swaps cols k and i
Dim i&, Temp
    For i = LBound(a, 1) To UBound(a, 1)
        Temp = a(i, j)
        a(i, j) = a(i, k)
        a(i, k) = Temp
    Next
End Sub

Function MatInv_(a, Optional dTiny)
Dim b
b = a
GJ b, , dTiny
MatInv_ = b
End Function

Function MatDet_(a, Optional dTiny) As Double
Dim b, d
b = a
GJ b, , d, dTiny
MatDet_ = d
End Function

'===============================================================
Sub GJ(a, Optional b, Optional Det, Optional dTiny)
'==============================================================
'Gauss-Jordan algorithm for matrix reduction with full pivot method
'A is a matrix (n x n); at the end contains the inverse of A
'B is a matrix (n x m); at the end cotains the solution of AX=B
'this version apply the check for too small elements: |aij|<Tiny
'rev. version of 13-8-2002
'==============================================================
Dim i&, j&, irow&, icol&, id&(), sw%, m&, n&, k&, PivotMax#, pk#
If IsMissing(dTiny) Then dTiny = 0
If IsMissing(Det) Then Det = 0 Else Det = 1
If IsMissing(b) Then m = 0 Else m = UBound(b, 2)
n = UBound(a, 1)
ReDim id(1 To 2 * n, 1 To 3) 'trace of swaps
sw = 0 'swap counter
For k = 1 To n
    'search max pivot
    irow = k: icol = k
    PivotMax = 0
    For i = k To n
    For j = k To n
        If Abs(a(i, j)) > PivotMax Then
            irow = i: icol = j: PivotMax = Abs(a(i, j))
        End If
    Next j
    Next i
    'ignore pivot for this condition?
    If irow = icol And Abs(a(k, k)) <> 0 Then
        irow = k
        icol = k
    End If
    ' swap rows and columns
    If irow > k Then
        SwapRow a, k, irow
        If m > 0 Then SwapRow b, k, irow
        Det = -Det
        sw = sw + 1
        id(sw, 1) = k
        id(sw, 2) = irow
        id(sw, 3) = 1
    End If
    If icol > k Then
        SwapCol a, k, icol
        Det = -Det
        sw = sw + 1
        id(sw, 1) = k
        id(sw, 2) = icol
        id(sw, 3) = 2
    End If
    ' check pivot 0
    If Abs(a(k, k)) <= dTiny Then
        a(k, k) = 0: Det = 0
        Exit Sub
    End If
    'normalization
    pk = a(k, k)
    If Det <> 0 Then Det = Det * pk
    a(k, k) = 1
    For j = 1 To n
        a(k, j) = a(k, j) / pk
    Next j
    For j = 1 To m
        b(k, j) = b(k, j) / pk
    Next j
    'linear reduction
    For i = 1 To n
        If i <> k And a(i, k) <> 0 Then
            pk = a(i, k)
            a(i, k) = 0
            For j = 1 To n
                a(i, j) = a(i, j) - pk * a(k, j)
            Next j
            For j = 1 To m
                b(i, j) = b(i, j) - pk * b(k, j)
            Next j
        End If
    Next i
Next k
'unscramble rows
For i = sw To 1 Step -1
    If id(i, 3) = 1 Then
        SwapCol a, id(i, 1), id(i, 2)
    Else
        SwapRow a, id(i, 1), id(i, 2)
        If m > 0 Then SwapRow b, id(i, 1), id(i, 2)
    End If
Next
End Sub

Sub xGaussJordan(a, n&, m&, Det, f, ByVal DgMx&, xa() As xNum)
'==============================================================
'Gauss-Jordan algorithm for triangle-diagonal matrix reduction
'Input: a = Matrix (n x m), m >= n
'       f = type of reduction : T triangle, D diagonal
'Output:det = determinant of A (n x n)
'       xA = Matrix as xNum
'==============================================================
Dim k&, w&, Ipivot&, i&, j&, TorD%
If VarType(a) > vbArray Then ConvMatIntoxNum a, xa, DgMx
DgMx = DgMx + 1 ': If DgMx > DIGITS_LIMIT Then DgMx = DIGITS_LIMIT
tXN(1).dgt(0) = 1: tXN(1).ndgt = 1: tXN(1).Sign = False: tXN(1).esp = 0: Det = 1
If f = "T" Then TorD = 1 ' Triangolarizza else TorD = 0  ' Diagonalizza
w = 1 ' "T" starts at 2, "D" is always 1
For k = 1 To n
  w = w + TorD ' add 1 for Triangle, 0 for Diagonal
  Ipivot = k: tXN(0).ndgt = 0
  For i = k To n 'search for max to pivot in column k
    tXN(2) = xa(i, k): tXN(2).Sign = False
    If xComp_(tXN(2), tXN(0)) > 0 Then tXN(0) = tXN(2): Ipivot = i
  Next i
  
  If Ipivot > k Then ' swap row
    For j = k To m: tXN(0) = xa(Ipivot, j): xa(Ipivot, j) = xa(k, j): xa(k, j) = tXN(0): Next j
    Det = -Det
  ElseIf xa(k, k).ndgt = 0 Then  'Ipivot = k ,pivot 0 check
    Det = vbStr0: Exit Sub 'entire col is 0, singular
  End If
  
  xMult_ tXN(1), tXN(1), xa(k, k), DgMx 'calc Determinant in tXN(1)
  For j = k + 1 To m: xDiv_ xa(k, j), xa(k, j), xa(k, k), DgMx: Next j 'normalize
  xa(k, k).ndgt = 1: xa(k, k).esp = 0: xa(k, k).Sign = False: xa(k, k).dgt(0) = 1 'Set Diag element to 1
  
  'linear reduction
  For i = w To n
    If i <> k Then
     If xa(i, k).ndgt <> 0 Then
      tXN(0) = xa(i, k): tXN(0).Sign = Not tXN(0).Sign
      For j = 1 To m
       If xa(k, j).ndgt <> 0 Then _
        xMult_ tXN(2), tXN(0), xa(k, j), DgMx: _
        xAdd_ xa(i, j), xa(i, j), tXN(2), DgMx
      Next j
    End If: End If
Next i, k
'convert determinant to string
If Det = -1 Then tXN(1).Sign = Not tXN(1).Sign
Det = xNum2str(tXN(1))
End Sub

Sub xGJ_MCM(a, n&, m&, Det, f, ByVal DgMx&, xa() As xNum, Optional IsIntMat)
'==============================================================
'Gauss-Jordan algorithm for triangle-diagonal matrix reduction
'   Using slower, more accurate MCM reduction for better
'   Singularity deturmination
'Input:  a = Matrix (n x m), m >= n
'        f = type of reduction : T triangle, D diagonal
'Output: Det = determinant of A (n x n) - "0" indicates singularity
'        xA = Matrix as xNum
'==============================================================
Dim k&, w&, Ipivot&, i&, j&, TorD%
If VarType(a) > vbArray Then ConvMatIntoxNum a, xa, DgMx
Det = 1
If f = "T" Then ' Triangolarizza else TorD = 0  ' Diagonalizza
  TorD = 1
  Dim DgMx2&, det_d(0) As xNum
  det_d(0).dgt(0) = 1: det_d(0).ndgt = 1: DgMx2 = DgMx + xBASE
'  Dim MinEsp&
'  MinEsp = 2147483647
'  For i = 1 To N: For j = 1 To N
'    If xa(i, j).esp < MinEsp Then MinEsp = xa(i, j).esp
'  Next j, i
  If IsMissing(IsIntMat) Then 'See if starting with "Integer" only matrix
    For i = 1 To n: For j = 1 To n
      If Not xIsInt_(xa(i, j)) Then IsIntMat = False: GoTo SkipRound
    Next j, i: IsIntMat = True
SkipRound:
End If: End If
w = 1 ' "T" starts at 2, "D" is always 1
For k = 1 To n
  w = w + TorD ' add 1 for Triangle, 0 for Diagonal
  Ipivot = k: tXN(0).ndgt = 0
  For i = k To n 'search for max to pivot in column k
    tXN(2) = xa(i, k): tXN(2).Sign = False
    If xComp_(tXN(2), tXN(0)) > 0 Then tXN(0) = tXN(2): Ipivot = i
  Next i
  
  If Ipivot > k Then ' swap row
    For j = k To m: tXN(0) = xa(Ipivot, j): xa(Ipivot, j) = xa(k, j): xa(k, j) = tXN(0): Next j
    Det = -Det
  ElseIf xa(k, k).ndgt = 0 Then  'Ipivot = k ,pivot 0 check
    Det = vbStr0: Exit Sub 'entire col is 0, singular
  End If
  
  'linear reduction
  For i = w To n
    If i <> k Then
     If xa(i, k).ndgt <> 0 Then 'Both are <>0
      xMCM_2_ xa(k, k), xa(i, k) 'Returns Minimun Common Multiple in tXN(0)
      xDiv_ tXN(1), tXN(0), xa(k, k), DgMx
      tXN(0).Sign = True: xDiv_ tXN(2), tXN(0), xa(i, k), DgMx
      If TorD Then xMult_ det_d(0), det_d(0), tXN(2), DgMx2
      For j = 1 To m
       xMult_ xa(i, j), tXN(2), xa(i, j), DgMx
       If xa(k, j).ndgt <> 0 Then _
        xMult_ tXN(0), tXN(1), xa(k, j), DgMx: _
        xAdd_ xa(i, j), xa(i, j), tXN(0), DgMx
      Next j
    End If: End If
Next i, k

If TorD = 0 Then 'normalization
  For i = 1 To n: For j = n + 1 To m
    xDiv_ xa(i, j), xa(i, j), xa(i, i), DgMx
  Next j, i
Else 'determinant computing
  For i = 2 To n: xMult_ xa(1, 1), xa(1, 1), xa(i, i), DgMx2: Next
  If Det = -1 Then det_d(0).Sign = Not det_d(0).Sign
  xDiv_ tXN(1), xa(1, 1), det_d(0), DgMx
  If IsIntMat Then xRound_ tXN(1), 0 ' Det is an Integer
'  If tXN(1).dgt(1) = 10 ^ xBASE - 1 Or tXN(1).dgt(1) = 0 Then xRound_ tXN(1), Abs(tXN(1).esp + xBASE + 1)
  Det = xNum2str(tXN(1)) 'convert to string
End If
End Sub

Function xMMult(Mat1, Mat2, Optional Digit_Max): xMMult = xMatMult(Mat1, Mat2, Digit_Max): End Function
Attribute xMMult.VB_Description = "returns the product of two matrices in multi-precision\n [n1 x m1] x[n2 x m2] => [n3 x m3]"
Attribute xMMult.VB_HelpID = 85
Attribute xMMult.VB_ProcData.VB_Invoke_Func = " \n14"
Function xMatMult(Mat1, Mat2, Optional Digit_Max)
Attribute xMatMult.VB_Description = "returns the product of two matrices in multi-precision\n [n1 x m1] x[n2 x m2] => [n3 x m3]"
Attribute xMatMult.VB_HelpID = 85
Attribute xMatMult.VB_ProcData.VB_Invoke_Func = " \n14"
' Multiply two matricies, where m1=n2
' Mat1 = matrice quadrata n1 x m1
' Mat2 = matrice quadrata n2 x m2
' Out A3 matrice quadrate n1 x m2
Dim a1, a2, a3$(), n1&, m1&, n2&, m2&
Dim x1() As xNum, x2() As xNum, x3() As xNum, DgMx&
LoadMatrix a1, n1, m1, Mat1
LoadMatrix a2, n2, m2, Mat2

If m1 <> n2 Then ErrRaise , "xMatMult: Invalid matrix size.": Exit Function
'If n1 = 1 Then If m1 = 1 Then If m2 = 1 Then xMatMult = xMult(a1(1, 1), a2(1, 1), Digit_Max): Exit Function

SetDgMx DgMx, Digit_Max
ConvMatIntoxNum a1, x1, DgMx
ConvMatIntoxNum a2, x2, DgMx
xMATMULT_ n1, m1, m2, x1, x2, x3, DgMx
ConvxNumIntoMat a3, x3, Digit_Max

PasteMatrix xMatMult, a3, n1, m2
End Function

Sub xMATMULT_(n1&, m1&, m2&, a1() As xNum, a2() As xNum, U() As xNum, DgMx&)
'performs matrix multiplication u = a1 x a2
'input  a1(n1 x m1)
'input  a2(n2 x m2)
'Output u (n1 x m2)
Dim i&, j&, k&
ReDim U(1 To n1, 1 To m2)
For i = 1 To n1: For j = 1 To m2: For k = 1 To m1
  SxMult_ tXN(0), a1(i, k), a2(k, j), DgMx
  xAdd_ U(i, j), U(i, j), tXN(0), DgMx
Next k, j, i
End Sub

Function xMSub(Mat1, Mat2, Optional Digit_Max): xMSub = xMatSub(Mat1, Mat2, Digit_Max): End Function
Attribute xMSub.VB_Description = "returns the difference of two matrices in multi-precision\n [n1 x m1] - [n2 x m2] => [n3 x m3]"
Attribute xMSub.VB_HelpID = 84
Attribute xMSub.VB_ProcData.VB_Invoke_Func = " \n14"
Function xMatSub(Mat1, Mat2, Optional Digit_Max)
Attribute xMatSub.VB_Description = "returns the difference of two matrices in multi-precision\n [n1 x m1] - [n2 x m2] => [n3 x m3]"
Attribute xMatSub.VB_HelpID = 84
Attribute xMatSub.VB_ProcData.VB_Invoke_Func = " \n14"
' Subtract two matricies
' Mat1 = matrice quadrata n1 x m1
' Mat2 = matrice quadrata n2 x m2
' Out A3 matrice quadrate n3 x m3
Dim a1, a2, a3$(), n1&, m1&, n2&, m2&, DgMx&
Dim x1() As xNum, x2() As xNum, x3() As xNum
SetDgMx DgMx, Digit_Max
LoadMatrix a1, n1, m1, Mat1
LoadMatrix a2, n2, m2, Mat2
If n1 <> n2 Or m1 <> m2 Then ErrRaise , "xMatSub: Invalid matrix size.": Exit Function
If n1 = 1 Then If m1 = 1 Then xMatSub = xSub(a1(1, 1), a2(1, 1), Digit_Max): Exit Function

ConvMatIntoxNum a1, x1, DgMx
ConvMatIntoxNum a2, x2, DgMx
xMatSub_ n1, m2, x1, x2, x3, DgMx
ConvxNumIntoMat a3, x3, Digit_Max
PasteMatrix xMatSub, a3, n1, m2
End Function

Sub xMatSub_(n&, m&, a1() As xNum, a2() As xNum, U() As xNum, DgMx&)
'performs matrix subctraction u = a1 - a2
'with multi-precision numbers
'input  a1(n1 x m1)
'input  a2(n2 x m2)
'Output u (n3 x m3)
' where n1=n2=n3, m1=m2=m3
Dim i&, j&
ReDim U(1 To n, 1 To m)
For i = 1 To n: For j = 1 To m
  xSub_ U(i, j), a1(i, j), a2(i, j), DgMx
Next j, i
End Sub

Function xMAdd(Mat1, Mat2, Optional Digit_Max): xMAdd = xMatAdd(Mat1, Mat2, Digit_Max): End Function
Attribute xMAdd.VB_Description = "returns the sum of two matrices in multi-precision\n [n1 x m1] + [n2 x m2] => [n3 x m3]"
Attribute xMAdd.VB_HelpID = 83
Attribute xMAdd.VB_ProcData.VB_Invoke_Func = " \n14"
Function xMatAdd(Mat1, Mat2, Optional Digit_Max)
Attribute xMatAdd.VB_Description = "returns the sum of two matrices in multi-precision\n [n1 x m1] + [n2 x m2] => [n3 x m3]"
Attribute xMatAdd.VB_HelpID = 83
Attribute xMatAdd.VB_ProcData.VB_Invoke_Func = " \n14"
' Add two matricies
' Mat1 = matrice quadrata n1 x m1
' Mat2 = matrice quadrata n2 x m2
' Out A3 matrice quadrate n3 x m3
Dim a1, a2, a3$(), n1&, m1&, n2&, m2&
Dim x1() As xNum, x2() As xNum, x3() As xNum, DgMx&
SetDgMx DgMx, Digit_Max
LoadMatrix a1, n1, m1, Mat1
LoadMatrix a2, n2, m2, Mat2
If n1 <> n2 Or m1 <> m2 Then ErrRaise , "xMatAdd: Invalid matrix size.": Exit Function
If n1 = 1 Then If m1 = 1 Then xMatAdd = xAdd(a1(1, 1), a2(1, 1), Digit_Max): Exit Function

ConvMatIntoxNum a1, x1, DgMx
ConvMatIntoxNum a2, x2, DgMx
xMatAdd_ n1, m2, x1, x2, x3, DgMx
ConvxNumIntoMat a3, x3, Digit_Max
PasteMatrix xMatAdd, a3, n1, m2
End Function

Sub xMatAdd_(n&, m&, a1() As xNum, a2() As xNum, U() As xNum, DgMx&)
'performs matrix addiction u = a1 + a2
'with multi-precision numbers
'input  a1(n1 x m1)
'input  a2(n2 x m2)
'Output u (n3 x m3)
' where n1=n2=n3, m1=m2=m3
Dim i&, j&
ReDim U(1 To n, 1 To m)
For i = 1 To n: For j = 1 To m
  xAdd_ U(i, j), a1(i, j), a2(i, j), DgMx
Next j, i

End Sub

Sub ConvMatIntoxNum(a, xa() As xNum, DgMx&)
'Converts a Matrix in a Matrix of xNum type
Dim i&, j&
ReDim xa(LBound(a, 1) To UBound(a, 1), LBound(a, 2) To UBound(a, 2))
For i = LBound(a, 1) To UBound(a, 1)
For j = LBound(a, 2) To UBound(a, 2)
    Cvt2xNum xa(i, j), a(i, j), DgMx
Next j, i
End Sub

Sub ConvVectIntoxNum(v(), xV() As xNum, DgMx&)
'Converts a Matrix in a Matrix of xNum type
Dim i&
ReDim xV(LBound(v, 1) To UBound(v, 1))
For i = LBound(v, 1) To UBound(v, 1)
    Cvt2xNum xV(i), v(i), DgMx
Next i
End Sub

Sub ConvxNumIntoMat(a$(), xa() As xNum, Digit_Max)
'Converts a Matrix of xNum in a Matrix of Formatted Strings
Dim i&, j&: ReDim a$(LBound(xa, 1) To UBound(xa, 1), LBound(xa, 2) To UBound(xa, 2))
For i = LBound(a, 1) To UBound(a, 1): For j = LBound(a, 2) To UBound(a, 2)
    a(i, j) = CvtxNum2str(xa(i, j), Digit_Max)
Next j, i
End Sub

'Sub xNumIntoMat(a$(), xA() As xNum)
''Converts a Matrix of xNum in a Matrix of UnFormatted Strings
'Dim i&, j&: ReDim a$(LBound(xA, 1) To UBound(xA, 1), LBound(xA, 2) To UBound(xA, 2))
'For i = LBound(a, 1) To UBound(a, 1): For j = LBound(a, 2) To UBound(a, 2)
'    a(i, j) = xNum2str(xA(i, j))
'Next j, i
'End Sub

Sub LoadMatrix(a, n&, m&, mat)
If IsArray(mat) Then
  a = mat
  n = UBound(a, 1)
  On Error Resume Next
  m = UBound(a, 2)
  If Err = 0 Then Exit Sub
  Dim tmp
  If n = 1 Then tmp = a(1): GoTo Set1
  tmp = a
  ReDim a(1 To 1, 1 To n)
  For m = 1 To n
    a(1, m) = tmp(m)
  Next m
  m = n: n = 1
ElseIf VarType(mat) < vbInteger Then
    ErrRaise , "Invalid Matrix": Exit Sub
Else
  n = 1: tmp = mat
Set1: ReDim a(1 To 1, 1 To 1)
  a(1, 1) = tmp
  m = 1
End If
End Sub

Sub PasteMatrix(MatO, MatI$(), n&, m&)
If n <> m Then
  If Not xNumInvAppCallFlg Then
   If n = Application.Caller.Columns.Count Then
    If m = Application.Caller.Rows.Count Then
      Dim i&, j&
      ReDim MatO(1 To m, 1 To n) As String
      For i = 1 To n: For j = 1 To m: MatO(j, i) = MatI(i, j): Next j, i: Exit Sub
  End If: End If: End If
ElseIf n = 1 Then
  MatO = MatI(1, 1): Exit Sub
End If
MatO = MatI
End Sub

Function xSysLinMCM(mat, v, Optional Digit_Max): xSYSLIN_NM_ xSysLinMCM, mat, v, Digit_Max, True: End Function
Attribute xSysLinMCM.VB_Description = "Solve Linear System Ax = B ( Gauss-Jordan algorithm ) in multiprecision arithmetic"
Attribute xSysLinMCM.VB_HelpID = 92
Attribute xSysLinMCM.VB_ProcData.VB_Invoke_Func = " \n14"
Function xSysLin(mat, v, Optional Digit_Max): xSYSLIN_NM_ xSysLin, mat, v, Digit_Max: End Function
Attribute xSysLin.VB_Description = "Solve Linear System Ax = B ( Gauss-Jordan algorithm ) in multiprecision arithmetic"
Attribute xSysLin.VB_HelpID = 92
Attribute xSysLin.VB_ProcData.VB_Invoke_Func = " \n14"

Sub xSYSLIN_NM_(OMat, mat, v, Optional Digit_Max, Optional UseMCM As Boolean)
'Solve matrix equation [Mat]*x=[V]
'Multi-Precision Arithmetic
' Mat (n x n)
' v (n x m)
' OMat (n x m) - Return result
Dim xa() As xNum, i&, j&, DgMx&
Dim a, b, Det, na&, nb&, ma&, mb&, x$()
LoadMatrix a, na, ma, mat
LoadMatrix b, nb, mb, v
If ma <> na Or na <> nb Then ErrRaise , "xSysLin: Invalid matrix size.": Exit Sub
If na = 1 Then OMat = xDiv(b(1, 1), a(1, 1), Digit_Max): Exit Sub
SetDgMx DgMx, Digit_Max
ReDim Preserve a(1 To na, 1 To na + mb)
For i = 1 To na: For j = 1 To mb: a(i, j + na) = b(i, j): Next j, i
If UseMCM Then _
  xGJ_MCM a, na, na + mb, Det, "D", DgMx, xa _
Else _
  xGaussJordan a, na, na + mb, Det, "D", DgMx, xa
If Det = vbStr0 Then OMat = "Singular": Exit Sub
'Load solutions in x
ReDim x(1 To na, 1 To mb) As String
For i = 1 To na: For j = 1 To mb
  x(i, j) = CvtxNum2str(xa(i, na + j), Digit_Max)
Next j, i
PasteMatrix OMat, x, na, mb
End Sub

Function xMBABMCM(a, b, Optional Digit_Max): xMatBAB_ xMBABMCM, a, b, Digit_Max, True: End Function
Attribute xMBABMCM.VB_Description = "Perfoms the similarity transform B^(-1)*A*B in extended precision"
Attribute xMBABMCM.VB_HelpID = 113
Attribute xMBABMCM.VB_ProcData.VB_Invoke_Func = " \n14"
Function xMBAB(a, b, Optional Digit_Max): xMatBAB_ xMBAB, a, b, Digit_Max: End Function
Attribute xMBAB.VB_Description = "Perfoms the similarity transform B^(-1)*A*B in extended precision"
Attribute xMBAB.VB_HelpID = 113
Attribute xMBAB.VB_ProcData.VB_Invoke_Func = " \n14"
Function xMatBAB(a, b, Optional Digit_Max): xMatBAB_ xMatBAB, a, b, Digit_Max: End Function
Attribute xMatBAB.VB_Description = "Perfoms the similarity transform B^(-1)*A*B in extended precision"
Attribute xMatBAB.VB_HelpID = 113
Attribute xMatBAB.VB_ProcData.VB_Invoke_Func = " \n14"

Sub xMatBAB_(OMat, a, b, Optional Digit_Max, Optional UseMCM As Boolean)
'Perfoms the similarity transform B^(-1)*A*B
'Trasformata per Contragradienza
'using multiprecision matrix arithmetic
Dim a1, a2, a3$(), n1&, m1&, n2&, m2&, Det$, i&, j&
Dim x1() As xNum, x2() As xNum, x3() As xNum, DgMx&
LoadMatrix a1, n1, m1, a
LoadMatrix a2, n2, m2, b

If m1 <> n2 Then ErrRaise , "xMatBAB: Invalid matrix size.": Exit Sub

SetDgMx DgMx, Digit_Max
ConvMatIntoxNum a1, x1, DgMx
ConvMatIntoxNum a2, x2, DgMx
DgMx = DgMx + 3
xMATMULT_ n1, m1, m2, x1, x2, x3, DgMx 'a*b

m2 = 2 * n2
ReDim Preserve x2(1 To n2, 1 To m2) 'b^-1
For i = 1 To n2: x2(i, n2 + i).ndgt = 1: x2(i, n2 + i).dgt(0) = 1: Next i
If UseMCM Then _
  xGJ_MCM n2, n2, m2, Det, "D", DgMx, x2 _
Else _
  xGaussJordan n2, n2, m2, Det, "D", DgMx, x2
If Det = vbStr0 Then OMat = "Singular": Exit Sub
ReDim x1(1 To n2, 1 To n2)
For i = 1 To n2: For j = 1 To n2: x1(i, j) = x2(i, n2 + j): Next j, i

xMATMULT_ n2, n2, n2, x1, x3, x2, DgMx '(b^-1)*(a*b)
ConvxNumIntoMat a3, x2, Digit_Max
OMat = a3
End Sub

Function xMPow(mat, n, Optional Digit_Max): xMPow = xMatPow(mat, n, Digit_Max): End Function
Attribute xMPow.VB_Description = "Returns the integer power of a square matrix: A^n in multiprecision arithmetic.\nn must be a positive integer"
Attribute xMPow.VB_HelpID = 114
Attribute xMPow.VB_ProcData.VB_Invoke_Func = " \n14"
Function xMatPow(mat, n, Optional Digit_Max)
Attribute xMatPow.VB_Description = "Returns the integer power of a square matrix: A^n in multiprecision arithmetic.\nn must be a positive integer"
Attribute xMatPow.VB_HelpID = 114
Attribute xMatPow.VB_ProcData.VB_Invoke_Func = " \n14"
'returns M^n in multiprecision arithmetic for square Mat
'Could be extended to include -1(xMatInv) 0(Idenity)
Dim a, i&, DgMx&, a3$(), n1&, m1&
Dim x1() As xNum, x2() As xNum, x3() As xNum
If n < 1 Then ErrRaise: Exit Function
If n = 1 Then xMatPow = mat: Exit Function
SetDgMx DgMx, Digit_Max
LoadMatrix a, n1, m1, mat
ConvMatIntoxNum a, x1, DgMx
#If CBool(VBA6 + VBA7) Then
x2 = x1
For i = 1 To n - 1
  xMATMULT_ n1, m1, m1, x1, x2, x3, DgMx
  x2 = x3
#Else
Dim j&, k&
ReDim x2(1 To n1, 1 To n1)
For j = 1 To n1: For k = 1 To n1: x2(j, k) = x1(j, k): Next k, j
For i = 1 To n - 1
  xMATMULT_ n1, m1, m1, x1, x2, x3, DgMx
  For j = 1 To n1: For k = 1 To n1: x2(j, k) = x3(j, k): Next k, j
#End If
Next
ConvxNumIntoMat a3, x2, Digit_Max
xMatPow = a3
End Function

Function xMDivS(mat, Scalar, Optional Digit_Max)
'divides a matrix by a scalar
Dim DgMx&, i&, j&, a, b$(), m&, n&, x() As xNum
SetDgMx DgMx, Digit_Max
LoadMatrix a, n, m, mat
ConvMatIntoxNum a, x, DgMx
Cvt2xNum tXN(0), Scalar, DgMx
For i = 1 To n: For j = 1 To m
  xDiv_ x(i, j), x(i, j), tXN(0), DgMx
Next j, i
ConvxNumIntoMat b, x, Digit_Max
PasteMatrix xMDivS, b, n, m
End Function

Function xMMultS(mat, Scalar, Optional Digit_Max)
Attribute xMMultS.VB_Description = "multiplies a scalar for a real matrix in multi-precision"
Attribute xMMultS.VB_HelpID = 520
Attribute xMMultS.VB_ProcData.VB_Invoke_Func = " \n14"
'multiplies a matrix by a scalar
Dim DgMx&, i&, j&, a, b$(), m&, n&, x() As xNum
SetDgMx DgMx, Digit_Max
LoadMatrix a, n, m, mat
ConvMatIntoxNum a, x, DgMx
Cvt2xNum tXN(0), Scalar, DgMx
For i = 1 To n: For j = 1 To m
  SxMult_ x(i, j), x(i, j), tXN(0), DgMx
Next j, i
ConvxNumIntoMat b, x, Digit_Max
PasteMatrix xMMultS, b, n, m
End Function

Function xProdScal(v1, v2, Optional Digit_Max)
Attribute xProdScal.VB_Description = "Multiprecision Scalar product of two vectors"
Attribute xProdScal.VB_HelpID = 90
Attribute xProdScal.VB_ProcData.VB_Invoke_Func = " \n14"
'Scalar product (inner) between two vectors
'with multiprecision arithemtic
'this version can be nested with ProdVect() 'thank to Robert Pigeon
'ver. 20-9-04 , (v1 and v2 can be also matrices)
Dim w1, w2, n1&, n2&, m1&, m2&
LoadMatrix w1, n1, m1, v1
LoadMatrix w2, n2, m2, v2
If n1 <> n2 Then ErrRaise: Exit Function
xProdScal = xMatMult(MatTI(w1), w2, Digit_Max)
End Function

Function xProdVect(v1, v2, Optional Digit_Max)
Attribute xProdVect.VB_Description = "Multiprecision vector product of two 3D vectors"
Attribute xProdVect.VB_HelpID = 116
Attribute xProdVect.VB_ProcData.VB_Invoke_Func = " \n14"
'return vector product (only 3 dimension) with multiprecision
'this version can be nested (thank to Robert Pigeon)
'ver. 27-6-02
Dim w1(), w2(), n1&, n2&, v$(1 To 3), DgMx&, w1_() As xNum, w2_() As xNum
LoadVector w1, v1, n1
LoadVector w2, v2, n2
If n1 <> n2 Or n1 <> 3 Then ErrRaise: Exit Function
SetDgMx DgMx, Digit_Max
ConvVectIntoxNum w1, w1_, DgMx
ConvVectIntoxNum w2, w2_, DgMx
xMult_ tXN(0), w2_(2), w1_(3), DgMx
xMult_ tXN(1), w1_(2), w2_(3), DgMx
xSub_ tXN(1), tXN(1), tXN(0), DgMx
v(1) = CvtxNum2str(tXN(1), Digit_Max)
xMult_ tXN(0), w1_(1), w2_(3), DgMx
xMult_ tXN(1), w1_(3), w2_(1), DgMx
xSub_ tXN(1), tXN(1), tXN(0), DgMx
v(2) = CvtxNum2str(tXN(1), Digit_Max)
xMult_ tXN(0), w2_(1), w1_(2), DgMx
xMult_ tXN(1), w1_(1), w2_(2), DgMx
xSub_ tXN(1), tXN(1), tXN(0), DgMx
v(3) = CvtxNum2str(tXN(1), Digit_Max)
xProdVect = PasteVector_(v)
End Function

Sub xMatDecomp_LU(a() As xNum, p&(), Pivot, DgMx&)
'-------------------------------------------------------------------
'Perform the LU decomposition with Crout's algorithm with partial pivot
'Pivot =True/False
' mod. 16-2-04 add permutation matrix
'--------------------------------------------------------------------
Dim n%, m As Integer
Dim i%, j%, iMax%, k As Integer
Dim big, Temp&, v1$
n = UBound(a, 1)
m = UBound(a, 2)
If n <> m Then Exit Sub
ReDim p&(1 To n) 'permutation vector
For i = 1 To n: p(i) = i: Next i
'start Crout's algorithm
For j = 1 To n
    For i = 1 To j - 1
        tXN(0) = a(i, j)
        For k = 1 To i - 1
          tXN(1) = a(k, j): tXN(1).Sign = Not tXN(1).Sign
          xMult_ tXN(1), a(i, k), tXN(1), DgMx
          xAdd_ tXN(0), tXN(0), tXN(1), DgMx
        Next k
        a(i, j) = tXN(0)
    Next i
    
    big = vbStr0
    For i = j To n
        tXN(0) = a(i, j)
        For k = 1 To j - 1
          tXN(1) = a(k, j): tXN(1).Sign = Not tXN(1).Sign
          xMult_ tXN(1), a(i, k), tXN(1), DgMx
          xAdd_ tXN(0), tXN(0), tXN(1), DgMx
        Next k
        a(i, j) = tXN(0)
        tXN(1) = tXN(0): tXN(1).Sign = False
        v1 = CvtxNum2str(tXN(1), DgMx)
        If xComp(v1, big) >= 1 Then
            big = v1
            iMax = i
        End If
    Next i
    
    If Pivot = True Then
      If j <> iMax Then
        For k = 1 To n
          tXN(1) = a(iMax, k): a(iMax, k) = a(j, k): a(j, k) = tXN(1)
        Next k
        Temp = p(j): p(j) = p(iMax): p(iMax) = Temp
      End If
    End If
    
    If j <> n And a(j, j).ndgt > 0 Then
        xDiv_ tXN(1), xSpougeX(-1), a(j, j), DgMx
        For i = j + 1 To n
          xMult_ a(i, j), tXN(1), a(i, j), DgMx
        Next i
    End If
Next j

End Sub

Function xMLU(mat, Optional Pivot, Optional Digit_Max): xMLU = xMatLU(mat, Pivot, Digit_Max): End Function
Attribute xMLU.VB_Description = "Perform the LU decomposition with Crout's algorithm.  A = L*U in multiprecision arithmetic"
Attribute xMLU.VB_HelpID = 115
Attribute xMLU.VB_ProcData.VB_Invoke_Func = " \n14"
Function xMatLU(mat, Optional Pivot, Optional Digit_Max)
Attribute xMatLU.VB_Description = "Perform the LU decomposition with Crout's algorithm.  A = L*U in multiprecision arithmetic"
Attribute xMatLU.VB_HelpID = 115
Attribute xMatLU.VB_ProcData.VB_Invoke_Func = " \n14"
'-------------------------------------------------------------------
'Perform the LU decomposition with Crout's algorithm
'   A = P*L*U
' mod. 16-2-04 add permutation matrix
'--------------------------------------------------------------------
Dim a, b$(), p&(), Perm() As Integer
Dim n&, m&, i&, j&, DgMx&
Dim xa() As xNum
If IsMissing(Pivot) Then Pivot = True
SetDigit_Max Digit_Max: DgMx = Digit_Max
LoadMatrix a, n, m, mat
If n <> m Then ErrRaise: Exit Function
Call ConvMatIntoxNum(a, xa, DgMx)
Call xMatDecomp_LU(xa, p, Pivot, DgMx)
m = 3 * n
ReDim b$(1 To n, 1 To m)
'stores L side and U side, and P
For i = 1 To n
  For j = 1 To n
    If j >= i Then
        b(i, n + j) = CvtxNum2str(xa(i, j), Digit_Max)
        b(i, j) = vbStr0
    Else
        b(i, n + j) = vbStr0
        b(i, j) = CvtxNum2str(xa(i, j), Digit_Max)
    End If
  Next j
  b(i, i) = vbStr1
Next i

'compute and return the permutaion matrix
ReDim Perm(1 To n, 1 To n)
For i = 1 To n
    If 1 <= p(i) And p(i) <= n Then Perm(p(i), i) = 1
Next i

For i = 1 To n: For j = 1 To n
    b(i, 2 * n + j) = Perm(i, j)
Next j, i
PasteMatrix xMatLU, b, n, m
End Function

Function xMCholesky(mat, Optional Digit_Max): xMCholesky = xMatLL(mat, Digit_Max): End Function
Attribute xMCholesky.VB_Description = "Perform the Cholesky's decomposition.  A = L*L^T in multiprecision arithmetic"
Attribute xMCholesky.VB_HelpID = 254
Attribute xMCholesky.VB_ProcData.VB_Invoke_Func = " \n14"
Function xMatLL(mat, Optional Digit_Max)
Attribute xMatLL.VB_Description = "Perform the Cholesky's decomposition.  A = L*L^T in multiprecision arithmetic"
Attribute xMatLL.VB_HelpID = 254
Attribute xMatLL.VB_ProcData.VB_Invoke_Func = " \n14"
'performs the Cholesky multiprecision decomposition A=L*L^t
Dim a1, a3$(), n&, m&, i&, j&, k&, DgMx&
Dim x1() As xNum, l() As xNum, s(1) As xNum
SetDgMx DgMx, Digit_Max
LoadMatrix a1, n, m, mat
If n <> m Then ErrRaise: Exit Function
ConvMatIntoxNum a1, x1, DgMx
DgMx = DgMx + 1

'begin Cholesky decomposition
ReDim l(1 To n, 1 To n)
For j = 1 To n
  s(0).ndgt = 0
  For k = 1 To j - 1
    xMult_ s(1), l(j, k), l(j, k), DgMx
    xAdd_ s(0), s(0), s(1), DgMx
  Next k
  xSub_ l(j, j), x1(j, j), s(0), DgMx
  
  If l(j, j).Sign Then Exit For 'the matrix can not be decomp
  xSqr_ l(j, j), l(j, j), DgMx
  For i = j + 1 To n
    s(0).ndgt = 0
    For k = 1 To j - 1
      xMult_ s(1), l(i, k), l(j, k), DgMx
      xAdd_ s(0), s(0), s(1), DgMx
    Next k
    xSub_ l(i, j), x1(i, j), s(0), DgMx
    xDiv_ l(i, j), l(i, j), l(j, j), DgMx
  Next i
Next j

ConvxNumIntoMat a3, l, Digit_Max
If n = 1 Then xMatLL = a3(1, 1) Else xMatLL = a3
End Function

Sub MatrixSort(a, Optional IndexCol, Optional Order, Optional CaseSensitive)
'==========================================
'SORT Routine with Swapping Algorithm
'A() may be matrix (N x M) or vector (N)
'Sort is based on the IndexCol column
'Order = A (default), D (Ascending, Descending)
'CaseSensitive = False, True (default)
'==========================================
Dim Flag_exchanged As Boolean
Dim i_min&, i_max&, j_min&, j_max&, i&, j&, k&, a1, a2, c
If IsMissing(IndexCol) Then IndexCol = 1
If IsMissing(CaseSensitive) Then CaseSensitive = True
If IsMissing(Order) Then Order = "A"
i_min = LBound(a, 1)
i_max = UBound(a, 1)
On Error GoTo Order_Vector
j_min = LBound(a, 2)
j_max = UBound(a, 2)
IndexCol = IndexCol - 1 + j_min
'Sort begin for Matrix
Do
    Flag_exchanged = False
    For i = i_min To i_max Step 2
        k = i + 1
        If k > i_max Then Exit For
        If CaseSensitive Then
            a1 = a(i, IndexCol)
            a2 = a(k, IndexCol)
        Else
            a1 = LCase$(a(i, IndexCol))
            a2 = LCase$(a(k, IndexCol))
        End If
        If (a1 > a2 And Order = "A") Or _
           (a1 < a2 And Order = "D") Then
            'swap rows
            For j = j_min To j_max
                c = a(k, j)
                a(k, j) = a(i, j)
                a(i, j) = c
            Next j
            Flag_exchanged = True
        End If
    Next
    If i_min = LBound(a, 1) Then
        i_min = LBound(a, 1) + 1
    Else
        i_min = LBound(a, 1)
    End If
Loop Until Flag_exchanged = False And i_min = LBound(a, 1)
Exit Sub

Order_Vector:
'Sort begin for Vector
On Error GoTo 0
Do
    Flag_exchanged = False
    For i = i_min To i_max Step 2
        k = i + 1
        If k > i_max Then Exit For
        If CaseSensitive Then
            a1 = a(i)
            a2 = a(k)
        Else
            a1 = LCase$(a(i))
            a2 = LCase$(a(k))
        End If
        If (a1 > a2 And Order = "A") Or _
           (a1 < a2 And Order = "D") Then
            'swap
                c = a(k)
                a(k) = a(i)
                a(i) = c
            Flag_exchanged = True
        End If
    Next
    If i_min = LBound(a) Then
        i_min = LBound(a) + 1
    Else
        i_min = LBound(a)
    End If
Loop Until Flag_exchanged = False And i_min = LBound(a)

End Sub

Sub MatCopy(a, b)
'Copy matrix A to B
' [A] --> [B]
Dim n0&, n1&, m0&, m1&, i&, j&
n0 = LBound(a, 1)
n1 = UBound(a, 1)
m0 = LBound(a, 2)
m1 = UBound(a, 2)
ReDim b(n0 To n1, m0 To m1)
For i = n0 To n1
For j = m0 To m1
    b(i, j) = a(i, j)
Next j
Next i
End Sub

Sub Copy_Convert_Mat(a, b)
' Skips the firt entry if array is dimensioned starting at 0
Dim n&, m&, i&, j&
If IsMatrix(a) Then
    n = UBound(a, 1)
    m = UBound(a, 2)
    ReDim b(1 To n, 1 To m)
    For i = 1 To n
    For j = 1 To m
        b(i, j) = a(i, j)
    Next j, i
Else
    n = UBound(a)
    ReDim b(1 To n)
    For i = 1 To n
        b(i) = a(i)
    Next i
End If
End Sub

Function xMT(mat): xMT = MatT(mat): End Function
Attribute xMT.VB_Description = "Matrix Transpose. (Mat) is a matrix n x m\nArray function transposes to m x n"
Attribute xMT.VB_HelpID = 89
Attribute xMT.VB_ProcData.VB_Invoke_Func = " \n14"
Function MatT(mat) 'Should use excel function TRANSPOSE, it works on strings and doubles
Attribute MatT.VB_Description = "Matrix Transpose. (Mat) is a matrix n x m\nArray function transposes to m x n"
Attribute MatT.VB_HelpID = 89
Attribute MatT.VB_ProcData.VB_Invoke_Func = " \n14"
Dim a, at, n&, m& 'No longer used internally, MatTI replaces it
LoadMatrix a, n, m, mat
Mat_Transp a, at
MatT = PasteVector_(at)
End Function

Function Flip(v)
Attribute Flip.VB_Description = "Returns a vector with inverse order\n[a1, a2, a3, a4] --> [a4, a3, a2, a1]"
Attribute Flip.VB_HelpID = 130
Attribute Flip.VB_ProcData.VB_Invoke_Func = " \n14"
'return a vector with inverse order
'mod. 8.12.05
Dim w, i&, n&, m&, j&, tmp
LoadMatrix w, n, m, v
If n > 1 Then
    'tabella o vettore verticale
    For j = 1 To m
    For i = 1 To Int(n / 2)
        tmp = w(i, j)
        w(i, j) = w(n - i + 1, j)
        w(n - i + 1, j) = tmp
    Next i, j
Else
    'vettore orizzontale
    For j = 1 To Int(m / 2)
        tmp = w(1, j)
        w(1, j) = w(1, m - j + 1)
        w(1, m - j + 1) = tmp
    Next j
End If
Flip = PasteVector_(w)
End Function

Function xMExp(mat, Optional n, Optional Tiny, Optional Digit_Max)
Attribute xMExp.VB_Description = "returns the matrix series expansion for exp(Mat) in multi-precision"
Attribute xMExp.VB_HelpID = 513
Attribute xMExp.VB_ProcData.VB_Invoke_Func = " \n14"
'returns the matrix series expansion for exp(Mat)
'exp(A)= I + A + 1/2*A^2 +1/6*A^3 +...1/n!*A^n + error
Dim a, b$(), b1, c, DgMx&, i&, j&, k&, m&, n1&
Dim Flag_End_Loop As Boolean
SetDgMx DgMx, Digit_Max
If IsMissing(Tiny) Then Tiny = "1E-" & Digit_Max
LoadMatrix a, n1, m, mat
If m <> n1 Then ErrRaise , "xMExp: Invalid matrix size.": Exit Function
'series expansion begins
#If CBool(VBA6 + VBA7) Then
  b = a
#Else
  MatString a, b, n1, m
#End If
M_ID c, m
c = xMatAdd(c, a, DgMx) 'C=I+A
k = 1 'For k = 2 To n
GoSub Check_End_Loop
Do Until Flag_End_Loop
    k = k + 1
    b1 = xMatMult(b, a, DgMx)
    For i = 1 To m: For j = 1 To m
      b(i, j) = xDivR(b1(i, j), k, DgMx) 'B= 1/k*B*A
    Next j, i
    c = xMatAdd(c, b, DgMx)
    GoSub Check_End_Loop
Loop
For i = 1 To m: For j = 1 To m
  b(i, j) = xFmtStr(c(i, j), Digit_Max)
Next j, i
xMExp = b
Exit Function
'-----------------------------
Check_End_Loop:
If IsMissing(n) Then
    Flag_End_Loop = xComp(xMatAbs(b, DgMx), Tiny) < 0
Else
    Flag_End_Loop = (k >= n)
End If
Return

End Function

Function xMExpErr(mat, n, Optional Digit_Max)
Attribute xMExpErr.VB_Description = "returns the truncation error of matrix series expansion for exp(Mat) in multi-precision"
Attribute xMExpErr.VB_HelpID = 517
Attribute xMExpErr.VB_ProcData.VB_Invoke_Func = " \n14"
'returns the truncation error of matrix series expansion for exp(Mat)
'exp(A)= I + A + 1/2*A^2 +1/6*A^3 +...1/n!*A^n + error
Dim a, b, b1, DgMx&, i&, j&, k&, m&, n1&
SetDgMx DgMx, Digit_Max
LoadMatrix a, n1, m, mat
If m <> n1 Then ErrRaise , "xMExpErr: Invalid matrix size.": Exit Function
'series expansion begins
b = a
For k = 2 To n
    b1 = xMatMult(b, a, DgMx)
    For i = 1 To m: For j = 1 To m
      b(i, j) = xDivR(b1(i, j), k, DgMx) 'B= 1/k*B*A
    Next j, i
Next
xMExpErr = xMatAbs(b, Digit_Max)
End Function

Function xMNormalize(mat, Optional NormType, Optional Tiny, Optional Digit_Max)
Attribute xMNormalize.VB_Description = "Multi-precision normalized vectors of the matrix of real numbers\nNormType = 1 (scaled to min) ,  2 (modulo=1),  3 (scaled to max)\n4 (mean of abs values), 5 (mean=0 and standard deviation=1)"
Attribute xMNormalize.VB_HelpID = 521
Attribute xMNormalize.VB_ProcData.VB_Invoke_Func = " \n14"
'NormType = 1 (scaled to Min abs element),
'NormType = 2 (scaled to Module =1)
'NormType = 3 (scaled to Max abs element )
'NormType = 4 (scaled to Mean abs elements )
'NormType = 5 (normalized mean = 0 and stdev = 1)
Dim a, n1&, m&, b$()
LoadMatrix a, n1, m, mat
If IsMissing(NormType) Then NormType = 2
xNormalizeMatrix a, b, NormType, Tiny, Digit_Max
xMNormalize = b
End Function

Private Sub xNormalizeMatrix(a, b$(), NormType, Optional Tiny, Optional Digit_Max)
'NormType = 1 (scaled to absolute max)
'2 (module=1)
'3 (scaled to absolute min)
'4 (scaled to absolute mean)
'5 (normalized mean = 0 and stdev = 1)
'mod. 11-1-2007
Dim DgMx&, n&, m&, tmp$, s1$, i&, j&
SetDgMx DgMx, Digit_Max
If IsMissing(Tiny) Then Tiny = 0 '2 * Ten_14
n = UBound(a, 1)
m = UBound(a, 2)
ReDim b$(1 To n, 1 To m)
'mop-up
If xCompZ(Tiny) > 0 Then
  For j = 1 To m
  For i = 1 To n
      If xComp(xAbs(a(i, j)), Tiny) < 0 Then a(i, j) = 0
  Next i, j
End If
'normalize
For j = 1 To m
    Select Case NormType
        Case 2  'module =1
            s1 = 0 '
            For i = 1 To n
              s1 = xAddR(s1, xMultSq(dCStr_(a(i, j)), DgMx), DgMx)
            Next i
            s1 = xSqr(s1, DgMx)
        Case 3  'max of |vi|  =1
            s1 = 0
            For i = 1 To n
              If xComp(xAbs(a(i, j)), xAbs(s1)) > 0 Then s1 = a(i, j)
            Next i
        Case 1  'min of |vi|  =1
            s1 = "1E2147483647"
            For i = 1 To n
              If xCompZ(a(i, j)) <> 0 Then
                If xComp(xAbs(a(i, j)), xAbs(s1)) < 0 Then s1 = a(i, j)
              End If
            Next i
        Case 4  'mean of |vi| element =1
            s1 = 0
            For i = 1 To n
                s1 = xAddR(s1, xAbs(a(i, j)), DgMx)
            Next i
            s1 = xDivR(s1, n, DgMx)
        Case 5  'z=(x-m)/s
            tmp = mat_avg_col(a, j, DgMx)
            s1 = mat_stdev_col(a, j, tmp, DgMx)
            For i = 1 To n
                a(i, j) = xSubR(a(i, j), tmp, DgMx)
            Next i
        End Select
    If xComp(xAbs(s1), Tiny) > 0 Then  'fix bug for null vectors . 6-6-05 VL
        For i = 1 To n
            b(i, j) = xDiv(a(i, j), s1, Digit_Max)
        Next i
    Else
        For i = 1 To n
            b(i, j) = xFmtStr(a(i, j), Digit_Max)
        Next i
    End If
Next j
End Sub

Private Function mat_avg_col(a, j&, DgMx&) As String
Dim k&, s$
For k = LBound(a, 1) To UBound(a, 1)
    s = xAddR(s, a(k, j), DgMx)
Next
mat_avg_col = xDivR(s, UBound(a, 1) - LBound(a, 1) + 1, DgMx)
End Function

Private Function mat_stdev_col(a, j&, MU$, DgMx&) As String
Dim k&, s$
For k = LBound(a, 1) To UBound(a, 1)
  s = xAddR(s, xMultSq(xSubR(a(k, j), MU, DgMx), DgMx), DgMx)
Next
mat_stdev_col = xSqr(xDivR(s, UBound(a, 1) - LBound(a, 1), DgMx), DgMx)
End Function

Function xMChar(mat, x, Optional Digit_Max)
'returns the characteristic matrix A-sI
Dim a, n&, m&, i&
LoadMatrix a, n, m, mat
For i = 1 To min_(n, m)
  a(i, i) = xSub(a(i, i), x, Digit_Max)
Next i
xMChar = a
End Function

Function xMCharPoly(mat, Optional Variable, Optional Digit_Max)
Attribute xMCharPoly.VB_Description = "returns the coefficients of the characteristic polynomial"
Attribute xMCharPoly.VB_HelpID = 99
Attribute xMCharPoly.VB_ProcData.VB_Invoke_Func = " \n14"
'returnes the coefficients of the characteristic polynomial
'of the square matrix "Mat" by the Newton-Girard formulas
'p(x)=an*x^n +...a1*x + a0
Dim a, coeff$(), n&, m&
Dim DgMx&, s$(), b, k&, i&, p$
LoadMatrix a, n, m, mat
If n <> m Then ErrRaise , "xMCharPoly: Invalid matrix size.": Exit Function
SetDgMx DgMx, Digit_Max
ReDim s(1 To n), coeff(0 To n)
coeff(n) = (-1) ^ n
b = a ' [A] --> [B]
For k = 1 To n
    For i = 1 To n
        s(k) = xAddR(s(k), b(i, i), DgMx)  'trace of [A]^k
    Next
    p = 0
    For i = 0 To k - 1
        p = xAddR(p, xMultR(coeff(n - i), s(k - i), DgMx), DgMx)
    Next
    coeff(n - k) = xDivR(xNegR(p), k, DgMx)
    If k < n Then b = xMatMult(b, a, DgMx)      '[B]=[B]*[A]
Next k
For k = 0 To n - 1
  coeff(k) = xFmtStr(coeff(k), Digit_Max)
Next
If ChkArrayRet Then
  xMCharPoly = PasteVector_(coeff)
Else
  If IsMissing(Variable) Then Variable = "x"
  WritePolyString coeff, xMCharPoly, Variable
End If
End Function

Function xSysLinIterG(mat, U, Optional x0, Optional nMax, Optional w, Optional Digit_Max)
Attribute xSysLinIterG.VB_Description = "Solve Linear System Mat*x = U (Gauss-Seidel iterative method) in multiprecision arithmetic"
Attribute xSysLinIterG.VB_HelpID = 94
Attribute xSysLinIterG.VB_ProcData.VB_Invoke_Func = " \n14"
'resolve a linear system with Gauss-Seidel iterative method
'[Mat]x=U
' Mat = square matrix (n x n)
' U = vector  (n x 1)
' x0 = vector starting point. may be vertical or horizonthal vectors, default 0's
' w relaxation parameter 0 < w < 2, default = 1
' Nmax = iterations step max, default = 1
Dim a, b, x, m&, n&, i&, Converg As Boolean, DgMx&, j&, s$, px$()
If IsMissing(w) Then w = 1
InitSysLinIter mat, U, x0, nMax, Digit_Max, DgMx, s, px, n, a, b, x, i, m
If s <> vbNullString Then xSysLinIterG = s: Exit Function
For i = 1 To n
  s = dCStr_(a(i, i))
  b(i) = xDivR(b(i), s, DgMx)
  For j = 1 To n: a(i, j) = xDivR(a(i, j), s, DgMx): Next
  px(i) = xFmtStr(dCStr_(x(i)), Digit_Max)
Next
For m = 1 To nMax
  Converg = True
  For i = 1 To n
    s = xMultR(a(i, 1), x(1), DgMx)
    For j = 2 To n
      s = xAddR(s, xMultR(a(i, j), x(j), DgMx), DgMx)
    Next j
    s = xMultR(w, xSubR(b(i), s, DgMx), DgMx)
    x(i) = xAddR(x(i), s, DgMx)
    s = xFmtStr(x(i), Digit_Max)
    If s <> px(i) Then px(i) = s: Converg = False
  Next i
  If Converg Then xSysLinIterG = PasteVector_(px): Exit Function
Next
For i = 1 To n: x(i) = xFmtStr(x(i), DIGITS_LIMIT): Next
xSysLinIterG = PasteVector_(x)
End Function

Private Sub InitSysLinIter(mat, U, x0, nMax, Digit_Max, DgMx&, s$, px$(), n&, a, b, x, i&, m&)
If IsMissing(nMax) Then nMax = 1
LoadMatrix a, n, m, mat
If m <> n Then
ErrExit: s = "Wrong Dimension": Exit Sub
End If
LoadVector b, U, m
If m <> n Then GoTo ErrExit
If IsMissing(x0) Then
  ReDim x(1 To n)
  For i = 1 To n: x(i) = 0: Next
Else
  LoadVector x, x0, m
  If m <> n Then GoTo ErrExit
End If
SetDgMx DgMx, Digit_Max
ReDim px$(1 To n)
End Sub

Function xSysLinIterJ(mat, U, Optional x0, Optional nMax, Optional Digit_Max)
Attribute xSysLinIterJ.VB_Description = "Solve Linear System Mat*x = U (Jacobi iterative method) in multiprecision arithmetic"
Attribute xSysLinIterJ.VB_HelpID = 94
Attribute xSysLinIterJ.VB_ProcData.VB_Invoke_Func = " \n14"
'resolve a linear system with Jacobi iterative method
'[Mat]x=U
' Mat = square matrix (n x n)
' U = vector  (n x 1)
' x0 = vector starting point. may be vertical or horizonthal vectors, default 0's
' Nmax = iterations step max, default = 1
Dim a, b, x, m&, n&, i&, Converg As Boolean, DgMx&, j&, s$, px$(), ix$()
InitSysLinIter mat, U, x0, nMax, Digit_Max, DgMx, s, px, n, a, b, x, i, m
If s <> vbNullString Then xSysLinIterJ = s: Exit Function
ReDim ix$(1 To n)
For i = 1 To n
  px(i) = xFmtStr(dCStr_(x(i)), Digit_Max)
Next
For m = 1 To nMax
  Converg = True
  For i = 1 To n: ix(i) = x(i): Next
  For i = 1 To n
    s = dCStr_(b(i))
    For j = 1 To n
      If i <> j Then s = xSubR(s, xMultR(a(i, j), ix(j), DgMx), DgMx)
    Next j
    x(i) = xDivR(s, a(i, i), DgMx)
    s = xFmtStr(x(i), Digit_Max)
    If s <> px(i) Then px(i) = s: Converg = False
  Next i
  If Converg Then xSysLinIterJ = PasteVector_(px): Exit Function
Next
For i = 1 To n: x(i) = xFmtStr(x(i), DIGITS_LIMIT): Next
xSysLinIterJ = PasteVector_(x)
End Function
VBA Filename frmPrime.frm Extracted Macro

'Option Explicit
Dim PN(), N_start, PNmax, nMax, HigPN, LastRow, LastColumn, CountN, CountI, ElapsTime
Dim flag_stop, Counter1, MaxRow

Private Sub Primi()
Dim OrigCalcStatus As Integer
On Error Resume Next
OrigCalcStatus = Application.Calculation
Application.Calculation = xlCalculationManual
MaxRow = Me.TextBox_rowmax
If PNmax <= 3 Then
    LastRow = 3: LastColumn = 1
    ReDim PN(1 To nMax)
    PN(1) = 1: PN(2) = 2: PN(3) = 3
    PNmax = 3: CountI = 3
    Cells(1, 1) = 1
    Cells(2, 1) = 2
    Cells(3, 1) = 3
End If
N_start = PN(PNmax) + 2
dim_max = nMax + PNmax - CountI
If UBound(PN) < dim_max Then
    ReDim Preserve PN(1 To dim_max)
End If
r = LastRow
c = LastColumn
t0 = Timer
n = N_start
Counter1 = CountI
j0 = 2: j1 = j0
res0 = 0: res1 = res0
i = 1
Do Until i > (nMax - CountI) Or flag_stop = 1
    flag = 0
    n_sqr = Sqr(n)  'mod 9-8-2002  VL
    For j = 2 To i - 1 + PNmax
        q = n / PN(j): res = q - Int(q)
        If res = 0 Then flag = 1: Exit For 'non \xe8 primo
        If PN(j) > n_sqr Then Exit For  'mod 9-8-2002  VL
    Next
        
    If flag = 0 Then
        PN(i + PNmax) = n
        HigPN = n:  r = r + 1
        If r > MaxRow Then
            r = 1: c = c + 1
        End If
        Cells(r, c) = PN(i + PNmax)
        i = i + 1
        Counter1 = Counter1 + 1
    End If
    n = n + 2
    If i Mod 20 = 0 Then
        ElapsTime = Timer - t0
        UpdateLabel
        DoEvents
    End If
Loop
'-----------------------------
PNmax = PNmax + i - 1
CountI = i - 1 + CountI
LastRow = r
LastColumn = c
ElapsTime = Timer - t0
Application.Calculation = OrigCalcStatus
End Sub

Private Sub LoadPrime1(p, nMax, LastRow, LastColumn)
'load all primes from worksheet columns
On Error GoTo Error_Handler
R0 = 1: C0 = 1
R1 = R0 + Range("A1").CurrentRegion.Rows.Count - 1
c1 = C0 + Range("A1").CurrentRegion.Columns.Count - 1
tmp = Range(Cells(R0, C0), Cells(R1, c1))
If Not IsArray(tmp) Then
    nMax = 0: Exit Sub
End If
LastRow = R1: LastColumn = C0
m = UBound(tmp, 2)
n = UBound(tmp, 1)
nMax = n * m
ReDim p(1 To nMax)
k = 0
For j = 1 To m
For i = 1 To n
    If Len(tmp(i, j)) = 0 Then
        nMax = k
        ReDim Preserve p(1 To nMax)
        Exit Sub
    End If
    k = k + 1
    p(k) = tmp(i, j)
    HigPN = p(k)
Next i
Next j
Exit Sub

Error_Handler:
nMax = 0
End Sub


Private Sub CommandButton_off_Click()
    If flag_stop = 0 Then flag_stop = 1
End Sub

Private Sub CommandButton_on_Click()
If Me.TextBox_Nmax < 1 Then Exit Sub
With Me
    .CommandButton_on.Enabled = False
    .CommandButton_off.Enabled = True
    If flag_stop = 1 Then flag_stop = 0
    nMax = CDbl(.TextBox_Nmax)
    .Label_msg = "Generating prime numbers. Wait..."
End With
        DoEvents
        If CountI = nMax Then CountI = 0 'reset counter
        Call Primi
        UpdateLabel
With Me
    .CommandButton_on.Enabled = True
    .CommandButton_off.Enabled = False
    If flag_stop = 0 Then flag_stop = 1
    .Label_msg = str$(nMax) & " new prime numbers found in" & Left$(str$(ElapsTime), 5) & " sec"
End With
    
End Sub

Private Sub CommandButton1_Click()
Application.Help XHelpFile, 78
End Sub

Private Sub UserForm_Activate()
    Me.Label_comp_perc = "0%"
    Me.TextBox_Nmax = 10000
    Me.TextBox_rowmax = Columns("A").Cells.Count
    Me.Label_msg = "Loading previous prime numbers. Wait..."
    Me.CommandButton_on.Enabled = False
    flag_stop = 0
    DoEvents
    
    LoadPrime1 PN, PNmax, LastRow, LastColumn
    'If PNmax = 0 Then ReDim PN(1 To 1)
    
    Me.Label_Prime_max = HigPN
    Me.Label_msg = "..."
    Me.Label9 = "Elapsed Time"
    Me.CommandButton_on.Enabled = True
    If flag_stop = 0 Then flag_stop = 1
End Sub

Sub UpdateLabel()
    With Me
        .Label_computed = Counter1
        x = Int(CDbl(Counter1 / nMax * 100))
        .Label_comp_perc = str$(x) & " %"
        .Label_Prime_max = HigPN
        .Label_time = TimeSerial(0, 0, ElapsTime)
    End With
End Sub
VBA Filename frmIntegrInf.frm Extracted Macro

Option Explicit
Public UserChoice As Long
Public Layout As Long
Public Method As Long
Dim R0, C0

Private Sub CommandButton_help_Click()
Application.Help XHelpFile, 184
End Sub

Private Sub CommandButton_run_Click()
UserChoice = 1
If Len(Me.RefEdit_Fxy) = 0 Then
    MsgBox "function missing", vbExclamation
    Me.RefEdit_Fxy.SetFocus
    Exit Sub
End If

'choose a method
If Me.OptionButton1 Then Method = 1
If Me.OptionButton2 Then Method = 2

If Len(Me.RefEdit_Out) = 0 Then Set_Default_Output_Cell
Unload Me
End Sub

Private Sub UserForm_Activate()
If Not ActiveCell Is Nothing Then
  If Not IsEmpty(ActiveCell) Then
    Me.RefEdit_Fxy = ActiveCell.Address
    Set_output_range
  End If
End If
End Sub

Private Sub UserForm_Initialize()
'nothing to do
End Sub

Private Sub Set_output_range()
Dim myRange As Range, s$
Set myRange = Range(Me.RefEdit_Fxy)
R0 = myRange.Row
C0 = myRange.Column
If Not IsEmpty(Cells(R0, C0 + 1)) Then 'guess layout horizontal
  Layout = 0
  Me.RefEdit_Xmin = Cells(R0, C0 + 1).Address
  If IsEmpty(Cells(R0, C0 + 2)) Then GoTo SetOutCell
  Me.RefEdit_Xmax = Cells(R0, C0 + 2).Address
  If Not IsEmpty(Cells(R0, C0 + 3)) Then If R0 <> 1 Then _
    If Not IsEmpty(Cells(R0 - 1, C0 + 3)) Then _
      Param_Address_Right R0 - 1, C0 + 3, s: Me.RefEdit_Param = s
ElseIf Not IsEmpty(Cells(R0 + 1, C0)) Then
  Layout = 1
  Me.RefEdit_Xmin = Cells(R0 + 1, C0).Address
  If IsEmpty(Cells(R0 + 2, C0)) Then GoTo SetOutCell
  Me.RefEdit_Xmax = Cells(R0 + 2, C0).Address
  If Not IsEmpty(Cells(R0 + 3, C0)) Then If C0 <> 1 Then _
    If Not IsEmpty(Cells(R0 + 3, C0 - 1)) Then _
      Param_Address_Down R0 + 3, C0 - 1, s: Me.RefEdit_Param = s
End If
SetOutCell: Set_Default_Output_Cell
End Sub

Sub Set_Default_Output_Cell()
    If Layout = 1 Then
        Me.RefEdit_Out = Cells(R0, C0 + 2).Address
    Else
        Me.RefEdit_Out = Cells(R0 + 2, C0).Address
    End If
End Sub
VBA Filename Integr_multidim.bas Extracted Macro
Option Explicit

Sub Integral_2D_N(Funct, Limit_min(), Limit_max(), results(), Rank, Accuracy, ErrMsg$, ErrMsgEval$, _
  Polar As Boolean, Optional Param, Optional Var_Labels)
'=============================================================================================
'INTEGRATION routine for bidimensional functions f(x, y) in normal domains
'Method used is 2D-Romberg algorithm
'Input:
'Funct = f(x, y) integration function
'Limit_min(1) <= x <= Limit_max(1)
'Limit_min(2) <= y <= Limit_max(2)
'Rank sets the max iterations for Romberg method; the points used are about 4^Rank
'Accuracy sets the relative error default= 10 ^ -11
'Polar default=FALSE
'Param = 1 or more parameters for all equations
'Var_Labels default is "x","y"
'Output:
'Results(1) = Approximated integral
'Results(2) = Estimated error
'Results(3) = Counter of points evaluated
'ErrMsg returns any error detected
'v. 2.0 by Leonardo Volpi, Foxes Team, 20-4-2006
'=============================================================================================

Dim P_max#(1 To 2), P_min#(1 To 2), n&, h#(1 To 2), p#(1 To 2), i1%, i2%, tmp#
Dim i&, j&, k&, Grid#(), r#(), LoopError#, VarMaxFun%, tmp1#, tmp2#
Dim OK As Boolean, ErrRel#, FunVal#, int0, y1, y2, VarSym$()
Dim VarID%(1 To 2), IntOrd%(1 To 2), VarMax%(1 To 3, 1 To 2), ParMax%
Dim par() As Parametro, VarMinId%(1 To 2, 1 To 2), VarMaxId%(1 To 2, 1 To 2)

ReDim results(1 To 3)
If VarType(Funct) < vbInteger Then ErrMsg = "Invalid Null": Exit Sub
ErrMsg = vbNullString 'initialize return message variable
'parse and syntax check of f(x,y) -----------------
Dim Fun As xclsMathParser
Set Fun = New xclsMathParser
OK = Fun.StoreExpression(Funct)
If Not OK Then ErrMsg = Fun.Expression & " : " & Fun.ErrorDescription: Exit Sub

'parse and syntax check of bound function -----------------
Dim fmin(1 To 2) As New xclsMathParser
Dim fmax(1 To 2) As New xclsMathParser
For i = 1 To 2
    OK = fmin(i).StoreExpression(Limit_min(i))
    If Not OK Then ErrMsg = fmin(i).Expression & " : " & fmin(i).ErrorDescription: Exit Sub
    OK = fmax(i).StoreExpression(Limit_max(i))
    If Not OK Then ErrMsg = fmax(i).Expression & " : " & fmax(i).ErrorDescription: Exit Sub
Next i

'extract parameters
If Not IsMissing(Param) Then
    Parameter_Add Param, par
    ParMax = UBound(par)
End If

'---  Check and build the variables Index
If Fun.VarTop - ParMax > 2 Then
    ErrMsg = "too many variables in " & Fun.Expression
    Exit Sub
End If

'Check and build the variables Index
If IsMissing(Var_Labels) Then
  ReDim VarSym(1 To 2)
  VarSym(1) = "x": VarSym(2) = "y"
ElseIf IsArray(Var_Labels) Then
  LoadVector VarSym, Var_Labels, n
  If n > 2 Then ErrMsg = "Must have 1 or 2 Var_Labels if present": Exit Sub
Else
  ReDim VarSym(1 To 2)
  VarSym(1) = Var_Labels: VarSym(2) = "y"
End If
'find the Integration variables and substitute parameters values (if any)
For k = 1 To 2
    VariablesIndex fmin(k), VarID, VarSym, par, Param, VarMax(1, k)
    For j = 1 To 2: VarMinId(k, j) = VarID(j): Next
    VariablesIndex fmax(k), VarID, VarSym, par, Param, VarMax(2, k)
    For j = 1 To 2: VarMaxId(k, j) = VarID(j): Next
    VarMax(3, k) = max_(VarMax(1, k), VarMax(2, k))
    IntOrd(k) = k
Next
VariablesIndex Fun, VarID, VarSym, par, Param, VarMaxFun
If VarMaxFun = 0 Then FunVal = Fun.Eval

'check if the domain is normal to a specific axes and build the integration order
If VarMax(3, IntOrd(1)) > VarMax(3, IntOrd(2)) Then
    tmp = IntOrd(1)
    IntOrd(1) = IntOrd(2) 'Swap
    IntOrd(2) = tmp
End If
If VarMax(3, IntOrd(1)) > 0 Then ErrMsg = "Normal domain not found for any axes": Exit Sub

For i = 1 To 2
    If VarMax(3, IntOrd(i)) >= i Then ErrMsg = "Bounding error": Exit Sub
Next
'calculate the initial box -----------
i1 = IntOrd(1)
i2 = IntOrd(2)
P_min(i1) = fmin(i1).Eval
P_max(i1) = fmax(i1).Eval
If VarMax(1, i2) <> 0 Then
  If VarMinId(i2, 1) > 1 Then
    fmin(i2).VarValue(VarMinId(i2, 1)) = P_min(i1)
    P_min(i2) = fmin(i2).Eval
    fmin(i2).VarValue(VarMinId(i2, 1)) = P_max(i1)
    tmp = fmin(i2).Eval
  Else
    P_min(i2) = fmin(i2).Eval1(P_min(i1))
    tmp = fmin(i2).Eval1(P_max(i1))
  End If
Else
  P_min(i2) = fmin(i2).Eval
  tmp = P_min(i2)
End If
If VarMax(2, i2) <> 0 Then
  If VarMaxId(i2, 1) > 1 Then
    fmax(i2).VarValue(VarMaxId(i2, 1)) = P_min(i1)
    tmp1 = fmax(i2).Eval
    fmax(i2).VarValue(VarMaxId(i2, 1)) = P_max(i1)
    tmp2 = fmax(i2).Eval
  Else
    tmp1 = fmax(i2).Eval1(P_min(i1))
    tmp2 = fmax(i2).Eval1(P_max(i1))
  End If
Else
    tmp1 = fmax(i2).Eval
    tmp2 = tmp1
End If
P_max(i2) = max4(P_min(i2), tmp, tmp1, tmp2)
P_min(i2) = min4(P_min(i2), tmp, tmp1, tmp2)
'-------------------------------------
k = 0
n = 2 ^ k
For i = 1 To 2
    h(i) = (P_max(i) - P_min(i)) / n
Next
If VarMax(1, i2) = 0 Then P_min(i2) = tmp
If VarMax(2, i2) = 0 Then P_max(i2) = tmp1

ReDim r(1 To Rank, 1 To Rank)
LoopError = 1#
ErrRel = Accuracy  'set relative error limit
Do Until k >= Rank Or LoopError <= ErrRel
    k = k + 1
    'build the mesh
    ReDim Grid(n, n, 1 To 3)
    For i = 0 To n
        p(i1) = P_min(i1) + h(i1) * i
        If VarMax(1, i2) <> 0 Then
          If VarMinId(i2, 1) > 1 Then
            fmin(i2).VarValue(VarMinId(i2, 1)) = p(i1)
            P_min(i2) = fmin(i2).Eval
          Else
            P_min(i2) = fmin(i2).Eval1(p(i1))
          End If
        End If
        If VarMax(2, i2) <> 0 Then
          If VarMaxId(i2, 1) > 1 Then
            fmax(i2).VarValue(VarMaxId(i2, 1)) = p(i1)
            P_max(i2) = fmax(i2).Eval
          Else
            P_max(i2) = fmax(i2).Eval1(p(i1))
          End If
        End If
        If Err Then GoTo Error_Handler
        h(i2) = (P_max(i2) - P_min(i2)) / n
        For j = 0 To n
            p(i2) = P_min(i2) + h(i2) * j
            Grid(i, j, 1) = p(1)
            Grid(i, j, 2) = p(2)
            Select Case VarMaxFun
              Case 0: Grid(i, j, 3) = FunVal: GoTo SkipCalc
              Case 1:
                If Polar Then
                  If VarID(1) <> 0 Then Fun.VarValue(VarID(1)) = p(1) * Cos(p(2)) Else _
                    Fun.VarValue(VarID(2)) = p(1) * Sin(p(2))
                Else
                  If VarID(1) <> 0 Then Fun.VarValue(VarID(1)) = p(1) Else _
                    Fun.VarValue(VarID(2)) = p(2)
                End If
              Case Else:
                If Polar Then
                  Fun.VarValue(VarID(1)) = p(1) * Cos(p(2))
                  Fun.VarValue(VarID(2)) = p(1) * Sin(p(2))
                Else
                  Fun.VarValue(VarID(1)) = p(1)
                  Fun.VarValue(VarID(2)) = p(2)
                End If
            End Select
            Grid(i, j, 3) = Fun.Eval: If Err Then ErrMsg = "Evaluation error": ErrMsgEval = Fun.Expression & " : " & Fun.ErrorDescription
SkipCalc:   If Polar Then Grid(i, j, 3) = Grid(i, j, 3) * p(1)
        Next j
    Next i
    'integral computing with 2D-trapezoidal formula
    int0 = 0
    For i = 0 To n - 1
      For j = 0 To n - 1
        int0 = int0 + Integr_4Points(i, j, Grid)
      Next j
    Next i
    r(k, 1) = int0
    n = 2 * n
    For i = 1 To 2
        h(i) = h(i) / 2
    Next
    'Richardson's extrapolation
    For j = 2 To k
        y1 = r(k - 1, j - 1)
        y2 = r(k, j - 1)
        r(k, j) = y2 + (y2 - y1) / (4 ^ (j - 1) - 1)
    Next j
    'error loop evaluation
    If k > 1 Then
        LoopError = Abs((r(k, k) - r(k, k - 1)))
        If Abs(r(k, k)) > 1 Then LoopError = LoopError / Abs(r(k, k))
    End If
Loop
results(1) = r(k, k)  'approximated integral
If i2 = 1 Then results(1) = -results(1) 'change sign for Y-Domain
results(2) = LoopError  'estimate error
results(3) = (n + 1) * (n + 1) * k 'points evaluated
Exit Sub
Error_Handler:
ErrMsg = "Wrong domain bound"
End Sub

Private Function Integr_4Points(i&, j&, Mesh#())
Dim i2&, j2&, tmp1#, tmp2#
i2 = i + 1
j2 = j + 1
tmp1 = (Mesh(i2, j, 1) - Mesh(i, j, 1)) * (Mesh(i2, j2, 2) - Mesh(i2, j, 2)) - (Mesh(i2, j2, 1) - Mesh(i2, j, 1)) * (Mesh(i2, j, 2) - Mesh(i, j, 2))
tmp2 = (Mesh(i, j2, 1) - Mesh(i2, j2, 1)) * (Mesh(i, j, 2) - Mesh(i, j2, 2)) - (Mesh(i, j, 1) - Mesh(i, j2, 1)) * (Mesh(i, j2, 2) - Mesh(i2, j2, 2))
Integr_4Points = (tmp1 * (Mesh(i, j, 3) + Mesh(i2, j, 3) + Mesh(i2, j2, 3)) + tmp2 * (Mesh(i, j, 3) + Mesh(i, j2, 3) + Mesh(i2, j2, 3))) / 6
End Function

Function Integr_2D(Fxy, xMin, xMax, yMin, yMax, Optional Param, Optional Polar, Optional ErrMax, Optional Var_Labels, Optional Rank)
Attribute Integr_2D.VB_Description = "Approximates the double integral of a function f(x, y) for a <= x <= b and\nc <= y <= d  using the 2D Romberg method. Param used by all equations.\nDefaults are Polar=FALSE, Rank=8, ErrMax=1E-11, Var_Labels=''x'',''y''"
Attribute Integr_2D.VB_HelpID = 183
Attribute Integr_2D.VB_ProcData.VB_Invoke_Func = " \n14"
'MpMath quad(lambda x,y:Fxy,[xMin, xMax],[yMin, yMax])
Dim Bound_min(1 To 2), Bound_max(1 To 2), results(), ErrMsg$, CoorPolar As Boolean, ErrMsgEval$
Dim U(1 To 4)

'setting default
If IsMissing(Rank) Then Rank = 8 '65.000 points max
Const Tiny# = 10 ^ -11
If IsMissing(ErrMax) Then ErrMax = Tiny
If IsMissing(Polar) Then Polar = False
CoorPolar = Polar

Bound_min(1) = xMin: Bound_max(1) = xMax
Bound_min(2) = yMin: Bound_max(2) = yMax

Integral_2D_N Fxy, Bound_min, Bound_max, results, Rank, ErrMax, ErrMsg, ErrMsgEval, CoorPolar, Param, Var_Labels

'load vector for output
If Len(ErrMsg) = 0 Then
    U(1) = results(1)   'integral
    U(2) = results(2)   'relative error
    U(3) = results(3)   'points
    U(4) = vbNullString 'error message
ElseIf ErrMsg = "Evaluation error" Then
    U(1) = results(1)   'integral
    U(2) = results(2)   'relative error
    U(3) = results(3)   'points
    U(4) = "Singularity: dubious accuracy -- " & ErrMsgEval
Else
    U(1) = ErrMsg
End If
Integr_2D = PasteVector_(U)
End Function

Function Integr_3D(Fxyz, xMin, xMax, yMin, yMax, zMin, zMax, Optional Param, Optional SysCoor, Optional ErrMax, Optional Var_Labels, Optional Rank)
Attribute Integr_3D.VB_Description = "Approximates the triple integral of a function f(x, y, z) using the 3D\ndouble exponential method.  SysCoor 1=Rect.,2=Polar,3=Cylindrical\nDefaults are SysCorr=1, Rank=8, ErrMax=2E-16, Var_Labels=''x'',''y'',''z''\nParam is used by all equations."
Attribute Integr_3D.VB_HelpID = 307
Attribute Integr_3D.VB_ProcData.VB_Invoke_Func = " \n14"
'MpMath quad(lambda x,y,z:Fxyz,[xMin, xMax], [yMin, yMax], [zMin, zMax],maxdegree=2)
Dim Bound_min(1 To 3), Bound_max(1 To 3), results(), ErrMsg$, U(1 To 4)

If IsMissing(Rank) Then Rank = 8
Bound_min(1) = xMin: Bound_max(1) = xMax
Bound_min(2) = yMin: Bound_max(2) = yMax
Bound_min(3) = zMin: Bound_max(3) = zMax

Integral_3D_N1 Fxyz, Bound_min, Bound_max, results, Rank, ErrMsg, ErrMax, SysCoor, Param, Var_Labels, False

If Len(ErrMsg) = 0 Then
    U(1) = results(1)   'integral
    U(2) = results(3)   'relative error
    U(3) = results(4) + results(5) 'points
    U(4) = vbNullString  'error message
ElseIf ErrMsg = "Evaluation error" Then
    U(1) = results(1)   'integral
    U(2) = results(3)   'relative error
    U(3) = results(4) + results(5) 'points
    U(4) = "Singularity: dubious accuracy"
Else
    U(1) = ErrMsg
End If
Integr_3D = PasteVector_(U)
End Function
'=============================================================================================
'TRIPLE INTEGRATION routine for regular functions f(x, y, z) on normal domain
'
'Method: 3D-Double Exponential algorithm
'Input:
'Funct = f(x, y, z) integration function
'Limit_min(1) <= x <= Limit_max(1)
'Limit_min(1) <= y <= Limit_max(1)
'Limit_min(1) <= z <= Limit_max(1)
'Rank sets the max iterations for DE method; max points used < (2*rank)^3
'Accuracy default= 2 * 10 ^ -16
'Coord sets the coordinate system (1= cartesian ortho, 2= polar, 3= cylindrical)
'Param = 1 or more parameters for all equations
'Var_Labels default is "x","y","z"
'Output:
'Results(1) = Approximated integral
'Results(2) = max error
'Results(3) = estimated error
'Results(4) = Number of function evaluation points
'Results(5) = Number of boundary evaluation points
'ErrMsg returns any error detected
'                                            v. 1.0 by Leonardo Volpi, Foxes Team, 9-2006
'=============================================================================================
Sub Integral_3D_N1(Funct, Limit_min(), Limit_max(), results(), Rank, ErrMsg, Optional Accuracy, _
  Optional Coord, Optional Param, Optional Var_Labels, Optional TimeCheck As Boolean = True)
If VarType(Funct) < vbInteger Then ErrMsg = "Invalid Null": Exit Sub

Dim OK As Boolean, VarMaxFun%, VarSym$(), VarIDMin1%, VarIDMax1%, par() As Parametro, _
 ParMax&, Fun As New xclsMathParser, fmin(1 To 3) As New xclsMathParser, VarID%(1 To 3), _
 fmax(1 To 3) As New xclsMathParser, n&, k&, k1&, K2&, k3&, fc&, fb&, IntOrd%(1 To 3), _
 VarMax%(1 To 3, 1 To 3), VarMaxId%(1 To 3, 1 To 3), VarMinId%(1 To 3, 1 To 3), _
 t#, TOL#, h#, f#, ja#, z#(1 To 3), x#(1 To 3), w#(1 To 3), a#(1 To 3), b#(1 To 3), ss#(1 To 2), v#(1 To 3)

If IsMissing(Accuracy) Then TOL = 2 * Ten_16 Else TOL = Accuracy
If IsMissing(Coord) Then Coord = 1 'rectangular
ReDim results(1 To 5)
ErrMsg = vbNullString 'initialize return message variable

'parse and syntax check of f(x,y) -----------------
OK = Fun.StoreExpression(Funct)
If Not OK Then GoTo EH

'parse and syntax check of bound function -----------------
For k = 1 To 3
  OK = fmin(k).StoreExpression(Limit_min(k))
  If Not OK Then Fun = fmin(k): GoTo EH
  OK = fmax(k).StoreExpression(Limit_max(k))
  If Not OK Then Fun = fmax(k): GoTo EH
Next

'extract parameters
If Not IsMissing(Param) Then
    Parameter_Add Param, par
    ParMax = UBound(par)
End If

'---  Check and build the variables Index
If Fun.VarTop - ParMax > 3 Then
    ErrMsg = "too many variables in " & Fun.Expression
    Exit Sub
End If
   'substitute parameters values and build
   'the index of the integration variables x, y, z (i= 1, 2, 3)
If IsMissing(Var_Labels) Then
  ReDim VarSym(1 To 3)
  VarSym(1) = "x": VarSym(2) = "y": VarSym(3) = "z"
ElseIf IsArray(Var_Labels) Then
  LoadVector VarSym, Var_Labels, n
  Select Case n
    Case 1: ReDim Preserve VarSym(1 To 3): VarSym(2) = "y": VarSym(3) = "z"
    Case 2: ReDim Preserve VarSym(1 To 3): VarSym(3) = "z"
    Case Is > 3: ErrMsg = "Must have 1, 2  or 3 Var_Labels if present": Exit Sub
  End Select
Else
  ReDim VarSym(1 To 3)
  VarSym(1) = Var_Labels: VarSym(2) = "y": VarSym(3) = "z"
End If
   'VarMinId(i, j) = contains the index of the variable j-th for the i-th integral
   ' integral 1 for dx, integral 2 for dy , integral 3 for dz
For k = 1 To 3
    VariablesIndex fmin(k), VarID, VarSym, par, Param, VarMax(1, k)
    For k1 = 1 To 3: VarMinId(k, k1) = VarID(k1): Next
    VariablesIndex fmax(k), VarID, VarSym, par, Param, VarMax(2, k)
    For k1 = 1 To 3: VarMaxId(k, k1) = VarID(k1): Next
    If VarMaxId(k, k) <> 0 Or VarMinId(k, k) <> 0 Then  'this variable cannot be in this bound
        ErrMsg = "incorrect bound definition": Exit Sub
    End If
    VarMax(3, k) = max_(VarMax(1, k), VarMax(2, k))
    IntOrd(k) = k
Next

VariablesIndex Fun, VarID, VarSym, par, Param, VarMaxFun

'check if the domain is normal to a specific axes and build the integration order
'sort integration order
If VarMax(3, IntOrd(1)) > VarMax(3, IntOrd(2)) Then Swap_ IntOrd(1), IntOrd(2)
If VarMax(3, IntOrd(1)) > VarMax(3, IntOrd(3)) Then Swap_ IntOrd(1), IntOrd(3)
If VarMax(3, IntOrd(2)) > VarMax(3, IntOrd(3)) Then Swap_ IntOrd(2), IntOrd(3)
'check bounding functions
If VarMax(3, IntOrd(1)) > 0 Then ErrMsg = "Normal domain not found for any axes": Exit Sub
For k = 1 To 3
  If VarMax(3, IntOrd(k)) >= k Then ErrMsg = "Bounding error": Exit Sub
Next
'
'DE- algorithm begins here
'
n = Rank  '/* 12 - 18  points max = 2*(2*n)^3
h = 5# / n   '/* 5.0 is rough limit of K in exp(exp(K)) */

'compute fixed limit (where applyng)
If VarMaxFun = 0 Then
  f = Fun.Eval: If Err Then GoTo EH
  fc = fc + 1
End If

For k = 1 To 3
  If VarMax(1, IntOrd(k)) = 0 Then
    a(k) = fmin(IntOrd(k)).Eval: If Err Then Fun = fmin(IntOrd(k)): GoTo EH
    fb = fb + 1
  End If
  If VarMax(2, IntOrd(k)) = 0 Then
    b(k) = fmax(IntOrd(k)).Eval: If Err Then Fun = fmax(IntOrd(k)): GoTo EH
    fb = fb + 1
  End If
Next

If VarMax(1, IntOrd(2)) <> 0 Then _
  If fmin(IntOrd(2)).VarTop > 1 Then _
    If VarMinId(IntOrd(2), 1) <> 0 Then VarIDMin1 = VarMinId(IntOrd(2), 1) Else _
      If VarMinId(IntOrd(2), 2) <> 0 Then VarIDMin1 = VarMinId(IntOrd(2), 2) Else _
        VarIDMin1 = VarMinId(IntOrd(2), 3)
If VarMax(2, IntOrd(2)) <> 0 Then _
  If fmax(IntOrd(2)).VarTop > 1 Then _
    If VarMaxId(IntOrd(2), 1) <> 0 Then VarIDMax1 = VarMaxId(IntOrd(2), 1) Else _
      If VarMaxId(IntOrd(2), 2) <> 0 Then VarIDMax1 = VarMaxId(IntOrd(2), 2) Else _
        VarIDMax1 = VarMaxId(IntOrd(2), 3)

For k = 1 To 2
  t = (k - 1) / 2#
  For k1 = -n To n
    z(1) = h * (k1 + t)
    Expo2_Transform z(1), a(1), b(1), x(IntOrd(1)), w(1)
    If Abs(w(1)) > TOL * (1 + Abs(ss(k))) Then
      For K2 = -n To n
        If VarMax(1, IntOrd(2)) <> 0 Then
          If VarIDMin1 > 0 Then
            fmin(IntOrd(2)).VarValue(VarIDMin1) = x(IntOrd(1))
            a(2) = fmin(IntOrd(2)).Eval
          Else
            a(2) = fmin(IntOrd(2)).Eval1(x(IntOrd(1)))
          End If
          If Err Then Fun = fmin(IntOrd(2)): GoTo EH
          fb = fb + 1
        End If
        If VarMax(2, IntOrd(2)) <> 0 Then
          If VarIDMax1 > 0 Then
            fmax(IntOrd(2)).VarValue(VarIDMax1) = x(IntOrd(1))
            b(2) = fmax(IntOrd(2)).Eval
          Else
            b(2) = fmax(IntOrd(2)).Eval1(x(IntOrd(1)))
          End If
          If Err Then Fun = fmax(IntOrd(2)): GoTo EH
          fb = fb + 1
        End If
        z(2) = h * (K2 + t)
        Expo2_Transform z(2), a(2), b(2), x(IntOrd(2)), w(2)
        If Abs(w(2)) > TOL * (1 + Abs(ss(k))) Then
          For k3 = -n To n
            If VarMax(1, IntOrd(3)) <> 0 Then
              If VarMinId(IntOrd(3), IntOrd(1)) <> 0 Then fmin(IntOrd(3)).VarValue(VarMinId(IntOrd(3), IntOrd(1))) = x(IntOrd(1))
              If VarMinId(IntOrd(3), IntOrd(2)) <> 0 Then fmin(IntOrd(3)).VarValue(VarMinId(IntOrd(3), IntOrd(2))) = x(IntOrd(2))
              a(3) = fmin(IntOrd(3)).Eval: If Err Then Fun = fmin(IntOrd(3)): GoTo EH
              fb = fb + 1
            End If
            If VarMax(2, IntOrd(3)) <> 0 Then
              If VarMaxId(IntOrd(3), IntOrd(1)) <> 0 Then fmax(IntOrd(3)).VarValue(VarMaxId(IntOrd(3), IntOrd(1))) = x(IntOrd(1))
              If VarMaxId(IntOrd(3), IntOrd(2)) <> 0 Then fmax(IntOrd(3)).VarValue(VarMaxId(IntOrd(3), IntOrd(2))) = x(IntOrd(2))
              b(3) = fmax(IntOrd(3)).Eval: If Err Then Fun = fmax(IntOrd(3)): GoTo EH
              fb = fb + 1
            End If
            z(3) = h * (k3 + t)
            Expo2_Transform z(3), a(3), b(3), x(IntOrd(3)), w(3)
            If Abs(w(3)) > TOL * (1 + Abs(ss(k))) Then
              'choose the coordinate system
              Select Case Coord
                Case 1: ja = 1 ' cartesian ortho system
                  If VarMaxFun = 0 Then GoTo SkipErrChk
                  If VarID(1) <> 0 Then Fun.VarValue(VarID(1)) = x(1)
                  If VarID(2) <> 0 Then Fun.VarValue(VarID(2)) = x(2)
                  If VarID(3) <> 0 Then Fun.VarValue(VarID(3)) = x(3)
                Case 2: Polar3D_Transf x, v, ja ' polar system
                  If VarMaxFun = 0 Then GoTo SkipErrChk
                  If VarID(1) <> 0 Then Fun.VarValue(VarID(1)) = v(1)
                  If VarID(2) <> 0 Then Fun.VarValue(VarID(2)) = v(2)
                  If VarID(3) <> 0 Then Fun.VarValue(VarID(3)) = v(3)
                Case 3: Cylin_Transf x, v, ja 'cylindrical system
                  If VarMaxFun = 0 Then GoTo SkipErrChk
                  If VarID(1) <> 0 Then Fun.VarValue(VarID(1)) = v(1)
                  If VarID(2) <> 0 Then Fun.VarValue(VarID(2)) = v(2)
                  If VarID(3) <> 0 Then Fun.VarValue(VarID(3)) = v(3)
              End Select
              f = Fun.Eval: If Err Then GoTo EH
              fc = fc + 1
SkipErrChk:   ss(k) = ss(k) + h ^ 3 * f * ja * w(1) * w(2) * w(3)
            End If
            '---- form counter
            If TimeCheck Then If (fb + fc) Mod 1000 = 0 Then If frmD3integr.TimeStop(fb + fc) Then Exit Sub
            '-----
          Next k3
        End If
      Next K2
    End If
  Next k1
Next k

results(1) = (ss(1) + ss(2)) / 2 'integral
results(2) = Abs(ss(1) - ss(2))  'max error
results(3) = 5 * TOL + 0.1 * (results(2)) ^ 2 'estimated error
results(4) = fc 'function evaluation counter
results(5) = fb 'bounding evaluation counter
Exit Sub
EH: ErrMsg = Fun.Expression & " : " & Fun.ErrorDescription
End Sub

Sub Expo2_Transform(z#, a#, b#, x#, w#)
Dim exz#, s#, t# ', hcos#, hsin#
        exz = Exp(z)
        'hsin = exz - 1 / exz
        'hcos = exz + 1 / exz
        s = Exp(Pi4_ * (exz - 1 / exz))
        t = s + 1 / s
        x = (b * s + a / s) / t '/* transformed abscissa  */
        If x <> a And x <> b Then
          w = (b - a) * Pi2_ * (exz + 1 / exz) / t ^ 2 '/* transformed weight */
        Else
          w = 0
        End If
End Sub

Private Sub VariablesIndex(Fun As xclsMathParser, VarID, VarSym$(), par() As Parametro, Param, VarMax%)
Dim i&, j&
VarMax = 0
For i = 1 To UBound(VarID): VarID(i) = 0: Next i

For i = 1 To Fun.VarTop
  For j = 1 To UBound(VarSym)
    If Fun.VarName(i) = VarSym(j) Then VarID(j) = i: VarMax = VarMax + 1: GoTo SkipParam
  Next j
  If Not IsMissing(Param) Then
    j = get_ParamId_(Fun.VarName(i), par)
    If j > 0 Then Fun.VarValue(i) = par(j).valr
  End If
SkipParam: Next i
End Sub

'transform from polar to rectangular [r0, theta, phi] -> [x, y, z]
'xp1 = ro
'xp2 = theta  [0, 2pi] longitudine
'xp3 = phi    [0, pi] co-latitudine
Private Sub Polar3D_Transf(xp#(), xR#(), ja#)
ja = Sin(xp(3))
xR(1) = xp(1) * ja * Cos(xp(2))     'x
xR(2) = xp(1) * ja * Sin(xp(2))     'y
xR(3) = xp(1) * Cos(xp(3))          'z
ja = xp(1) ^ 2 * ja   '|J|
End Sub

'transform from cylindrical to rectangular [r0, theta, z] -> [x, y, z]
'xc1 = ro
'xc2 = theta  [0, 2pi]
'xc3 = z      [0, 2pi]
Private Sub Cylin_Transf(xc#(), xR#(), ja#)
xR(1) = xc(1) * Cos(xc(2))    'x
xR(2) = xc(1) * Sin(xc(2))    'y
xR(3) = xc(3)                 'z
ja = xc(1)      '|J|
End Sub
VBA Filename FiittingRM.bas Extracted Macro
'******************************************************************************************
' Fitting Routines with Robust methods
' by  Alfredo \xc1lvarez Valdivia
' r.1.0, 19-6-2002
'******************************************************************************************

Type Recta
    Pendiente As Double
    Ordenada As Double
    MedianaResidual As Double
End Type

Private Function M\xe9todo_mediana_simple(Abscisas#(), Ordenadas#(), Pendiente#, Ordenada#) As Boolean

'Ajusta una recta mediante el m\xe9todo de la mediana simple (SM). Si se produce
'alg\xfan error la funci\xf3n devuelve FALSE, en caso contrario devuelve TRUE

M\xe9todo_mediana_simple = True

'On Error GoTo ErrorMedianaSimple:

Dim i%, j%, inf%, sup As Integer
Dim VectorPendientes#()

inf = LBound(Abscisas)
sup = UBound(Abscisas)

ReDim VectorPendientes(inf To (sup - inf) * (sup + 1 - inf) / 2)

If Not CalcularPendientes(Abscisas(), Ordenadas(), VectorPendientes(), inf, sup, 1) Then
    M\xe9todo_mediana_simple = False
    Exit Function
End If

'Llamar a la subrutina de ordenamiento para el VectorPendientes
If Not Qsort(VectorPendientes, inf, UBound(VectorPendientes)) Then
    M\xe9todo_mediana_simple = False
    Exit Function
End If

'Se calcula la mediana de las pendientes
sup = (sup - inf) * (sup + 1 - inf) / 2
Pendiente = CalcularMediana(VectorPendientes(), inf, sup)

'C\xe1lculo de la ordenada en el origen
sup = UBound(Abscisas)
ReDim VectorPendientes(inf To sup)

If Not CalcularOrdenada(Abscisas(), Ordenadas(), VectorPendientes(), Pendiente, inf, sup) Then
    M\xe9todo_mediana_simple = False
    Exit Function
End If

'Llamar a la subrutina de ordenamiento para el VectorPendientes
If Not Qsort(VectorPendientes, inf, sup) Then
    M\xe9todo_mediana_simple = False
    Exit Function
End If


'Se calcula la mediana de las ordenadas
Ordenada = CalcularMediana(VectorPendientes(), inf, sup)

'Exit Function
'
'
'ErrorMedianaSimple:
'
'M\xe9todo_mediana_simple = False
'MsgBox "Se ha producido un error en el m\xf3dulo 'Mod_M\xe9todos_Robustos'," & Chr(13) & "en la funci\xf3n 'M\xe9todo_mediana_simple'. Consulte con el proveedor", vbCritical, "Error"
'
'Exit Function
'
End Function

Private Function M\xe9todo_mediana_repetida(Abscisas#(), Ordenadas#(), Pendiente#, Ordenada#) As Boolean

'Ajusta una recta mediante el m\xe9todo de la mediana repetida (RM). Si se produce
'alg\xfan error la funci\xf3n devuelve FALSE, en caso contrario devuelve TRUE

M\xe9todo_mediana_repetida = True

'On Error GoTo ErrorMedianaRepetida:

Dim i%, j%, inf%, sup As Integer
Dim VectorPendientes#(), VectorAuxiliar1#(), VectorAuxiliar2#()

inf = LBound(Abscisas)
sup = UBound(Abscisas)

ReDim VectorPendientes(inf To sup - 1, inf To sup - 1)
ReDim VectorAuxiliar1(inf To sup - 1)
ReDim VectorAuxiliar2(inf To sup)

If Not CalcularPendientes(Abscisas(), Ordenadas(), VectorPendientes(), inf, sup, 2) Then
    M\xe9todo_mediana_repetida = False
    Exit Function
End If

sup = sup - 1
For i = inf To sup + 1
    If Not CalcularVector(VectorPendientes(), VectorAuxiliar1(), i, inf, sup + 1) Then
        M\xe9todo_mediana_repetida = False
        Exit Function
    End If
    
    'Ordenar VectorAuxiliar1()
    If Not Qsort(VectorAuxiliar1(), inf, sup) Then
        M\xe9todo_mediana_repetida = False
        Exit Function
    End If

    'Se calcula la mediana del vector VectorAuxiliar1()
    VectorAuxiliar2(i) = CalcularMediana(VectorAuxiliar1(), inf, sup)
Next i

'ordenar VectorAuxiliar2()
If Not Qsort(VectorAuxiliar2(), inf, sup + 1) Then
    M\xe9todo_mediana_repetida = False
    Exit Function
End If

'Se calcula la mediana del VectorAuxiliar2()
Pendiente = CalcularMediana(VectorAuxiliar2(), inf, sup + 1)

'C\xe1lculo de la ordenada en el origen
sup = UBound(Abscisas)
ReDim VectorAuxiliar1(inf To sup)

If Not CalcularOrdenada(Abscisas(), Ordenadas(), VectorAuxiliar1(), Pendiente, inf, sup) Then
    M\xe9todo_mediana_repetida = False
    Exit Function
End If

'Llamar a la subrutina de ordenamiento para el VectorPendientes
If Not Qsort(VectorAuxiliar1(), inf, sup) Then
    M\xe9todo_mediana_repetida = False
    Exit Function
End If

'Se calcula la mediana de las ordenadas
Ordenada = CalcularMediana(VectorAuxiliar1(), inf, sup)

'Exit Function
'
'
'ErrorMedianaRepetida:
'
'M\xe9todo_mediana_repetida = False
'MsgBox "Se ha producido un error en el m\xf3dulo 'Mod_M\xe9todos_Robustos'," & Chr(13) & "en la funci\xf3n 'M\xe9todo_mediana_repetida'. Consulte con el proveedor", vbCritical, "Error"
'
'Exit Function
'
End Function

Private Function M\xe9todo_m\xednima_mediana_cuadrados(Abscisas#(), Ordenadas#(), Pendiente#, Ordenada#) As Boolean

'Ajusta una recta mediante el m\xe9todo de la m\xednima mediana de cuadrados (LMS). Si se
'produce alg\xfan error la funci\xf3n devuelve FALSE, en caso contrario devuelve TRUE

M\xe9todo_m\xednima_mediana_cuadrados = True

'On Error GoTo ErrorM\xednimaMedianaCuadrados:

Dim i%, inf%, sup As Integer
Dim VectorRectas() As Recta, VectorResidual#(), VectorMedianas#(), auxiliar As Double

inf = LBound(Abscisas)
sup = UBound(Abscisas)

ReDim VectorRectas(inf To (sup - inf) * (sup + 1 - inf) / 2)
ReDim VectorResidual(inf To sup)
ReDim VectorMedianas(inf To (sup - inf) * (sup + 1 - inf) / 2)

'Se calculan todas las rectas posibles
If Not CalcularRectas(Abscisas(), Ordenadas(), VectorRectas(), inf, sup) Then
    M\xe9todo_m\xednima_mediana_cuadrados = False
    Exit Function
End If

'Para cada una de las rectas calculadas se busca la residual de cada punto y se halla
'la mediana de estos valores
For i = inf To ((sup - inf) * (sup + 1 - inf) / 2)
    
    'Para una recta, se calcula la residual de cada uno de los puntos
    If Not CalcularResiduales(VectorResidual(), Abscisas(), Ordenadas(), VectorRectas(i).Pendiente, VectorRectas(i).Ordenada, inf, sup) Then
        M\xe9todo_m\xednima_mediana_cuadrados = False
        Exit Function
    End If
    
    'Se ordena el vector que contiene las residuales de cada punto para una recta dada
    If Not Qsort(VectorResidual(), inf, sup) Then
        M\xe9todo_m\xednima_mediana_cuadrados = False
        Exit Function
    End If
    
    'Se busca la mediana de las residuales para esta recta ajustada y se almacena
    'en dos sitios distintos ya que uno de estos vectores se va a ordenar y
    'es necesario no perder la pista de cada uno de los valores
    VectorMedianas(i) = CalcularMediana(VectorResidual(), inf, sup)
    VectorRectas(i).MedianaResidual = VectorMedianas(i)
Next i
    
'Se ordena el vector de medianas para tomor el menor valor
sup = ((sup - inf) * (sup + 1 - inf) / 2)
If Not Qsort(VectorMedianas(), inf, sup) Then
    M\xe9todo_m\xednima_mediana_cuadrados = False
    Exit Function
End If

i = 1
Do
    If VectorMedianas(1) = VectorRectas(i).MedianaResidual Then
        'ReDim Preserve Pendiente(1 To i)
        'ReDim Preserve Ordenada(1 To i)
        Pendiente = VectorRectas(i).Pendiente
        Ordenada = VectorRectas(i).Ordenada
        i = sup
    End If
    i = i + 1
Loop While i <= sup
'Exit Function
'
'ErrorM\xednimaMedianaCuadrados:
'M\xe9todo_m\xednima_mediana_cuadrados = False
'MsgBox "Se ha producido un error en el m\xf3dulo 'Mod_M\xe9todos_Robustos'," & Chr(13) & "en la funci\xf3n 'M\xe9todo_m\xednima_mediana_cuadrados'. Consulte con el proveedor", vbCritical, "Error"
'Exit Function

End Function

Private Function CalcularPendientes(Abscisas#(), Ordenadas#(), VectorPendientes#(), ByVal inf%, ByVal sup%, ByVal m\xe9todo%) As Boolean

'inf: \xedndice del primer elemento de la tabla de datos
'sup: \xedndice del \xfaltimo elemento de la tabla de datos

'm\xe9todo=1   se refiere a la mediana simple
'm\xe9todo=2   se refiere a la mediana repetida

CalcularPendientes = True

'On Error GoTo ErrorCalcularPendientes:

Dim i%, j%, k As Integer

k = inf
For i = inf To sup - 1
    For j = i + 1 To sup
        If m\xe9todo = 1 Then
            VectorPendientes(k) = (Ordenadas(i) - Ordenadas(j)) / (Abscisas(i) - Abscisas(j))
            k = k + 1
        ElseIf m\xe9todo = 2 Then
            VectorPendientes(i, j - 1) = (Ordenadas(i) - Ordenadas(j)) / (Abscisas(i) - Abscisas(j))
        End If
    Next j
Next i

'Exit Function
'
'ErrorCalcularPendientes:
'
'CalcularPendientes = False
'MsgBox "Se ha producido un error en el m\xf3dulo 'Mod_M\xe9todos_Robustos'," & Chr(13) & "en la funci\xf3n 'CalcularPendientes'. Consulte con el proveedor", vbCritical, "Error"
'
'Exit Function

End Function

Private Function CalcularOrdenada(Abscisas#(), Ordenadas#(), VectorOrdenadas#(), ByVal Pendiente#, ByVal inf%, ByVal sup%) As Boolean

'inf: \xedndice del primer elemento de la tabla de datos
'sup: \xedndice del \xfaltimo elemento de la tabla de datos

CalcularOrdenada = True

'On Error GoTo CalcularOrdenada:

Dim i As Integer

For i = inf To sup
    VectorOrdenadas(i) = Ordenadas(i) - Pendiente * Abscisas(i)
Next i

'Exit Function
'
'
'CalcularOrdenada:
'
'CalcularOrdenada = False
'MsgBox "Se ha producido un error en el m\xf3dulo 'Mod_M\xe9todos_Robustos'," & Chr(13) & "en la funci\xf3n 'CalcularOrdenada'. Consulte con el proveedor", vbCritical, "Error"
'
'Exit Function
'

End Function

Private Function CalcularVector(VectorPendientes#(), VectorAuxiliar1#(), ByVal puntero%, ByVal inf%, ByVal sup%) As Boolean

'inf: \xedndice del primer elemento de la tabla de datos
'sup: \xedndice del \xfaltimo elemento de la tabla de datos

CalcularVector = True

'On Error GoTo CalcularVector:

Dim i%, j%, k As Integer

k = inf
For j = inf To sup - 1
    If j >= puntero Then
        VectorAuxiliar1(k) = VectorPendientes(puntero, j)
        k = k + 1
    ElseIf j < puntero Then
        VectorAuxiliar1(k) = VectorPendientes(j, puntero - 1)
        k = k + 1
    End If
Next j
            
'Exit Function
'
'
'CalcularVector:
'
'CalcularVector = False
'MsgBox "Se ha producido un error en el m\xf3dulo 'Mod_M\xe9todos_Robustos'," & Chr(13) & "en la funci\xf3n 'CalcularVector'. Consulte con el proveedor", vbCritical, "Error"
'
'Exit Function
'

End Function

Private Function CalcularMediana(vector#(), ByVal inf%, ByVal sup%) As Double

'inf: dimensi\xf3n inferior de vector()
'sup: dimensi\xf3n superior de vector()

'CalcularMediana = True

'On Error GoTo CalcularMediana:

If ((sup + 1 - inf) Mod 2) = 0 Then
    CalcularMediana = (vector((sup + 1 - inf) / 2) + vector((sup + 3 - inf) / 2)) / 2
Else
    CalcularMediana = vector((sup + 2 - inf) / 2)
End If


'Exit Function
'
'
'CalcularMediana:
'
''CalcularMediana = False
'MsgBox "Se ha producido un error en el m\xf3dulo 'Mod_M\xe9todos_Robustos'," & Chr(13) & "en la funci\xf3n 'CalcularMediana'. Consulte con el proveedor", vbCritical, "Error"
'
'Exit Function


End Function

Private Function Qsort(vector#(), ByVal primero%, ByVal \xfaltimo%) As Boolean

Qsort = True

'On Error GoTo ErrorQsort:

Dim i%, j As Integer
Dim central#, auxiliar As Double

i = primero
j = \xfaltimo
central = vector((i + j) \ 2)

Do
    Do While vector(i) < central
        i = i + 1
    Loop
    Do While vector(j) > central
        j = j - 1
    Loop
    If i <= j Then
        auxiliar = vector(i)
        vector(i) = vector(j)
        vector(j) = auxiliar
        i = i + 1
        j = j - 1
    End If
Loop Until i > j

If primero < j Then
    Qsort vector(), primero, j
End If

If i < \xfaltimo Then
    Qsort vector(), i, \xfaltimo
End If

'Exit Function
'
'
'ErrorQsort:
'
'Qsort = False
'MsgBox "Se ha producido un error en el m\xf3dulo 'Mod_M\xe9todos_Robustos'," & Chr(13) & "en la funci\xf3n 'Qsort'. Consulte con el proveedor", vbCritical, "Error"
'
'Exit Function
'

End Function

Private Function CalcularRectas(Abscisas#(), Ordenadas#(), VectorRectas() As Recta, ByVal inf%, ByVal sup%) As Boolean

'inf: \xedndice del primer elemento de la tabla de datos
'sup: \xedndice del \xfaltimo elemento de la tabla de datos

CalcularRectas = True

'On Error GoTo ErrorCalcularRectas:

Dim i%, j%, k As Integer

k = inf
For i = inf To sup - 1
    For j = i + 1 To sup
        VectorRectas(k).Pendiente = (Ordenadas(i) - Ordenadas(j)) / (Abscisas(i) - Abscisas(j))
        VectorRectas(k).Ordenada = Ordenadas(i) - (VectorRectas(k).Pendiente * Abscisas(i))
        k = k + 1
    Next j
Next i

'Exit Function
'
'
'ErrorCalcularRectas:
'
'CalcularRectas = False
'MsgBox "Se ha producido un error en el m\xf3dulo 'Mod_M\xe9todos_Robustos'," & Chr(13) & "en la funci\xf3n 'CalcularRectas'. Consulte con el proveedor", vbCritical, "Error"
'
'Exit Function
'

End Function

Private Function CalcularResiduales(VectorResidual#(), Abscisas#(), Ordenadas#(), Pendiente#, Ordenada#, ByVal inf%, ByVal sup%) As Boolean

'inf: \xedndice del primer elemento de la tabla de datos
'sup: \xedndice del \xfaltimo elemento de la tabla de datos

CalcularResiduales = True

'On Error GoTo ErrorCalcularResiduales:

Dim i%, j As Integer

For i = inf To sup
    VectorResidual(i) = (Ordenadas(i) - Pendiente * Abscisas(i) - Ordenada) ^ 2
Next i
    
'Exit Function
'
'
'ErrorCalcularResiduales:
'
'CalcularResiduales = False
'MsgBox "Se ha producido un error en el m\xf3dulo 'Mod_M\xe9todos_Robustos'," & Chr(13) & "en la funci\xf3n 'CalcularResiduales'. Consulte con el proveedor", vbCritical, "Error"
'
'Exit Function
'

End Function

'=============================================================================================================
Function RegLinRM(x, y, Optional Method)
Attribute RegLinRM.VB_Description = "Linear Regression with Robust Method"
Attribute RegLinRM.VB_HelpID = 128
Attribute RegLinRM.VB_ProcData.VB_Invoke_Func = " \n14"
'-----------------------------------------------------------------------------
'Linear Regression with Robust Method, 20.7.2002
'Uses the original routines developed by Alfredo \xc1lvarez Valdivia
'Parameter x and y are both vectors of ( n x 1)
'Parameter Method= SM (simple mediana), RM (repeated mediana), LMS (least mediana squares)
'returns coefficients [a1,a0] of linear regression y = a1*x+a0
'----------------------------------------------------------------------------.
Dim Abscisas#(), Ordenadas#()
Dim Pendiente#, Ordenada#, n&
If IsMissing(Method) Then Method = Sm
LoadVector Abscisas, x, n
LoadVector Ordenadas, y, n
Select Case Method
Case "LMS"
    ris = M\xe9todo_m\xednima_mediana_cuadrados(Abscisas(), Ordenadas(), Pendiente, Ordenada)
Case "RM"
    ris = M\xe9todo_mediana_repetida(Abscisas(), Ordenadas(), Pendiente, Ordenada)
Case Else
    ris = M\xe9todo_mediana_simple(Abscisas(), Ordenadas(), Pendiente, Ordenada)
End Select
If ris Then PasteVector2 RegLinRM, Array(Pendiente, Ordenada) Else RegLinRM = "?"

End Function

Function RegLinMM(x, y)
Attribute RegLinMM.VB_Description = "Linear Regression Min-Max (Chebychev)"
Attribute RegLinMM.VB_HelpID = 283
Attribute RegLinMM.VB_ProcData.VB_Invoke_Func = " \n14"
'Returns the Min-Max Linear Regression Polynomial (Cebychev)
'Uses the exchange algorithm
'v. 10.5.2005 by Foxes Team
Dim y_, x_, Yerr()
Dim Yerr_max#, h#, e1#, e2#
Const e# = Ten_15
y_ = y
n = UBound(y_)
x_ = x
If n < 3 Or n <> UBound(x_, 1) Then
    RegLinMM = "?"
    Exit Function
End If
ReDim Yerr(1 To n)
m = UBound(x_, 2)

i1 = 1: i2 = 2: i3 = 3
x1 = x_(i1, 1): x2 = x_(i2, 1): x3 = x_(i3, 1)
y1 = y_(i1, 1): y2 = y_(i2, 1): y3 = y_(i3, 1)
MaxCounter = 1000: e1 = CDbl(VbMax)

Do
    m = (y1 - y3) / (x1 - x3)
    q = ((y1 + 2 * y2 + y3) - m * (x1 + 2 * x2 + x3)) / 4
    h = ((y1 - 2 * y2 + y3) - m * (x1 - 2 * x2 + x3)) / 4
    'search for max error point
    Yerr_max = 0: i_max = 0
    For i = 1 To n
        Yerr(i) = y_(i, 1) - m * x_(i, 1) - q
        If Abs(Yerr(i)) > Yerr_max Then
            Yerr_max = Abs(Yerr(i))
            i_max = i
        End If
    Next
    'check end algorithm
'    If Yerr_max <= Abs(h) + e# Then Exit Do
    e2 = Abs(Yerr_max - Abs(h)): If e2 <= e# Or e2 = e1 Then Exit Do Else e1 = e2
    'insert the new Pmax value into the tree point set [P1,P2,P3] and eliminate one
    If x_(i_max, 1) > x3 Then 'case  P1<P2<P3<Pmax
        If Sgn(Yerr(i_max)) <> Sgn(Yerr(i3)) Then
            'shift left
            x1 = x2: x2 = x3
            y1 = y2: y2 = y3
            i1 = i2: i2 = i3
        End If
        x3 = x_(i_max, 1): y3 = y_(i_max, 1): i3 = i_max

    ElseIf x_(i_max, 1) < x1 Then  'case  Pmax<P1<P2<P3
        If Sgn(Yerr(i_max)) <> Sgn(Yerr(i1)) Then
            'shift right
            x3 = x2: x2 = x1
            y3 = y2: y2 = y1
            i3 = i2: i2 = i1
        End If
        x1 = x_(i_max, 1): y1 = y_(i_max, 1): i1 = i_max

    ElseIf x_(i_max, 1) < x2 Then   'case  P1<Pmax<P2<P3
        If Sgn(Yerr(i_max)) = Sgn(Yerr(i2)) Then
            x2 = x_(i_max, 1): y2 = y_(i_max, 1): i2 = i_max
        Else
            x1 = x_(i_max, 1): y1 = y_(i_max, 1): i1 = i_max
        End If

    ElseIf x_(i_max, 1) > x2 Then   'case  P1<P2<Pmax<P3
        If Sgn(Yerr(i_max)) = Sgn(Yerr(i2)) Then
            x2 = x_(i_max, 1): y2 = y_(i_max, 1): i2 = i_max
        Else
            x3 = x_(i_max, 1): y3 = y_(i_max, 1): i3 = i_max
        End If
    End If
    MaxCounter = MaxCounter - 1
Loop Until MaxCounter = 0
If MaxCounter > 0 Then PasteVector2 RegLinMM, Array(q, m) Else RegLinMM = "?"
End Function

Private Sub Lin_MaxMin(x1, x2, x3, y1, y2, y3, m, q, h)
'compute the line of min-max error (Cebysev)
m = (y1 - y3) / (x1 - x3)
q = ((y1 + 2 * y2 + y3) - m * (x1 + 2 * x2 + x3)) / 4
h = ((y1 - 2 * y2 + y3) - m * (x1 - 2 * x2 + x3)) / 4
End Sub
VBA Filename modSpline1.bas Extracted Macro
'************************************************************
' CUBIC SPLINE FUNCTION for EXCEL
' by Olgierd Zieba
' rev. ver. 1.1 - 18 Oct. 2004  by Foxes Team
'*************************************************************
Option Base 1
Option Explicit
'Calculates Cubic Spline Coefficients
Function Cspline_Coeff(Xin As Range, Yin As Range)
Attribute Cspline_Coeff.VB_Description = "Calculates Cubic Spline Coefficients\na3*x^3+a2*x^2+a1*x+a0"
Attribute Cspline_Coeff.VB_HelpID = 140
Attribute Cspline_Coeff.VB_ProcData.VB_Invoke_Func = " \n14"
Dim n%, ny%  'Xin and Yin counts
Dim i%   'loop counter
Dim ihi%, m%, x#(), y#()
Dim a#, b#, p#, qn#, sig#, un#, h0#, h1#, h2#

ny = Yin.Cells.Count
If IsMissing(Xin) Or Xin Is Nothing Then
    n = ny
Else
    n = Xin.Cells.Count
End If

' Next check to be sure that there are the came counts of Xin and Yin
If n <> ny Then
    Cspline_Coeff = CVErr(xlErrRef) 'Uneven counts of Xin and Yin"
    GoTo err_ret
End If
 
ReDim x(1 To n) As Double
ReDim y(1 To n) As Double
'ReDim u(1 To n - 1) As Single
ReDim U(1 To n - 1) As Double   'mod. LV 31-8-02 accuracy increased
ReDim ypp(1 To n) As Double 'these are the 2nd derivative values
ReDim coeff(1 To n, 1 To 4) As Double 'these are the cubic spline coefficients

'populate and order the input arrays
OrderNodes Xin, Yin, x, y

ypp(1) = 0  'First knot boundary condition
U(1) = 0    'First knot boundary condition

For i = 2 To n - 1
    h0 = x(i + 0) - x(i - 1)
    h1 = x(i + 1) - x(i - 0)
    h2 = x(i + 1) - x(i - 1)
    
    sig = h0 / h2
    p = sig * ypp(i - 1) + 2#
    ypp(i) = (sig - 1) / p
    U(i) = (y(i + 1) - y(i)) / h1 - (y(i) - y(i - 1)) / h0
    U(i) = (6# * U(i) / h2 - sig * U(i - 1)) / p
    
    Next i
    
qn = 0
un = 0
ypp(n) = (un - qn * U(n - 1)) / (qn * ypp(n - 1) + 1) 'Last knot boundary condition


For i = n - 1 To 1 Step -1
    ypp(i) = ypp(i) * ypp(i + 1) + U(i) 'Backfill the 2nd derivatives
    h0 = x(i + 1) - x(i)
    'Calculate the coefficients for each spline fragment
    coeff(i, 1) = (ypp(i + 1) - ypp(i)) / (6# * h0) 'A (X^3)
    coeff(i, 2) = ypp(i) / 2# 'B (X^2)
    coeff(i, 3) = (y(i + 1) - y(i)) / h0 - (2# * h0 * ypp(i) + h0 * ypp(i + 1)) / 6# 'C (X)
    coeff(i, 4) = y(i) 'D
    
Next i

Cspline_Coeff = PasteVector_(coeff)

err_ret:
End Function
'Prealculates Cubic Spline for cspline_eval
Function Cspline_Pre(Xin As Range, Yin As Range)
Attribute Cspline_Pre.VB_Description = "2nd derivative values of cubic spline,"
Attribute Cspline_Pre.VB_HelpID = 141
Attribute Cspline_Pre.VB_ProcData.VB_Invoke_Func = " \n14"
Dim n%, ny%  'Xin and Yin counts
Dim i%   'loop counter
Dim ihi%, m%, x#(), y#()
Dim a#, b#, p#, qn#, sig#, un#, h0#, h1#, h2#

ny = Yin.Cells.Count
n = Xin.Cells.Count

' Next check to be sure that there are the came counts of Xin and Yin
If n <> ny Then
    Cspline_Pre = CVErr(xlErrRef) 'Uneven counts of Xin and Yin"
    GoTo err_ret
End If
 
ReDim x(1 To n) As Double
ReDim y(1 To n) As Double
'ReDim u(1 To n - 1) As Single
ReDim U(1 To n - 1) As Double   'mod. LV 31-8-02
ReDim ypp(1 To n, 1 To 1) As Double 'these are the 2nd derivative values

'populate and order the input arrays
OrderNodes Xin, Yin, x, y

ypp(1, 1) = 0 'First knot boundary condition
U(1) = 0    'First knot boundary condition

For i = 2 To n - 1
    h0 = x(i + 0) - x(i - 1)
    h1 = x(i + 1) - x(i - 0)
    h2 = x(i + 1) - x(i - 1)
    
    sig = h0 / h2
    p = sig * ypp(i - 1, 1) + 2#
    ypp(i, 1) = (sig - 1) / p
    U(i) = (y(i + 1) - y(i)) / h1 - (y(i) - y(i - 1)) / h0
    U(i) = (6# * U(i) / h2 - sig * U(i - 1)) / p
    
    Next i
    
qn = 0
un = 0
ypp(n, 1) = (un - qn * U(n - 1)) / (qn * ypp(n - 1, 1) + 1) 'Last knot boundary condition

For i = n - 1 To 1 Step -1
    ypp(i, 1) = ypp(i, 1) * ypp(i + 1, 1) + U(i) 'Backfill the 2nd derivatives
Next i

Cspline_Pre = PasteVector_(ypp)

err_ret:
End Function
'Interpolates one point from sorted X,Y data pairs using Cubic Spline Interpolation
Function Cspline_Interp(Xin As Range, Yin As Range, Xtarget#)
Attribute Cspline_Interp.VB_Description = "Interpolates one point from sorted X,Y data pairs using Cubic Spline Interpolation"
Attribute Cspline_Interp.VB_HelpID = 139
Attribute Cspline_Interp.VB_ProcData.VB_Invoke_Func = " \n14"

Dim n%, ny%   'Xin and Yin counts
Dim i%   'loop counter
Dim ihi%, m%, x#(), y#()
Dim a#, b#, p#, qn#, sig#, un#, h0#, h1#, h2#, Yout#

ny = Yin.Cells.Count
n = Xin.Cells.Count
' Next check to be sure that there are the came counts of Xin and Yin
If n <> ny Then
    Cspline_Interp = CVErr(xlErrRef) 'Uneven counts of Xin and Yin"
    GoTo err_ret
End If
 
ReDim x(1 To n) As Double
ReDim y(1 To n) As Double
'ReDim u(1 To n - 1) As Single
ReDim U(1 To n - 1) As Double   'mod. LV 31-8-02
ReDim ypp(1 To n) As Double 'these are the 2nd derivative values

'populate and order the input arrays
OrderNodes Xin, Yin, x, y

ypp(1) = 0  'First knot boundary condition
U(1) = 0    'First knot boundary condition

For i = 2 To n - 1
    h0 = x(i + 0) - x(i - 1)
    h1 = x(i + 1) - x(i - 0)
    h2 = x(i + 1) - x(i - 1)
    
    sig = h0 / h2
    p = sig * ypp(i - 1) + 2#
    ypp(i) = (sig - 1) / p
    U(i) = (y(i + 1) - y(i)) / h1 - (y(i) - y(i - 1)) / h0
    U(i) = (6# * U(i) / h2 - sig * U(i - 1)) / p
    
    Next i
    
qn = 0
un = 0
ypp(n) = (un - qn * U(n - 1)) / (qn * ypp(n - 1) + 1) 'Last knot boundary condition


For i = n - 1 To 1 Step -1
    ypp(i) = ypp(i) * ypp(i + 1) + U(i) 'Backfill the 2nd derivatives
Next i
''''''''''''''''''''''''''''''''''''''''
'Spline evaluation at target X point
'''''''''''''''''''''''''''''''''''''''''
'Find correct interval using halving binary search
i = 1
ihi = n
Do While (i < ihi - 1)
        m = (i + ihi) \ 2   'Calculate the midpoint
        If Xtarget < x(m) Then ihi = m Else i = m  'Narrow down the bounds
Loop
' i = beginning of the correct interval
h0 = x(i + 1) - x(i)    'Calc the width of the X interval
a = (x(i + 1) - Xtarget) / h0
b = (Xtarget - x(i)) / h0
Yout = a * y(i) + b * y(i + 1) + ((a ^ 3 - a) * ypp(i) + (b ^ 3 - b) * ypp(i + 1)) * (h0 ^ 2) / 6#

Cspline_Interp = Yout

err_ret:
End Function


'Interpolates one point from sorted X,Y data pairs using Cubic Spline Interpolation
Function Cspline_Eval(Xin As Range, Yin As Range, ypp As Range, Xtarget#)
Attribute Cspline_Eval.VB_Description = "Interpolates one point from sorted X,Y data pairs using Cubic Spline Interpolation with 2nd derivatives (fast formula)"
Attribute Cspline_Eval.VB_HelpID = 139
Attribute Cspline_Eval.VB_ProcData.VB_Invoke_Func = " \n14"

Dim n%, ny%, nd%   'Xin, Din and Yin counts
Dim i%  'loop counter
Dim ihi%, m%, x#(), y#()
Dim a#, b#, p#, qn#, sig#, un#, h0#, h1#, h2#, Yout#

ny = Yin.Cells.Count
nd = ypp.Cells.Count
n = Xin.Cells.Count

' Next check to be sure that there are the came counts of Xin and Yin
If n <> ny Or n <> nd Then
    Cspline_Eval = CVErr(xlErrRef) 'Uneven counts of Xin , Din and Yin"
    GoTo err_ret
End If

ReDim x(1 To n) As Double
ReDim y(1 To n) As Double
 
'populate and order the input arrays
OrderNodes Xin, Yin, x, y
 
''populate the input arrays
'For i = 1 To N
'    If i > 1 Then
'        If Xin(i).value <= Xin(i - 1).value Then 'Check if X values are not repeating and are sorted in ascending order
'            cspline_eval = CVErr(xlErrValue) 'Error: Not sorted or repeating
'            GoTo err_ret
'        End If
'    End If
'Next i
''''''''''''''''''''''''''''''''''''''''
'Spline evaluation at target X point
'''''''''''''''''''''''''''''''''''''''''
'Find correct interval using halving binary search
i = 1
ihi = n
Do While (i < ihi - 1)
    m = (i + ihi) \ 2   'Calculate the midpoint
    If Xtarget < x(m) Then ihi = m Else i = m  'Narrow down the bounds
Loop
' i = beginning of the correct interval
h0 = x(i + 1) - x(i)    'Calc the width of the X interval
a = (x(i + 1) - Xtarget) / h0
b = (Xtarget - x(i)) / h0
Yout = a * y(i) + b * y(i + 1) + ((a ^ 3 - a) * ypp(i).Value + (b ^ 3 - b) * ypp(i + 1).Value) * (h0 ^ 2) / 6#

Cspline_Eval = Yout
err_ret:
End Function


Private Sub OrderNodes(Xin As Range, Yin As Range, x#(), y#())
'populate and order the input arrays
Dim n&, i&, tmp()
n = Xin.Cells.Count
ReDim tmp(1 To n, 1 To 2)
For i = 1 To n
    tmp(i, 1) = CDbl_(Xin(i))
    tmp(i, 2) = CDbl_(Yin(i))
Next i
 
MatrixSort tmp
 
For i = 1 To n
    x(i) = tmp(i, 1)
    y(i) = tmp(i, 2)
Next i
 
 
End Sub
VBA Filename Integration.bas Extracted Macro
'=======================================================================================
'Module for Integral, Serie, and Discrete Fourier Transform
'ver 3.1 , March-2006, by Foxes Team
'=======================================================================================
Option Explicit

'Public Variables only avail to this Module
Dim func_count

Function DFSP(Samples, Optional db, Optional Angle)
Attribute DFSP.VB_Description = "returns the N/2 harmonics of the Discrete Fourier Spectrum from N samples"
Attribute DFSP.VB_HelpID = 197
Attribute DFSP.VB_ProcData.VB_Invoke_Func = " \n14"
'Discrete Fourier Spectrum
'mod. 11.3.06
    Dim a, U#(), i&, ro#, TETA#, Rango&, n1&, n2&, m&, x#, y#
    Const Tiny# = Ten_13
    If IsMissing(db) Then db = False
    If IsMissing(Angle) Then Angle = "RAD"
    a = Samples
    n1 = UBound(a, 1)
    n2 = UBound(a, 2)
    
    ReDim U(1 To n1, 1 To 2)
    'load samples
    For i = 1 To n1
        U(i, 1) = a(i, 1)
    Next
    If n2 > 1 Then
        For i = 1 To n1
            U(i, 2) = a(i, 2)
        Next
    End If
    
    Rango = vIntLog2(n1)
    m = 2 ^ Rango       ' campioni temporali
    If m = n1 Then
        FFT_1D Rango, U
    Else
        DFT_1D U
    End If
    PolarConversion U(1, 1), U(1, 2), ro, TETA, Angle, db, Tiny
    U(1, 1) = ro: U(1, 2) = TETA
    For i = 2 To n1
        x = -2 * U(i, 2)
        y = 2 * U(i, 1)
        PolarConversion x, y, ro, TETA, Angle, db, Tiny
        U(i, 1) = ro: U(i, 2) = TETA
    Next i
    
    DFSP = U
End Function

Function DFSP_INV(Spectrum, Optional db, Optional Angle)
Attribute DFSP_INV.VB_Description = "returns a temporal sequence of 2N samples from N harmonics spectrum"
Attribute DFSP_INV.VB_HelpID = 199
Attribute DFSP_INV.VB_ProcData.VB_Invoke_Func = " \n14"
'Discrete Fourier Spectrum
'mod. 11-3-06
    Dim a, U#(), i&, ro#, TETA#, Rango&, m
    Dim n1&, n2&, n3&, x, y
    If IsMissing(db) Then db = False
    If IsMissing(Angle) Then Angle = "RAD"
    Const Tiny# = Ten_13
    a = Spectrum
    n1 = UBound(a, 1)
    n2 = UBound(a, 2)
    n3 = 2 * n1
    ReDim U(1 To n3, 1 To 2)
    'load samples
    If db = True Then
        Rect_Conversion a(1, 1), 0, x, y, Angle, True, Tiny
        U(1, 1) = x
    Else
        U(1, 1) = a(1, 1)
    End If
    For i = 2 To n1
        If db = True Then ro = a(i, 1) - 6 Else ro = a(i, 1) / 2
        TETA = 0
        If n2 > 1 Then TETA = a(i, 2)
        Rect_Conversion ro, TETA, x, y, Angle, db
        U(i, 1) = y
        U(i, 2) = -x
        U(n3 - i + 2, 1) = y
        U(n3 - i + 2, 2) = x
    Next
   
    Rango = vIntLog2(n3)
    m = 2 ^ Rango       ' campioni temporali
    If m = n3 Then
        FFT_1D Rango, U, -1
    Else
        DFT_1D U, -1
    End If
    
    Mat_mop_up U, Tiny

    DFSP_INV = U
End Function


Function FFT(Samples, Optional central)
Attribute FFT.VB_Description = "Returns the N x 2 matrix of the FFT transform. The number of samples N must be a power of 2."
Attribute FFT.VB_HelpID = 104
Attribute FFT.VB_ProcData.VB_Invoke_Func = " \n14"
Dim a, U#(), i&, Rango&, n1&, n2&, m&, k&
Const Tiny# = Ten_14
If IsMissing(central) Then central = False
a = Samples
n1 = UBound(a, 1)
n2 = UBound(a, 2)
Rango = vIntLog2(n1)
m = 2 ^ Rango       ' campioni temporali
k = m / 2           ' campioni frequenziali
If m <> n1 Then FFT = "?": Exit Function
ReDim U(1 To m, 1 To 2)
'load samples
For i = 1 To m
    U(i, 1) = a(i, 1)
Next
If n2 > 1 Then
    For i = 1 To m: U(i, 2) = a(i, 2): Next
End If
'
FFT_1D Rango, U
'
Mat_mop_up U, Tiny
If central = True Then FT_central U
FFT = U
End Function

Sub FFT_1D(r&, h#(), Optional Inv)
'   Cooley-Tukey Radix-2 DIF Complex FFT.
'   R = Rango della Trasformata
'   H = Array campioni (m x 2)
'       Inizialmente contiene i campioni temporali.
'       Alla fine contiene i campioni frequenziali della trasformata
'   INV = if -1 compute the INV_FFT ; default 1
' mod. 22.4.2004
Dim i&, j&, k&, l&, n1&, n2&, ie&, ia&, m&, n&
Dim c#, s#, xT#, yt#, p#, a#
'
If IsMissing(Inv) Then Inv = 1
n = 2 ^ r
If n = 1 Then Exit Sub
' -------- Conjugate for inverse FFT
If Inv = -1 Then
     For i = 1 To n: h(i, 2) = -h(i, 2): Next i
End If
' -------- Butterfly algorithm  ----
p = TPi_ / n
n2 = n
For k = 1 To r
   n1 = n2
   n2 = n2 / 2
   ie = n / n1
   ia = 1
   For j = 1 To n2
      a = (ia - 1) * p
      c = Cos(a)
      s = Sin(a)
      ia = ia + ie
      For i = j To n Step n1
         l = i + n2
         xT = h(i, 1) - h(l, 1)
         h(i, 1) = h(i, 1) + h(l, 1)
         yt = h(i, 2) - h(l, 2)
         h(i, 2) = h(i, 2) + h(l, 2)
         h(l, 1) = c * xT + s * yt
         h(l, 2) = c * yt - s * xT
         'conta = conta + 1          '>>>>>>>> DEBUG
      Next i
   Next j
Next k
'
'--------- Bit reversal permutation ...
j = 1
n1 = n - 1
For i = 1 To n1
   If i < j Then
      xT = h(j, 1)
      h(j, 1) = h(i, 1)
      h(i, 1) = xT
      yt = h(j, 2)
      h(j, 2) = h(i, 2)
      h(i, 2) = yt
   End If
   k = n / 2
   Do While (k < j)
      j = j - k
      k = k / 2
   Loop
  j = j + k
Next i
'-------- Conjugate and normalize
If Inv = -1 Then
  For i = 1 To n
        h(i, 2) = -h(i, 2)
        h(i, 1) = h(i, 1)
  Next i
Else
  For i = 1 To n
        h(i, 2) = h(i, 2) / n
        h(i, 1) = h(i, 1) / n
  Next i
End If
'Debug.Print conta  '<<<<<<<<<<<<<<<< DEBUG
End Sub

Function FFT_INV(Samples, Optional central)
Attribute FFT_INV.VB_Description = "Returns the N samples of the FFT inverse transform. The number of samples N must be a power of 2."
Attribute FFT_INV.VB_HelpID = 105
Attribute FFT_INV.VB_ProcData.VB_Invoke_Func = " \n14"
Dim a, t#(), i&, Rango&, n1&, n2&, m
Const Tiny# = Ten_14
If IsMissing(central) Then central = False
a = Samples
If central = True Then FT_lateral a
n1 = UBound(a, 1)
n2 = UBound(a, 2)
Rango = vIntLog2(n1)
m = 2 ^ Rango       ' campioni temporali
If m <> n1 Then FFT_INV = "?": Exit Function
ReDim t(1 To m, 1 To 2)
'load samples
For i = 1 To m
    t(i, 1) = a(i, 1)
    t(i, 2) = 0
Next
If n2 > 1 Then
    For i = 1 To m
        t(i, 2) = a(i, 2)
    Next
End If

FFT_1D Rango, t, -1

Mat_mop_up t, Tiny

FFT_INV = t
End Function

Sub DFT_1D(a, Optional Inv)
'   A = vettore campioni  (M x 2)
'   INV = if -1 compute the INV_DFT ; default 1
'mod 20.2.2004
Dim i&, amax&, amin&, m&, k&, j&, c#
Dim somma1#, somma2#, BETA#, ALFA#, a11#, a21#, a12#, a22#
Dim seno#, coseno#
Dim b()
If IsMissing(Inv) Then
    Inv = 1
Else
    Inv = -1
End If

amax = UBound(a, 1)
amin = LBound(a, 1)
ReDim b(amin To amax, 1 To 2)

'   M = numero campioni temporali
'   K = numero campioni frequenziali
m = amax - amin + 1
k = amax - amin + 1

ALFA = -Inv * TPi_ / m ' angolo DFT

For i = 1 To k
    somma1 = 0
    somma2 = 0
    BETA = ALFA * (i - 1)
    a11 = Cos(BETA): a21 = Sin(BETA): a12 = -a21: a22 = a11
    coseno = 1: seno = 0
    For j = 1 To m
        somma1 = a(j, 1) * coseno - a(j, 2) * seno + somma1
        somma2 = a(j, 1) * seno + a(j, 2) * coseno + somma2
        c = a11 * coseno + a12 * seno
        seno = a21 * coseno + a22 * seno
        coseno = c
    Next j
    If Inv = 1 Then
        b(i, 1) = 1 / m * somma1
        b(i, 2) = 1 / m * somma2
    Else
        b(i, 1) = somma1
        b(i, 2) = somma2
    End If
Next i
'load A
For i = 1 To k
    a(i, 1) = b(i, 1)
    a(i, 2) = b(i, 2)
Next
End Sub

Function DFT(Samples, Optional central)
Attribute DFT.VB_Description = "returns the N x 2 matrix of the DFT transformation of N samples."
Attribute DFT.VB_HelpID = 104
Attribute DFT.VB_ProcData.VB_Invoke_Func = " \n14"
Dim a, t#(), m&, m1&, i&
Const Tiny# = 5 * Ten_13
If IsMissing(central) Then central = False
a = Samples
m = UBound(a, 1)
m1 = UBound(a, 2)
ReDim t(1 To m, 1 To 2)
'load samples
For i = 1 To m
    t(i, 1) = a(i, 1)
Next
If m1 > 1 Then
    For i = 1 To m: t(i, 2) = a(i, 2): Next
End If
'
DFT_1D t
'
Mat_mop_up t, Tiny
If central = True Then FT_central t
DFT = t
End Function

Function DFT_INV(Samples, Optional central)
Attribute DFT_INV.VB_Description = "returns the N samples of the Inverse DFT transformation"
Attribute DFT_INV.VB_HelpID = 105
Attribute DFT_INV.VB_ProcData.VB_Invoke_Func = " \n14"
Dim a, t#(), m&, m1&, i&
Const Tiny# = 5 * Ten_13
If IsMissing(central) Then central = False
a = Samples
If central = True Then FT_lateral a
m = UBound(a, 1)
m1 = UBound(a, 2)
ReDim t(1 To m, 1 To 2)
'load samples
For i = 1 To m
    t(i, 1) = a(i, 1)
Next
If m1 > 1 Then
    For i = 1 To m: t(i, 2) = a(i, 2): Next
End If

DFT_1D t, -1

Mat_mop_up t, Tiny

DFT_INV = t
End Function

Sub FFT_2D(a, Ur#(), Ui#(), Optional Inv)
Dim n&, m&, i&, j&, k&, tmp#, v#(), rn&, RM&, n1&

If IsMissing(Inv) Then Inv = 1
n1 = UBound(a, 1)
m = UBound(a, 2)
n = n1 / 2
rn = vIntLog2(n)
RM = vIntLog2(m)

ReDim Ur(1 To n, 1 To m), Ui(1 To n, 1 To m)
    
For i = 1 To n
    ReDim v(1 To m, 1 To 2)
    For j = 1 To m: v(j, 1) = a(i, j): Next j
    For j = 1 To m: v(j, 2) = a(n + i, j): Next j
    '
    FFT_1D RM, v, Inv
    '
    For j = 1 To m
           Ur(i, j) = v(j, 1)
           Ui(i, j) = v(j, 2)
    Next j
Next i

For j = 1 To m
    ReDim v(1 To n, 1 To 2)
    For i = 1 To n
           v(i, 1) = Ur(i, j)
           v(i, 2) = Ui(i, j)
    Next i
    '
    FFT_1D rn, v, Inv
    '