program main !*****************************************************************************80 ! !! MAIN is the main program for SLATEC_PRB. ! ! Discussion: ! ! SLATEC_PRB tests the SLATEC library. ! ! Modified: ! ! 02 February 2007 ! ! Local Parameters: ! ! integer KPRINT, controls the amount of output. ! 0 Quick checks - No printing. ! Driver - Short pass or fail message printed. ! 1 Quick checks - No message printed for passed tests, ! short message printed for failed tests. ! Driver - Short pass or fail message printed. ! 2 Quick checks - Print short message for passed tests, ! fuller information for failed tests. ! Driver - Pass or fail message printed. ! 3 Quick checks - Print complete quick check results. ! Driver - Pass or fail message printed. ! implicit none integer :: kprint = 0 call timestamp ( ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'SLATEC_PRB' write ( *, '(a)' ) ' FORTRAN90 version' write ( *, '(a)' ) ' Tests for the SLATEC library.' write ( *, '(a)' ) ' ' call test01 ( kprint ) call test02 ( kprint ) call test03 ( kprint ) call test04 ( kprint ) call test05 ( kprint ) call test06 ( kprint ) call test07 ( kprint ) call test08 ( kprint ) call test09 ( kprint ) call test10 ( kprint ) call test11 ( kprint ) call test12 ( kprint ) call test13 ( kprint ) call test14 ( kprint ) call test15 ( kprint ) call test16 ( kprint ) ! ! Having problems with DQDOT test. ! ! call test17 ( kprint ) call test18 ( kprint ) call test19 ( kprint ) call test20 ( kprint ) call test21 ( kprint ) call test22 ( kprint ) call test23 ( kprint ) call test24 ( kprint ) call test25 ( kprint ) call test26 ( kprint ) call test27 ( kprint ) call test28 ( kprint ) call test29 ( kprint ) call test30 ( kprint ) call test31 ( kprint ) call test32 ( kprint ) call test33 ( kprint ) call test34 ( kprint ) call test35 ( kprint ) call test36 ( kprint ) call test37 ( kprint ) call test38 ( kprint ) call test39 ( kprint ) call test40 ( kprint ) call test41 ( kprint ) call test42 ( kprint ) call test43 ( kprint ) call test44 ( kprint ) call test45 ( kprint ) call test46 ( kprint ) call test47 ( kprint ) call test48 ( kprint ) call test49 ( kprint ) call test50 ( kprint ) call test51 ( kprint ) call test52 ( kprint ) call test53 ( kprint ) call test54 ( kprint ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'SLATEC_PRB' write ( *, '(a)' ) ' Normal end of execution.' write ( *, '(a)' ) ' ' call timestamp ( ) stop end subroutine test01 ( kprint ) !*****************************************************************************80 ! !! TEST01 tests AAAAAA. ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if call QC6A ( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if if ( nfail == 0 ) then write ( LUN, '(a)' ) 'TEST01 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST01 *************') end subroutine test02 ( kprint ) !*****************************************************************************80 ! !! TEST02 tests the single precision Fullerton routines. ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if call SFNCK( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST02 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST02 *************') end subroutine test03 ( kprint ) !*****************************************************************************80 ! !! TEST03 tests the double precision Fullerton routines. ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if call DFNCK( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST03 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST03 *************') end subroutine test04 ( kprint ) !*****************************************************************************80 ! !! TEST04 tests the complex Fullerton routines. ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if call CFNCK( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST04 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST04 *************') END subroutine test05 ( kprint ) !*****************************************************************************80 ! !! TEST05 tests BESI, BESJ, BESK, BESY, EXINT and GAUS8. ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if call EG8CK( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if call BIKCK( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if call BJYCK( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST05 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST05 *************') end subroutine test06 ( kprint ) !*****************************************************************************80 ! !! TEST06 tests DBESI, DBESJ, DBESK, DBESY, DEXINT and DGAUS8. ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if call DEG8CK( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if call DBIKCK( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if call DBJYCK( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST06 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST06 *************') END subroutine test07 ( kprint ) !*****************************************************************************80 ! !! TEST07 tests the single precision special function routines. ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if call QCKIN( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if call QCPSI( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST07 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST07 *************') END subroutine test08 ( kprint ) !*****************************************************************************80 ! !! TEST08 tests the double precision special function routines. ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if call DQCKIN( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if call DQCPSI( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST08 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST08 *************') end subroutine test09 ( kprint ) !*****************************************************************************80 ! !! TEST09 tests the single precision complex Bessel functions. ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if call CQCAI( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if call CQCBH( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if ! ! This test has caused overflow in some cases. ! call CQCBI( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if call CQCBJ( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if call CQCBK( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if call CQCBY( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST09 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST09 *************') end subroutine test10 ( kprint ) !*****************************************************************************80 ! !! TEST10 tests the double precision complex Bessel functions. ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if call ZQCAI( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if call ZQCBH( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if call ZQCBI( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if call ZQCBJ( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if call ZQCBK( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if call ZQCBY( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST10 passed all tests.' else write (LUN, 9010) nfail end if return 9000 FORMAT (/' --------------TEST10 passed all tests.') 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST10 *************') end subroutine test11 ( kprint ) !*****************************************************************************80 ! !! TEST11 tests XLEGF and XNRMP. ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if call FCNQX1 (LUN, KPRINT, IPASS) if ( ipass == 0 ) then nfail = nfail + 1 end if if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST11 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST11 *************') end subroutine test12 ( kprint ) !*****************************************************************************80 ! !! TEST12 tests DXLEGF and DXNRMP. ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if call FCNQX2 (LUN, KPRINT, IPASS) if ( ipass == 0 ) then nfail = nfail + 1 end if if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST12 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST12 *************') end subroutine test13 ( kprint ) !*****************************************************************************80 ! !! TEST13 tests single precision Carlson elliptic routines RC, RD, RF and RJ. ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if call QCRC( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if call QCRD( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if call QCRF( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if call QCRJ( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST13 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST13 *************') end subroutine test14 ( kprint ) !*****************************************************************************80 ! !! TEST14 tests double precision Carlson elliptic routines DRC, DRD, DRF and DRJ. ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if call QCDRC( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if call QCDRD( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if call QCDRF( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if call QCDRJ( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST14 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST14 *************') end subroutine test15 ( kprint ) !*****************************************************************************80 ! !! TEST15 tests single precision 3J6J routines, RC3JJ, RC3JM and RC6J. ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if call QC36J(LUN, KPRINT, IPASS) if ( ipass == 0 ) then nfail = nfail + 1 end if if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST15 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST15 *************') END subroutine test16 ( kprint ) !*****************************************************************************80 ! !! TEST16 tests double precision 3J6J routines, DC3JJ, DC3JM and DC6J. ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if call DQC36J(LUN, KPRINT, IPASS) if ( ipass == 0 ) then nfail = nfail + 1 end if if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST16 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST16 *************') END subroutine test17 ( kprint ) !*****************************************************************************80 ! !! TEST17 tests the BLAS. ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if call BLACHK ( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST17 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST17 *************') end subroutine test18 ( kprint ) !*****************************************************************************80 ! !! TEST18 tests single precision Level 2 and 3 BLAS routines. ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if call SBLAT2 (LUN, KPRINT, IPASS) if ( ipass == 0 ) then nfail = nfail + 1 end if call SBLAT3 (LUN, KPRINT, IPASS) if ( ipass == 0 ) then nfail = nfail + 1 end if if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST18 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST18 *************') end subroutine test19 ( kprint ) !*****************************************************************************80 ! !! TEST19 tests double precision Level 2 and 3 BLAS routines. ! ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if call DBLAT2 (LUN, KPRINT, IPASS) if ( ipass == 0 ) then nfail = nfail + 1 end if call DBLAT3 (LUN, KPRINT, IPASS) if ( ipass == 0 ) then nfail = nfail + 1 end if if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST19 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST19 *************') end subroutine test20 ( kprint ) !*****************************************************************************80 ! !! TEST20 tests complex Level 2 and 3 BLAS routines. ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if call CBLAT2 (LUN, KPRINT, IPASS) if ( ipass == 0 ) then nfail = nfail + 1 end if call CBLAT3 (LUN, KPRINT, IPASS) if ( ipass == 0 ) then nfail = nfail + 1 end if if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST20 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST20 *************') end subroutine test21 ( kprint ) !*****************************************************************************80 ! !! TEST21 tests the LINPACK routines. ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nerr integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if call SGEQC(LUN,KPRINT,NERR) nfail = nfail + NERR call DGEQC(LUN,KPRINT,NERR) nfail = nfail + NERR call CGEQC(LUN,KPRINT,NERR) ! ! Write PASS or FAIL message ! nfail = nfail + NERR if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST21 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST21 *************') end subroutine test22 ( kprint ) !*****************************************************************************80 ! !! TEST22 tests the LINPACK routines. ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nerr integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if call SQCK(LUN,KPRINT,NERR) nfail = nfail+NERR call DQCK(LUN,KPRINT,NERR) nfail = nfail+NERR call CQCK(LUN,KPRINT,NERR) ! ! Write PASS or FAIL message ! nfail = nfail+NERR if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST22 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST22 *************') end subroutine test23 ( kprint ) !*****************************************************************************80 ! !! TEST23 tests the LINPACK routines. ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nerr integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if call CGECK(LUN,KPRINT,NERR) nfail = nfail + NERR call CGBQC(LUN,KPRINT,NERR) nfail = nfail + NERR call CPOQC(LUN,KPRINT,NERR) nfail = nfail + NERR call CPPQC(LUN,KPRINT,NERR) nfail = nfail + NERR call CPBQC(LUN,KPRINT,NERR) nfail = nfail + NERR call CSIQC(LUN,KPRINT,NERR) nfail = nfail + NERR call CSPQC(LUN,KPRINT,NERR) nfail = nfail + NERR call CHIQC(LUN,KPRINT,NERR) nfail = nfail + NERR call CHPQC(LUN,KPRINT,NERR) nfail = nfail + NERR call CTRQC(LUN,KPRINT,NERR) nfail = nfail + NERR call CGTQC(LUN,KPRINT,NERR) nfail = nfail + NERR call CPTQC(LUN,KPRINT,NERR) nfail = nfail + NERR call CCHQC(LUN,KPRINT,NERR) nfail = nfail + NERR call CQRQC(LUN,KPRINT,NERR) nfail = nfail + NERR call CSVQC(LUN,KPRINT,NERR) ! ! Write PASS or FAIL message ! nfail = nfail + NERR if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST23 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST23 *************') end subroutine test24 ( kprint ) !*****************************************************************************80 ! !! TEST24 tests CGEEV, CHIEV, SGEEV, SSIEV, and SSPEV. ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if call EISQX1( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if call EISQX2( lun, kprint, ipass ) ! ! Write PASS or FAIL message ! if ( ipass == 0 ) then nfail = nfail + 1 end if if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST24 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST24 *************') end subroutine test25 ( kprint ) !*****************************************************************************80 ! !! TEST25 tests single precision SLAP. ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail EXTERNAL SLAPQC, XERMAX, XSETF, XSETUN lun = i1mach(2) lin = i1mach(1) nfail = 0 call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if call xermax ( 1000 ) call SLAPQC( lun, kprint, ipass ) ! ! Write PASS or FAIL message ! if ( ipass == 0 ) then nfail = nfail + 1 end if if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST25 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST25 *************') END subroutine test26 ( kprint ) !*****************************************************************************80 ! !! TEST26 tests double precision SLAP. ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail EXTERNAL DLAPQC, XERMAX, XSETF, XSETUN lun = i1mach(2) lin = i1mach(1) nfail = 0 call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if call xermax ( 1000 ) call DLAPQC( lun, kprint, ipass ) ! ! Write PASS or FAIL message ! if ( ipass == 0 ) then nfail = nfail + 1 end if if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST26 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST26 *************') END subroutine test27 ( kprint ) !*****************************************************************************80 ! !! TEST27 test LSEI and SGLSS. ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if call LSEIQX( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if call QCGLSS( lun, kprint, ipass ) ! ! Write PASS or FAIL message ! if ( ipass == 0 ) then nfail = nfail + 1 end if if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST27 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST27 *************') END subroutine test28 ( kprint ) !*****************************************************************************80 ! !! TEST28 tests DLSEI and DGLSS. ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if call DLSEIT( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if call DQCGLS( lun, kprint, ipass ) ! ! Write PASS or FAIL message ! if ( ipass == 0 ) then nfail = nfail + 1 end if if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST28 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST28 *************') END subroutine test29 ( kprint ) !*****************************************************************************80 ! !! TEST29 tests POLINT, POLCOF, POLYVL, DPLINT, DPOLCF and DPOLVL. ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if call PNTCHK( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if call DPNTCK( lun, kprint, ipass ) ! ! Write PASS or FAIL message ! if ( ipass == 0 ) then nfail = nfail + 1 end if if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST29 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST29 *************') END subroutine test30 ( kprint ) !*****************************************************************************80 ! !! TEST30 tests the single precision B-Spline package. ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if call BSPCK( lun, kprint, ipass ) ! ! Write PASS or FAIL message ! if ( ipass == 0 ) then nfail = nfail + 1 end if if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST30 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST30 *************') END subroutine test31 ( kprint ) !*****************************************************************************80 ! !! TEST31 tests the double precision B-Spline package. ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if call DBSPCK( lun, kprint, ipass ) ! ! Write PASS or FAIL message ! if ( ipass == 0 ) then nfail = nfail + 1 end if if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST31 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST31 *************') END subroutine test32 ( kprint ) !*****************************************************************************80 ! !! TEST32 tests PCHIP. ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail LUN = i1mach(2) LIN = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) ! ! Test PCHIP evaluators ! end if call PCHQK1( lun, kprint, ipass ) ! ! Test PCHIP integrators ! if ( ipass == 0 ) then nfail = nfail + 1 end if call PCHQK2( lun, kprint, ipass ) ! ! Test PCHIP interpolators ! if ( ipass == 0 ) then nfail = nfail + 1 end if call PCHQK3( lun, kprint, ipass ) ! ! Test PCHIP monotonicity checker ! if ( ipass == 0 ) then nfail = nfail + 1 end if call PCHQK4( lun, kprint, ipass ) ! ! Test PCH to B-spline conversion. ! if ( ipass == 0 ) then nfail = nfail + 1 end if call PCHQK5( lun, kprint, ipass ) ! ! Write PASS or FAIL message ! if ( ipass == 0 ) then nfail = nfail + 1 end if if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST32 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST32 *************') END subroutine test33 ( kprint ) !*****************************************************************************80 ! !! TEST33 tests DPCHIP. ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail LUN = i1mach(2) LIN = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if ! ! Test DPCHIP evaluators ! call DPCHQ1( lun, kprint, ipass ) ! ! Test DPCHIP integrators ! if ( ipass == 0 ) then nfail = nfail + 1 end if call DPCHQ2( lun, kprint, ipass ) ! ! Test DPCHIP interpolators ! if ( ipass == 0 ) then nfail = nfail + 1 end if call DPCHQ3( lun, kprint, ipass ) ! ! Test DPCHIP monotonicity checker ! if ( ipass == 0 ) then nfail = nfail + 1 end if call DPCHQ4( lun, kprint, ipass ) ! ! Test PCH to B-spline conversion. ! if ( ipass == 0 ) then nfail = nfail + 1 end if call DPCHQ5( lun, kprint, ipass ) ! ! Write PASS or FAIL message ! if ( ipass == 0 ) then nfail = nfail + 1 end if if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST33 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST33 *************') END subroutine test34 ( kprint ) !*****************************************************************************80 ! !! TEST34 tests CPQR79, CPZERO, DFZERO, FZERO. RPQR79 and RPZERO. ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if call CPRPQX( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if call FZTEST( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if call DFZTST( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if call RQRTST( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if call CQRTST( lun, kprint, ipass ) ! ! Write PASS or FAIL message ! if ( ipass == 0 ) then nfail = nfail + 1 end if if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST34 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST34 *************') end subroutine test35 ( kprint ) !*****************************************************************************80 ! !! TEST35 tests SNSQ, SNSQE, and SOS. ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if call SNSQQK( lun, kprint, ipass ) if ( ipass == 0) nfail = nfail + 1 call SOSNQX( lun, kprint, ipass ) ! ! Write PASS or FAIL message ! if ( ipass == 0) nfail = nfail + 1 if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST35 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST35 *************') end subroutine test36 ( kprint ) !*****************************************************************************80 ! !! TEST36 tests DNSQ, DNSQE, and DSOS. ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if call DNSQQK( lun, kprint, ipass ) if ( ipass == 0) nfail = nfail + 1 call DSOSQX( lun, kprint, ipass ) ! ! Write PASS or FAIL message ! if ( ipass == 0 ) then nfail = nfail + 1 end if if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST36 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST36 *************') END subroutine test37 ( kprint ) !*****************************************************************************80 ! !! TEST37 tests the SPLP and SBOCLS packages. ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if call SPLPQX( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if call SBOCQX( lun, kprint, ipass ) ! ! Write PASS or FAIL message ! if ( ipass == 0 ) then nfail = nfail + 1 end if if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST37 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST37 *************') END subroutine test38 ( kprint ) !*****************************************************************************80 ! !! TEST38 tests the DSPLP and DBOCLS packages. ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if call DPLPQX( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if call DBOCQX( lun, kprint, ipass ) ! ! Write PASS or FAIL message ! if ( ipass == 0 ) then nfail = nfail + 1 end if if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST38 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST38 *************') END subroutine test39 ( kprint ) !*****************************************************************************80 ! !! TEST39 tests single precision QUADPACK routines. ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) ! ! Test QAG. ! end if call CQAG (LUN, KPRINT, IPASS) ! ! Test QAGS. ! if ( ipass == 0 ) then nfail = nfail + 1 end if call CQAGS (LUN, KPRINT, IPASS) ! ! Test QAGP. ! if ( ipass == 0 ) then nfail = nfail + 1 end if call CQAGP (LUN, KPRINT, IPASS) ! ! Test QAGI. ! if ( ipass == 0 ) then nfail = nfail + 1 end if call CQAGI (LUN, KPRINT, IPASS) ! ! Test QAWO. ! if ( ipass == 0 ) then nfail = nfail + 1 end if call CQAWO (LUN, KPRINT, IPASS) ! ! Test QAWF. ! if ( ipass == 0 ) then nfail = nfail + 1 end if call CQAWF (LUN, KPRINT, IPASS) ! ! Test QAWS. ! if ( ipass == 0 ) then nfail = nfail + 1 end if call CQAWS (LUN, KPRINT, IPASS) ! ! Test QAWC. ! if ( ipass == 0 ) then nfail = nfail + 1 end if call CQAWC (LUN, KPRINT, IPASS) ! ! Test QNG. ! if ( ipass == 0 ) then nfail = nfail + 1 end if call CQNG (LUN, KPRINT, IPASS) ! ! Write PASS or FAIL message ! if ( ipass == 0 ) then nfail = nfail + 1 end if if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST39 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST39 *************') end subroutine test40 ( kprint ) !*****************************************************************************80 ! !! TEST40 tests the double precision QUADPACK routines. ! ! Modified: ! ! 18 May 2007 ! ! Author: ! ! John Burkardt ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if ! ! Test DQAG. ! call CDQAG (LUN, KPRINT, IPASS) ! ! Test DQAGS. ! if ( ipass == 0 ) then nfail = nfail + 1 end if call CDQAGS (LUN, KPRINT, IPASS) ! ! Test DQAGP. ! if ( ipass == 0 ) then nfail = nfail + 1 end if call CDQAGP (LUN, KPRINT, IPASS) ! ! Test DQAGI. ! if ( ipass == 0 ) then nfail = nfail + 1 end if call CDQAGI (LUN, KPRINT, IPASS) ! ! Test DQAWO. ! if ( ipass == 0 ) then nfail = nfail + 1 end if call CDQAWO (LUN, KPRINT, IPASS) ! ! Test DQAWF. ! if ( ipass == 0 ) then nfail = nfail + 1 end if call CDQAWF (LUN, KPRINT, IPASS) ! ! Test DQAWS. ! if ( ipass == 0 ) then nfail = nfail + 1 end if call CDQAWS (LUN, KPRINT, IPASS) ! ! Test DQAWC. ! if ( ipass == 0 ) then nfail = nfail + 1 end if call CDQAWC (LUN, KPRINT, IPASS) ! ! Test DQNG. ! if ( ipass == 0 ) then nfail = nfail + 1 end if call CDQNG (LUN, KPRINT, IPASS) ! ! Write PASS or FAIL message ! if ( ipass == 0 ) then nfail = nfail + 1 end if if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST40 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST40 *************') end subroutine test41 ( kprint ) !*****************************************************************************80 ! !! TEST41 tests AVINT, GAUS8 and QNC79. ! ! Modified: ! ! 18 May 2007 ! ! Author: ! ! John Burkardt ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if call AVNTST( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if call QG8TST( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if call QN79QX( lun, kprint, ipass ) ! ! Write PASS or FAIL message ! if ( ipass == 0 ) then nfail = nfail + 1 end if if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST41 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST41 *************') END subroutine test42 ( kprint ) !*****************************************************************************80 ! !! TEST42 tests DAVINT, DGAUS8 and DQNC79. ! ! Modified: ! ! 18 May 2007 ! ! Author: ! ! John Burkardt ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if call DAVNTS( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if call DQG8TS( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if call DQN79Q( lun, kprint, ipass ) ! ! Write PASS or FAIL message ! if ( ipass == 0 ) then nfail = nfail + 1 end if if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST42 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST42 *************') END subroutine test43 ( kprint ) !*****************************************************************************80 ! !! TEST43 tests DEABM, DEBDF, DERKF, BVSUP. ! ! Modified: ! ! 18 May 2007 ! ! Author: ! ! John Burkardt ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if call QXABM( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if call QXBDF( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if call QXRKF( lun, kprint, ipass ) if ( ipass == 0 ) then nfail = nfail + 1 end if call QXBVSP( lun, kprint, ipass ) ! ! Write PASS or FAIL message ! if ( ipass == 0) nfail = nfail + 1 if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST43 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST43 *************') END subroutine test44 ( kprint ) !*****************************************************************************80 ! !! TEST44 tests DDEABM, DDEBDF, DDERKF and DBVSUP. ! ! Modified: ! ! 18 May 2007 ! ! Author: ! ! John Burkardt ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if call QXDABM( lun, kprint, ipass ) if ( ipass == 0) nfail = nfail + 1 call QXDBDF( lun, kprint, ipass ) if ( ipass == 0) nfail = nfail + 1 call QXDRKF( lun, kprint, ipass ) if ( ipass == 0) nfail = nfail + 1 call QXDBVS( lun, kprint, ipass ) ! ! Write PASS or FAIL message ! if ( ipass == 0) nfail = nfail + 1 if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST44 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST44 *************') end subroutine test45 ( kprint ) !*****************************************************************************80 ! !! TEST45 tests single precision SDRIVE. ! ! Modified: ! ! 18 May 2007 ! ! Author: ! ! John Burkardt ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if call SDQCK(LUN, KPRINT, IPASS) ! ! Write PASS or FAIL message ! if ( ipass == 0) nfail = nfail + 1 if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST45 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST45 *************') end subroutine test46 ( kprint ) !*****************************************************************************80 ! !! TEST46 tests double precision SDRIVE. ! ! Modified: ! ! 18 May 2007 ! ! Author: ! ! John Burkardt ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if call DDQCK(LUN, KPRINT, IPASS) ! ! Write PASS or FAIL message ! if ( ipass == 0) nfail = nfail + 1 if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST46 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST46 *************') end subroutine test47 ( kprint ) !*****************************************************************************80 ! !! TEST47 tests complex SDRIVE. ! ! Modified: ! ! 18 May 2007 ! ! Author: ! ! John Burkardt ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if call CDQCK(LUN, KPRINT, IPASS) ! ! Write PASS or FAIL message ! if ( ipass == 0) nfail = nfail + 1 if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST47 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST47 *************') end subroutine test48 ( kprint ) !*****************************************************************************80 ! !! TEST48 tests SDASSL. ! ! Modified: ! ! 18 May 2007 ! ! Author: ! ! John Burkardt ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if call xermax ( 1000 ) call sdasqc ( lun, kprint, ipass ) ! ! Write PASS or FAIL message ! if ( ipass == 0) then nfail = nfail + 1 end if if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST48 passed all tests.' else write ( lun, 9010 ) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST48 *************') end subroutine test49 ( kprint ) !*****************************************************************************80 ! !! TEST49 tests DDASSL. ! ! Modified: ! ! 18 May 2007 ! ! Author: ! ! John Burkardt ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if call xermax ( 1000 ) call DDASQC( lun, kprint, ipass ) ! ! Write PASS or FAIL message ! if ( ipass == 0 ) then nfail = nfail + 1 end if if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST49 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST49 *************') end subroutine test50 ( kprint ) !*****************************************************************************80 ! !! TEST50 tests FISHPACK. ! ! Modified: ! ! 18 May 2007 ! ! Author: ! ! John Burkardt ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) ! ! Test HWSCRT ! end if call QXCRT( lun, kprint, ipass ) ! ! Test HWSPLR ! if ( ipass == 0) nfail = nfail + 1 call QXPLR( lun, kprint, ipass ) ! ! Test HWSCYL ! if ( ipass == 0) nfail = nfail + 1 call QXCYL( lun, kprint, ipass ) ! ! Test HWSSSP ! if ( ipass == 0) nfail = nfail + 1 call QXSSP( lun, kprint, ipass ) ! ! Test HWSCSP ! if ( ipass == 0) nfail = nfail + 1 call QXCSP( lun, kprint, ipass ) ! ! Test GENBUN ! if ( ipass == 0) nfail = nfail + 1 call QXGBUN( lun, kprint, ipass ) ! ! Test BLKTRI ! if ( ipass == 0) nfail = nfail + 1 call QXBLKT( lun, kprint, ipass ) ! ! Write PASS or FAIL message ! if ( ipass == 0 ) then nfail = nfail + 1 end if if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST50 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST50 *************') end subroutine test51 ( kprint ) !*****************************************************************************80 ! !! TEST51 tests the FFT package. ! ! Modified: ! ! 18 May 2007 ! ! Author: ! ! John Burkardt ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if call FFTQX( lun, kprint, ipass ) ! ! Write PASS or FAIL message ! if ( ipass == 0) then nfail = nfail + 1 end if if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST51 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST51 *************') end subroutine test52 ( kprint ) !*****************************************************************************80 ! !! TEST52 tests SNLS1E, SNLS1, FC, BVALU, CV, POLFIT, PCOEF and PVALUE. ! ! Modified: ! ! 18 May 2007 ! ! Author: ! ! John Burkardt ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if ! ! Test SNLS1E and SNLS1 ! call SNLS1Q( lun, kprint, ipass ) ! ! Test FC (also BVALU and CV) ! if ( ipass == 0 ) then nfail = nfail + 1 end if call FCQX( lun, kprint, ipass ) ! ! Test POLFIT (also PCOEF and PVALUE) ! if ( ipass == 0) nfail = nfail + 1 call PFITQX( lun, kprint, ipass ) ! ! Write PASS or FAIL message ! if ( ipass == 0) nfail = nfail + 1 if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST52 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST52 *************') end subroutine test53 ( kprint ) !*****************************************************************************80 ! !! TEST53 tests DNLS1E, DNLS1, DFC, DBVALU, DCV, DPOLFT, DPCOEF and DPLV1U. ! ! Modified: ! ! 18 May 2007 ! ! Author: ! ! John Burkardt ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if call DNLS1Q( lun, kprint, ipass ) if ( ipass == 0) nfail = nfail + 1 call DFCQX( lun, kprint, ipass ) if ( ipass == 0) nfail = nfail + 1 call DPFITT( lun, kprint, ipass ) ! ! Write PASS or FAIL message ! if ( ipass == 0) nfail = nfail + 1 if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST53 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST53 *************') end subroutine test54 ( kprint ) !*****************************************************************************80 ! !! TEST54 tests the sort routines ISORT, IPSORT, IPPERM and so on. ! ! Modified: ! ! 18 May 2007 ! ! Author: ! ! John Burkardt ! implicit none integer i1mach integer ipass integer kprint integer lin integer lun integer nfail lun = i1mach(2) lin = i1mach(1) nfail = 0 call xermax ( 1000 ) call xsetun ( lun ) if ( kprint <= 1 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if ! ! Test ISORT, IPSORT and IPPERM ! call ISRTQC(LUN, KPRINT, IPASS) ! ! Test SSORT, SPSORT and SPPERM ! if ( ipass == 0) nfail = nfail + 1 call SSRTQC(LUN, KPRINT, IPASS) ! ! Test DSORT, DPSORT and DPPERM ! if ( ipass == 0) nfail = nfail + 1 call DSRTQC(LUN, KPRINT, IPASS) ! ! Test HPSORT and HPPERM ! if ( ipass == 0) nfail = nfail + 1 call HSRTQC(LUN, KPRINT, IPASS) ! ! Write PASS or FAIL message ! if ( ipass == 0) nfail = nfail + 1 if ( nfail == 0 ) then write ( lun, '(a)' ) 'TEST54 passed all tests.' else write (LUN, 9010) nfail end if return 9010 FORMAT (/' ************* WARNING -- ', I5, & ' TEST(S) FAILED IN PROGRAM TEST54 *************') end subroutine AVNTST ( lun, kprint, ipass ) !*****************************************************************************80 ! !! AVNTST is a quick check for AVINT. ! !***PURPOSE Quick check for AVINT. !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (AVNTST-S, DAVNTS-D) !***AUTHOR (UNKNOWN) !***ROUTINES CALLED AVINT, R1MACH, XERCLR, XGETF, XSETF !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 890911 Removed unnecessary intrinsics. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901205 Changed usage of R1MACH(3) to R1MACH(4). (RWC) ! 910501 Added PURPOSE and TYPE records. (WRB) ! 910708 Minor modifications in use of KPRINT. (WRB) ! 920210 Code restructured and revised to test error returns for all ! values of KPRINT. (WRB) !***END PROLOGUE AVNTST ! real a real ans real b real del logical fatal integer i integer IPASS integer LUN integer kontrl integer KPRINT integer n real R1MACH real rn1 real sqb real TOL real X(501) real xint real Y(501) if ( 2 <= kprint ) then write (LUN,9000) end if ipass = 1 TOL = max ( 0.0001E0, SQRT ( R1MACH(4) ) ) ! ! Perform first accuracy test. ! TOL1 = 1.0E-2 * TOL A = 0.0E0 B = 5.0E0 XINT = EXP ( 5.0D0 ) - 1.0D0 N = 500 RN1 = N - 1 SQB = SQRT ( B ) DEL = 0.4E0 * ( B - A ) / real ( N - 1 ) DO I = 1, N X(I) = SQB * SQRT ( A + real ( I - 1 ) * ( B - A ) / RN1 ) + DEL Y(I) = EXP ( X(I) ) end do ! ! See if test was passed. ! call AVINT ( X, Y, N, A, B, ANS, IERR ) if ( tol < ABS ( ANS - XINT ) ) then ipass = 0 if ( 3 <= kprint ) then write (LUN,9010) IERR, ANS, XINT end if end if ! ! Perform second accuracy test. ! X(1) = 0.0E0 X(2) = 5.0E0 Y(1) = 1.0E0 Y(2) = 0.5E0 A = -0.5E0 B = 0.5E0 XINT = 1.0E0 ! ! See if test was passed. ! call AVINT ( X, Y, 2, A, B, ANS, IERR ) if ( TOL1 < ABS ( ANS - XINT ) ) then ipass = 0 if ( 3 <= kprint ) then write (LUN,9010) IERR, ANS, XINT end if end if ! ! Send message indicating passage or failure of tests. ! if ( 2 <= kprint ) then if ( ipass == 1 ) then if ( 3 <= kprint ) then write (LUN,9020) end if else write (LUN,9030) end if end if ! ! Test error returns. ! call XGETF ( KONTRL ) if ( kprint <= 2 ) then call XSETF (0) else call XSETF (1) end if FATAL = .FALSE. call xerclr if ( 3 <= kprint ) then write (LUN,9040) end if DO I = 1, 20 X(I) = real ( I - 1 ) / 19.0E0 - 0.01E0 if ( I == 1 ) then Y(I) = 1.0E0 else Y(I) = X(I) / ( EXP ( X(I) ) - 1.0 ) end if end do ! ! Test IERR = 1 error return. ! call AVINT ( X, Y, 20, 0.0E0, 1.0E0, ANS, IERR ) if ( IERR /= 1 ) then ipass = 0 FATAL = .TRUE. if ( 3 <= kprint ) then write (LUN,9060) IERR, 1 end if end if ! ! Test IERR = 2 error return. ! call xerclr call AVINT ( X, Y, 20, 1.0E0, 0.0E0, ANS, IERR ) if ( IERR /= 2 ) then ipass = 0 FATAL = .TRUE. if ( kprint >= 3) write (LUN,9060) IERR, 2 end if if ( ANS /= 0.0E0 ) then ipass = 0 FATAL = .TRUE. if ( kprint >= 3) write (LUN,9070) end if ! ! Test IERR = 5 error return. ! call xerclr call AVINT ( X, Y, 1, 0.0E0, 1.0E0, ANS, IERR ) if ( IERR /= 5 ) then ipass = 0 FATAL = .TRUE. if ( kprint >= 3) write (LUN,9060) IERR, 5 end if if ( ANS /= 0.0E0 ) then ipass = 0 FATAL = .TRUE. if ( kprint >= 3) write (LUN,9070) end if ! ! Test IERR = 4 error return. ! call xerclr X(1) = 1.0E0/19.0E0 X(2) = 0.0E0 call AVINT (X, Y, 20, 0.0E0, 1.0E0, ANS, IERR) if ( IERR /= 4 ) then ipass = 0 FATAL = .TRUE. if ( kprint >= 3) write (LUN,9060) IERR, 4 end if if ( ANS /= 0.0E0 ) then ipass = 0 FATAL = .TRUE. if ( kprint >= 3) write (LUN,9070) end if ! ! Test IERR = 3 error return. ! call xerclr X(1) = 0.0E0 X(2) = 1.0E0/19.0E0 call AVINT (X, Y, 20, 0.0E0, .01E0, ANS, IERR) if ( IERR /= 3 ) then ipass = 0 FATAL = .TRUE. if ( kprint >= 3) write (LUN,9060) IERR, 3 end if if ( ANS /= 0.0E0 ) then ipass = 0 FATAL = .TRUE. if ( kprint >= 3) write (LUN,9070) end if ! ! Reset XERMSG control variables and write summary. ! call xerclr call XSETF (KONTRL) if ( FATAL ) then if ( kprint >= 2 ) then write (LUN, 9080) end if else if ( kprint >= 3 ) then write (LUN, 9090) end if end if ! ! Write PASS/FAIL message. ! if ( ipass == 1 .and. KPRINT >= 3) then write (LUN,9100) end if if ( ipass == 0 .and. KPRINT >= 2) then write (LUN,9110) end if return 9000 FORMAT ('1' / ' AVINT Quick Check') 9010 FORMAT (/' FAILED ACCURACY TEST' / & ' IERR=', I2, 5X, 'COMPUTED ANS=', E20.11 / 14X, & 'CORRECT ANS=', E20.11, 5X, 'REQUESTED ERR=', E10.2) 9020 FORMAT (/ ' AVINT passed both accuracy tests.') 9030 FORMAT (/ ' AVINT failed at least one accuracy test.') 9040 FORMAT (/ ' Test error returns from AVINT' / & ' 4 error messages expected' /) 9060 FORMAT (/' IERR =', I2, ' and it should =', I2 /) 9070 FORMAT (1X, 'ANS /= 0') 9080 FORMAT (/ ' At least one incorrect argument test FAILED') 9090 FORMAT (/ ' All incorrect argument tests PASSED') 9100 FORMAT (/' ***************AVINT PASSED ALL TESTS***************') 9110 FORMAT (/' ***************AVINT FAILED SOME TESTS**************') END subroutine BIKCK (LUN, KPRINT, IPASS) !*****************************************************************************80 ! !! BIKCK is a quick check for BESI and BESK. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (BIKCK-S, DBIKCK-D) !***KEYWORDS QUICK CHECK !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! BIKCK is a quick check routine for BESI and BESK. The main loops ! evaluate the Wronskian and test the error. Underflow and overflow ! diagnostics are checked in addition to illegal arguments. ! !***ROUTINES CALLED BESI, BESK, NUMXER, R1MACH, XERCLR, XGETF, XSETF !***REVISION HISTORY (YYMMDD) ! 750101 DATE WRITTEN ! 890911 Removed unnecessary intrinsics. (WRB) ! 891004 Removed unreachable code. (WRB) ! 891004 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901013 Editorial changes, some restructing and modifications to ! obtain more information when there is failure of the ! Wronskian. (RWC) ! 910501 Added PURPOSE and TYPE records. (WRB) ! 910708 Code revised to test error returns for all values of ! KPRINT. (WRB) !***END PROLOGUE BIKCK integer I, IX, K, KONTRL, KODE, LUN, M, N, NERR, NU, NW, NY REAL ALP, DEL, ER, FNU, FNUP, RX, TOL, X REAL FN(3), W(5), XX(5), Y(5) REAL R1MACH !***FIRST EXECUTABLE STATEMENT BIKCK LOGICAL FATAL ! if ( kprint >= 2) write (LUN,90000) ipass = 1 XX(1) = 0.49E0 XX(2) = 1.3E0 XX(3) = 5.3E0 XX(4) = 13.3E0 XX(5) = 21.3E0 FN(1) = 0.095E0 FN(2) = 0.70E0 FN(3) = 0.0E0 TOL = 500.0E0*MAX(R1MACH(4), 7.1E-15) DO 60 KODE=1,2 DO 50 M=1,3 DO 40 N=1,4 DO 30 NU=1,4 FNU = FN(M) + 12*(NU-1) DO 20 IX=1,5 if ( IX < 2 .and. NU > 3) GO TO 20 X = XX(IX) RX = 1.0E0/X call BESI(X, FNU, KODE, N, Y, NY) if ( NY /= 0) GO TO 20 call BESK(X, FNU, KODE, N, W, NW) if ( NW /= 0) GO TO 20 FNUP = FNU + N call BESI(X,FNUP,KODE,1,Y(N+1),NY) if ( NY /= 0) GO TO 20 call BESK(X,FNUP,KODE,1,W(N+1),NW) if ( NW /= 0) GO TO 20 DO I=1,N ER = Y(I+1)*W(I) + W(I+1)*Y(I) - RX ER = ABS(ER)*X if ( ER > TOL ) then ipass = 0 if ( KPRINT >= 2) write (LUN,90010) KODE,M,N, & NU,IX,I,X,ER,TOL, & Y(I),Y(I+1),W(I),W(I+1) end if end do 20 continue 30 continue 40 continue 50 continue ! ! Check small values of X and order ! 60 continue N = 2 FNU = 1.0E0 X = R1MACH(4)/100.0E0 DO 80 I=1,3 DO 70 KODE=1,2 call BESI(X, FNU, KODE, N, Y, NY) call BESK(X, FNU, KODE, N, W, NW) ER = Y(2)*W(1) + W(2)*Y(1) - 1.0E0/X ER = ABS(ER)*X if ( ER > TOL ) then ipass = 0 if ( KPRINT >= 2) write (LUN,90020) I,KODE,FNU,X,ER,TOL, & Y(1),Y(2),W(1),W(2) GO TO 700 end if 70 continue 700 FNU = R1MACH(4)/100.0E0 X = XX(2*I-1) ! ! Check large values of X and order ! 80 continue KODE = 2 DO 76 K=1,2 DEL = 30*(K-1) FNU = 45.0E0+DEL DO 75 N=1,2 X = 20.0E0 + DEL DO 71 I=1,5 RX = 1.0E0/X call BESI(X, FNU, KODE, N, Y, NY) if ( NY /= 0) GO TO 71 call BESK(X, FNU, KODE, N, W, NW) if ( NW /= 0) GO TO 71 if ( N == 1 ) then FNUP = FNU + 1.0E0 call BESI(X,FNUP,KODE,1,Y(2),NY) if ( NY /= 0) GO TO 71 call BESK(X,FNUP,KODE,1,W(2),NW) if ( NW /= 0) GO TO 71 end if ER = Y(2)*W(1) + Y(1)*W(2) - RX ER = ABS(ER)*X if ( ER > TOL ) then ipass = 0 if ( KPRINT >= 2) write (LUN,90030) K,N,I,FNUP,X, & ER,TOL,Y(1),Y(2),W(1),W(2) GO TO 760 end if X = X + 10.0E0 71 continue 75 continue ! ! Check underflow flags ! 76 continue 760 X = R1MACH(1)*10.0E0 ALP = 12.3E0 N = 3 call BESI(X, ALP, 1, N, Y, NY) if ( NY /= 3 ) then ipass = 0 if ( KPRINT >= 2) write (LUN,90040) end if X = LOG(R1MACH(2)/10.0E0) + 20.0E0 ALP = 1.3E0 N = 3 call BESK(X, ALP, 1, N, W, NW) if ( NW /= 3 ) then ipass = 0 if ( KPRINT >= 2) write (LUN,90050) ! ! Trigger 10 error conditions ! end if call XGETF (KONTRL) if ( kprint <= 2 ) then call XSETF (0) else call XSETF (1) end if FATAL = .FALSE. call xerclr if ( kprint >= 3) write (LUN,90060) XX(1) = 1.0E0 XX(2) = 1.0E0 XX(3) = 1.0E0 ! ! Illegal arguments ! XX(4) = 1.0E0 DO I=1,4 XX(I) = -XX(I) K = INT(XX(3)) N = INT(XX(4)) call BESI(XX(1), XX(2), K, N, Y, NY) if ( NUMXER(NERR) /= 2 ) then ipass = 0 FATAL = .TRUE. end if call xerclr call BESK(XX(1), XX(2), K, N, W, NW) if ( NUMXER(NERR) /= 2 ) then ipass = 0 FATAL = .TRUE. end if call xerclr XX(I) = -XX(I) ! ! Trigger overflow ! end do X = LOG(R1MACH(2)/10.0E0) + 20.0E0 N = 3 ALP = 2.3E0 call BESI(X, ALP, 1, N, Y, NY) if ( NUMXER(NERR) /= 6 ) then ipass = 0 FATAL = .TRUE. end if call xerclr X = R1MACH(1)*10.0E0 call BESK(X, ALP, 1, N, W, NW) if ( NUMXER(NERR) /= 6 ) then ipass = 0 FATAL = .TRUE. end if call xerclr call XSETF (KONTRL) if ( FATAL ) then if ( kprint >= 2 ) then write (LUN, 90070) end if else if ( kprint >= 3 ) then write (LUN, 90080) end if end if if ( ipass == 1 .and. KPRINT >= 2) write (LUN,90100) if ( ipass == 0 .and. KPRINT >= 1) write (LUN,90110) return 90000 FORMAT (/ ' QUICK CHECKS FOR BESI AND BESK' //) 90010 FORMAT (/ ' ERROR IN QUICK CHECK OF WRONSKIAN', 1P / & ' KODE = ', I1,', M = ', I1, ', N = ', I1, ', NU = ', I1, & ', IX = ', I1, ', I = ', I1 / & ' X = ', E14.7, ', ER = ', E14.7, ', TOL = ', E14.7 / & ' Y(I) = ', E14.7, ', Y(I+1) = ', E14.7 / & ' W(I) = ', E14.7, ', W(I+1) = ', E14.7) 90020 FORMAT (/ ' ERROR IN QUICK CHECK OF SMALL X AND ORDER', 1P / & ' I = ', I1,', KODE = ', I1, ', FNU = ', E14.7 / & ' X = ', E14.7, ', ER = ', E14.7, ', TOL = ', E14.7 / & ' Y(1) = ', E14.7, ', Y(2) = ', E14.7 / & ' W(1) = ', E14.7, ', W(2) = ', E14.7) 90030 FORMAT (/ ' ERROR IN QUICK CHECK OF LARGE X AND ORDER', 1P / & ' K = ', I1,', N = ', I1, ', I = ', I1, & ', FNUP = ', E14.7 / & ' X = ', E14.7, ', ER = ', E14.7, ', TOL = ', E14.7 / & ' Y(1) = ', E14.7, ', Y(2) = ', E14.7 / & ' W(1) = ', E14.7, ', W(2) = ', E14.7) 90040 FORMAT (/ ' ERROR IN BESI UNDERFLOW TEST' /) 90050 FORMAT (/ ' ERROR IN BESK UNDERFLOW TEST' /) 90060 FORMAT (// ' TRIGGER 10 ERROR CONDITIONS' //) 90070 FORMAT (/ ' AT LEAST ONE INCORRECT ARGUMENT TEST FAILED') 90080 FORMAT (/ ' ALL INCORRECT ARGUMENT TESTS PASSED') 90100 FORMAT (/' **********BESI AND BESK PASSED ALL TESTS************') 90110 FORMAT (/' **********BESI OR BESK FAILED SOME TESTS************') END subroutine BJYCK (LUN, KPRINT, IPASS) !*****************************************************************************80 ! !! BJYCK is a quick check for BESJ and BESY. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (BJYCK-S, DBJYCK-D) !***KEYWORDS QUICK CHECK !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! BJYCK is a quick check routine for BESJ and BESY. The main loops ! evaluate the Wronskian and test the error. Underflow and overflow ! diagnostics are checked in addition to illegal arguments. ! !***ROUTINES CALLED BESJ, BESY, NUMXER, R1MACH, XERCLR, XGETF, XSETF !***REVISION HISTORY (YYMMDD) ! 750101 DATE WRITTEN ! 890911 Removed unnecessary intrinsics. (WRB) ! 891004 Removed unreachable code. (WRB) ! 891004 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901013 Editorial changes, some restructing and modifications to ! obtain more information when there is failure of the ! Wronskian. (RWC) ! 910501 Added PURPOSE and TYPE records. (WRB) ! 910708 Code revised to test error returns for all values of ! KPRINT. (WRB) !***END PROLOGUE BJYCK integer I, IX, K, KONTRL, LUN, M, N, NERR, NU, NY REAL ALP, DEL, ER, FNU, FNUP, RHPI, RX, TOL, X REAL FN(3), W(5), XX(5), Y(5) REAL R1MACH !***FIRST EXECUTABLE STATEMENT BJYCK LOGICAL FATAL if ( KPRINT >= 2) write (LUN,90000) IPASS=1 RHPI = 0.5E0/ATAN(1.0E0) XX(1) = 0.49E0 XX(2) = 1.3E0 XX(3) = 5.3E0 XX(4) = 13.3E0 XX(5) = 21.3E0 FN(1) = 0.095E0 FN(2) = 0.70E0 FN(3) = 0.0E0 TOL = 500.0E0*MAX(R1MACH(4), 7.1E-15) DO 50 M=1,3 DO 40 N=1,4 DO 30 NU=1,4 FNU = FN(M) + 12*(NU-1) DO 20 IX=1,5 if ( IX < 2 .and. NU > 3) GO TO 20 X = XX(IX) RX = RHPI/X call BESJ(X, FNU, N, Y, NY) if ( NY /= 0) GO TO 20 call BESY(X, FNU, N, W) FNUP = FNU + N call BESJ(X,FNUP,1,Y(N+1),NY) if ( NY /= 0) GO TO 20 call BESY(X,FNUP,1,W(N+1)) DO I=1,N ER = Y(I+1)*W(I) - W(I+1)*Y(I) - RX ER = ABS(ER)/RX if ( ER > TOL ) then ipass = 0 if ( KPRINT >= 2) write (LUN,90010) M,N,NU,IX,I, & X,ER,TOL,Y(I),Y(I+1),W(I),W(I+1) end if end do 20 continue 30 continue 40 continue ! ! Check small values of X and order ! 50 continue N = 2 FNU = 1.0E0 X = R1MACH(4)/100.0E0 RX = RHPI/X DO 60 I=1,3 call BESJ(X, FNU, N, Y, NY) call BESY(X, FNU, N, W) ER = Y(2)*W(1) - W(2)*Y(1) - RX ER = ABS(ER)/RX if ( ER > TOL ) then ipass = 0 if ( KPRINT >= 2) write (LUN,90020) I,FNU,X,ER,TOL, & Y(I),Y(I+1),W(I),W(I+1) GO TO 600 end if FNU = R1MACH(4)/100.0E0 X = XX(2*I-1) RX = RHPI/X ! ! Check large values of X and order ! 60 continue 600 DO 76 K=1,2 DEL = 30*(K-1) FNU = 70.0E0+DEL DO 75 N=1,2 X = 50.0E0 + DEL DO 70 I=1,5 RX = RHPI/X call BESJ(X, FNU, N, Y, NY) if ( NY /= 0) GO TO 70 call BESY(X, FNU, N, W) if ( N == 1 ) then FNUP = FNU + 1.0E0 call BESJ(X,FNUP,1,Y(2),NY) if ( NY /= 0) GO TO 70 call BESY(X,FNUP,1,W(2)) end if ER = Y(2)*W(1) - Y(1)*W(2) - RX ER = ABS(ER)/RX if ( ER > TOL ) then ipass = 0 if ( KPRINT >= 2) write (LUN,90030) K,N,I,X,ER,TOL, & Y(1),Y(2),W(1),W(2) GO TO 800 end if X = X + 10.0E0 70 continue 75 continue ! ! Check underflow flags ! 76 continue 800 X = R1MACH(1)*10.0E0 ALP = 12.3E0 N = 3 call BESJ(X, ALP, N, Y, NY) if ( NY /= 3 ) then ipass = 0 if ( KPRINT >= 2) write (LUN,90040) ! ! Trigger 7 error conditions ! end if call XGETF (KONTRL) if ( kprint <= 2 ) then call XSETF (0) else call XSETF (1) end if FATAL = .FALSE. call xerclr if ( kprint >= 3) write (LUN,90050) XX(1) = 1.0E0 XX(2) = 1.0E0 ! ! Illegal arguments ! XX(3) = 1.0E0 DO 80 I=1,3 XX(I) = -XX(I) N = INT(XX(3)) call BESJ(XX(1), XX(2), N, Y, NY) if ( NUMXER(NERR) /= 2 ) then ipass = 0 FATAL = .TRUE. end if call xerclr call BESY(XX(1), XX(2), N, W) if ( NUMXER(NERR) /= 2 ) then ipass = 0 FATAL = .TRUE. end if call xerclr XX(I) = -XX(I) ! ! Trigger overflow ! 80 continue X = R1MACH(1)*10.0E0 N = 3 ALP = 2.3E0 call BESY(X, ALP, N, W) if ( NUMXER(NERR) /= 6 ) then ipass = 0 FATAL = .TRUE. end if call xerclr call XSETF (KONTRL) if ( FATAL ) then if ( kprint >= 2 ) then write (LUN, 90070) end if else if ( kprint >= 3 ) then write (LUN, 90080) end if end if if ( ipass == 1 .and. KPRINT >= 2) write (LUN,90100) if ( ipass == 0 .and. KPRINT >= 1) write (LUN,90110) return 90000 FORMAT (/ ' QUICK CHECKS FOR BESJ AND BESY' //) 90010 FORMAT (/ ' ERROR IN QUICK CHECK OF WRONSKIAN', 1P / & ' M = ', I1,', N = ', I1, ', NU = ', I1, ', IX = ', I1, & ', I = ', I1, / & ' X = ', E14.7, ', ER = ', E14.7, ', TOL = ', E14.7 / & ' Y(I) = ', E14.7, ', Y(I+1) = ', E14.7 / & ' W(I) = ', E14.7, ', W(I+1) = ', E14.7) 90020 FORMAT (/ ' ERROR IN QUICK CHECK OF SMALL X AND ORDER', 1P / & ' I = ', I1,', FNU = ', E14.7 / & ' X = ', E14.7, ', ER = ', E14.7, ', TOL = ', E14.7 / & ' Y(1) = ', E14.7, ', Y(2) = ', E14.7 / & ' W(1) = ', E14.7, ', W(2) = ', E14.7) 90030 FORMAT (/ ' ERROR IN QUICK CHECK OF LARGE X AND ORDER', 1P / & ' K = ', I1,', N = ', I1, ', I = ', I1 / & ' X = ', E14.7, ', ER = ', E14.7, ', TOL = ', E14.7 / & ' Y(1) = ', E14.7, ', Y(2) = ', E14.7 / & ' W(1) = ', E14.7, ', W(2) = ', E14.7) 90040 FORMAT (/ ' ERROR IN BESJ UNDERFLOW TEST' /) 90050 FORMAT (// ' TRIGGER 7 ERROR CONDITIONS' //) 90070 FORMAT (/ ' AT LEAST ONE INCORRECT ARGUMENT TEST FAILED') 90080 FORMAT (/ ' ALL INCORRECT ARGUMENT TESTS PASSED') 90100 FORMAT (/' **********BESJ AND BESY PASSED ALL TESTS**********') 90110 FORMAT (/' **********BESJ OR BESY FAILED SOME TESTS**********') END subroutine BLACHK ( LUN, KPRINT, IPASS ) !*****************************************************************************80 ! !! BLACHK is a quick check for Basic Linear Algebra Subprograms. ! !***LIBRARY SLATEC !***KEYWORDS QUICK CHECK !***AUTHOR Lawson, C. L., (JPL) !***DESCRIPTION ! ! ********************************* TBLA *************************** ! TEST DRIVER FOR BASIC LINEAR ALGEBRA SUBPROGRAMS. ! C. L. LAWSON, JPL, 1974 DEC 10, 1975 MAY 28 ! ! UPDATED BY K. HASKELL - JUNE 23,1980 ! !***ROUTINES CALLED CHECK0, CHECK1, CHECK2, HEADER !***COMMON BLOCKS COMBLA !***REVISION HISTORY (YYMMDD) ! 751210 DATE WRITTEN ! 890618 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE BLACHK ! integer IPASS, JTEST(38) double precision DFAC,DQFAC LOGICAL PASS COMMON /COMBLA/ NPRINT, ICASE, N, INCX, INCY, MODE, PASS DATA SFAC,SDFAC,DFAC,DQFAC / .625E-1, .50, .625D-1, 0.625D-1/ DATA JTEST /1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1/ NPRINT = LUN ipass = 1 if ( 2 <= KPRINT ) then write ( nprint, '(a)' ) & 'QUICK CHECK OF 38 BASIC LINEAR ALGEBRA SUBROUTINES' write ( nprint, '(a)' ) ' ' end if DO ICASE = 1, 38 if ( JTEST(ICASE) == 0 ) then cycle end if ! ! INITIALIZE PASS, INCX, INCY, AND MODE FOR A NEW CASE. ! THE VALUE 9999 FOR INCX, INCY OR MODE WILL APPEAR IN THE ! DETAILED OUTPUT, IF ANY, FOR CASES THAT DO NOT INVOLVE ! THESE PARAMETERS. ! call HEADER (KPRINT) PASS=.TRUE. INCX=9999 INCY=9999 MODE=9999 GO TO (12,12,12,12,12,12,12,12,12,12, & 12,10,10,12,12,10,10,12,12,12, & 12,12,12,12,12,11,11,11,11,11, & 11,11,11,11,11,11,11,11), ICASE 10 call CHECK0 ( SFAC, DFAC, KPRINT ) GO TO 50 11 call CHECK1 ( SFAC, DFAC, KPRINT ) GO TO 50 12 call CHECK2 ( SFAC, SDFAC, DFAC, DQFAC, KPRINT ) 50 continue if ( 2 <= KPRINT .and. PASS ) then write ( nprint, 1001 ) end if if ( .NOT. PASS ) then ipass = 0 end if end do if ( 2 <= KPRINT .and. ipass == 1 ) then write ( nprint, 1006 ) end if if ( 1 <= KPRINT .and. ipass == 0 ) then write ( nprint, 1007 ) end if return 1001 FORMAT(1H+,39X,4HPASS) 1006 FORMAT(/54H ****************BLAS PASSED ALL TESTS****************) 1007 FORMAT(/54H ****************BLAS FAILED SOME TESTS***************) END subroutine BSPCK (LUN, KPRINT, IPASS) !*****************************************************************************80 ! !! BSPCK is a quick check for the B-Spline package. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (BSPCK-S, DBSPCK-D) !***KEYWORDS QUICK CHECK !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! BSPCK is a quick check routine for the B-Spline package which ! tests consistency between results from higher level routines. ! Those routines not explicitly called are exercised at some lower ! level. The routines exercised are BFQAD, BINT4, BINTK, BNFAC, ! BNSLV, BSGQ8, BSPDR, BSPEV, BSPPP, BSPVD, BSPVN, BSQAD, BVALU, ! INTRV, PFQAD, PPGQ8, PPQAD and PPVAL. ! !***ROUTINES CALLED BFQAD, BINT4, BINTK, BSPDR, BSPEV, BSPPP, BSPVD, ! BSPVN, BSQAD, BVALU, FB, INTRV, PFQAD, PPQAD, ! PPVAL, R1MACH !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 890911 Removed unnecessary intrinsics. (WRB) ! 891004 Removed unreachable code. (WRB) ! 891009 Removed unreferenced variables. (WRB) ! 891009 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 930214 Declarations sections added, code revised to test error ! returns for all values of kprint and code polished. (WRB) !***END PROLOGUE BSPCK ! .. Scalar Arguments .. ! .. Local Scalars .. integer IPASS, KPRINT, LUN REAL ATOL, BQUAD, BV, DEN, DN, ER, FBCL, FBCR, PI, PQUAD, QUAD, & SPV, TOL, X1, X2, XL, XX integer I, IBCL, IBCR, ID, IERR, IKNT, ILEFT, ILO, INBV, INEV, & INPPV, IWORK, J, JHIGH, JJ, K, KK, KNT, KNTOPT, KONTRL, & LDC, LDCC, LXI, MFLAG, N, NDATA, NERR, NMK, NN ! .. Local Arrays .. LOGICAL FATAL REAL ADif ( 52), BC(13), C(4, 10), CC(4, 4), Q(3), QQ(77), QSAVE(2), & ! .. External Functions .. SV(4), T(17), W(65), X(11), XI(11), Y(11) REAL BVALU, FB, PPVAL, R1MACH integer NUMXER ! .. External Subroutines .. EXTERNAL BVALU, FB, NUMXER, PPVAL, R1MACH EXTERNAL BFQAD, BINT4, BINTK, BSPDR, BSPEV, BSPPP, BSPVD, BSPVN, & ! .. Intrinsic Functions .. BSQAD, INTRV, PFQAD, PPQAD, XGETF, XSETF !***FIRST EXECUTABLE STATEMENT BSPCK INTRINSIC ABS, SIN ! if ( kprint >= 2) write (LUN, 9000) ipass = 1 PI = 3.14159265358979324E0 ! ! Generate data. ! TOL = 1000.0E0*R1MACH(4) NDATA = 11 DEN = NDATA - 1 DO 20 I = 1,NDATA X(I) = (I-1)/DEN Y(I) = SIN(PI*X(I)) 20 continue X(3) = 2.0E0/DEN ! ! Compute splines for two knot arrays. ! Y(3) = SIN(PI*X(3)) DO 110 IKNT = 1,2 KNT = 3 - IKNT IBCL = 1 IBCR = 2 FBCL = PI FBCR = 0.0E0 ! ! Error test on BINT4. ! call BINT4 (X,Y,NDATA,IBCL,IBCR,FBCL,FBCR,KNT,T,BC,N,K,W) INBV = 1 DO 30 I = 1,NDATA XX = X(I) BV = BVALU(T,BC,N,K,0,XX,INBV,W) ER = ABS(Y(I)-BV) if ( ER > TOL ) then ipass = 0 if ( kprint >= 2) write (LUN, 9010) end if 30 continue INBV = 1 BV = BVALU(T,BC,N,K,1,X(1),INBV,W) ER = ABS(PI-BV) if ( ER > TOL ) then ipass = 0 if ( kprint >= 2) write (LUN, 9020) end if BV = BVALU(T,BC,N,K,2,X(NDATA),INBV,W) ER = ABS(BV) if ( ER > TOL ) then ipass = 0 if ( kprint >= 2) write (LUN, 9030) ! ! Test for equality of area from 4 routines. ! end if X1 = X(1) X2 = X(NDATA) call BSQAD (T,BC,N,K,X1,X2,BQUAD,W) LDC = 4 call BSPPP (T,BC,N,K,LDC,C,XI,LXI,W) call PPQAD (LDC,C,XI,LXI,K,X1,X2,Q(1)) call BFQAD (FB,T,BC,N,K,0,X1,X2,TOL,Q(2),IERR,W) ! ! Error test for quadratures. ! call PFQAD (FB,LDC,C,XI,LXI,K,0,X1,X2,TOL,Q(3),IERR) DO I = 1,3 ER = ABS(BQUAD-Q(I)) if ( ER > TOL ) then ipass = 0 if ( kprint >= 2) write (LUN, 9040) end if end do QSAVE(KNT) = BQUAD 110 continue ER = ABS(QSAVE(1)-QSAVE(2)) if ( ER > TOL ) then ipass = 0 if ( kprint >= 2) write (LUN, 9060) ! ! Check BSPDR and BSPEV against BVALU, PPVAL and BSPVD. ! end if call BSPDR (T,BC,N,K,K,ADIF) INEV = 1 INBV = 1 INPPV = 1 ILO = 1 DO 170 I = 1,6 XX = X(I+I-1) call BSPEV (T,ADIF,N,K,K,XX,INEV,SV,W) ATOL = TOL DO 130 J = 1,K SPV = BVALU (T,BC,N,K,J-1,XX,INBV,W) ER = ABS(SPV-SV(J)) X2 = ABS(SV(J)) if ( X2 > 1.0E0) ER = ER/X2 if ( ER > ATOL ) then ipass = 0 if ( kprint >= 2) write (LUN, 9070) end if ATOL = 10.0E0*ATOL 130 continue ATOL = TOL DO 140 J = 1,K SPV = PPVAL (LDC,C,XI,LXI,K,J-1,XX,INPPV) ER = ABS(SPV-SV(J)) X2 = ABS(SV(J)) if ( X2 > 1.0E0) ER = ER/X2 if ( ER > ATOL ) then ipass = 0 if ( kprint >= 2) write (LUN, 9080) end if ATOL = 10.0E0*ATOL 140 continue ATOL = TOL LDCC = 4 X1 = XX if ( I+I-1 == NDATA) X1 = T(N) NN = N + K call INTRV (T,NN,X1,ILO,ILEFT,MFLAG) DO 160 J = 1,K call BSPVD (T,K,J,XX,ILEFT,LDCC,CC,W) ER = 0.0E0 DO 150 JJ = 1,K ER = ER + BC(ILEFT-K+JJ)*CC(JJ,J) 150 continue ER = ABS(ER-SV(J)) X2 = ABS(SV(J)) if ( X2 > 1.0E0) ER = ER/X2 if ( ER > ATOL ) then ipass = 0 if ( kprint >= 2) write (LUN, 9090) end if ATOL = 10.0E0*ATOL 160 continue 170 continue DO 220 K = 2,4 N = NDATA NMK = N - K DO I = 1,K T(I) = X(1) T(N+I) = X(N) end do XL = X(N) - X(1) DN = N - K + 1 DO I = 1,NMK T(K+I) = X(1) + I*XL/DN end do ! ! Error test on BINTK. ! call BINTK (X,Y,T,N,K,BC,QQ,W) INBV = 1 DO 210 I = 1,N XX = X(I) BV = BVALU(T,BC,N,K,0,XX,INBV,W) ER = ABS(Y(I)-BV) if ( ER > TOL ) then ipass = 0 if ( kprint >= 2) write (LUN, 9100) end if 210 continue ! ! Trigger error conditions. ! 220 continue call XGETF (KONTRL) if ( kprint <= 2 ) then call XSETF (0) else call XSETF (1) end if FATAL = .FALSE. call xerclr if ( kprint >= 3) write (LUN, 9050) W(1) = 11.0E0 W(2) = 4.0E0 W(3) = 2.0E0 W(4) = 0.5E0 W(5) = 4.0E0 ILO = 1 INEV = 1 INBV = 1 call INTRV (T,N+1,W(4),ILO,ILEFT,MFLAG) DO 320 I = 1,5 W(I) = -W(I) N = W(1) K = W(2) ID = W(3) XX = W(4) LDC = W(5) if ( I <= 4 ) then BV = BVALU (T,BC,N,K,ID,XX,INBV,QQ) if ( NUMXER(NERR) /= 2 ) then ipass = 0 FATAL = .TRUE. end if call xerclr call BSPEV (T,ADIF,N,K,ID,XX,INEV,SV,QQ) if ( NUMXER(NERR) /= 2 ) then ipass = 0 FATAL = .TRUE. end if call xerclr JHIGH = N - 10 call BSPVN (T,JHIGH,K,ID,XX,ILEFT,SV,QQ,IWORK) if ( NUMXER(NERR) /= 2 ) then ipass = 0 FATAL = .TRUE. end if call xerclr call BFQAD (FB,T,BC,N,K,ID,XX,X2,TOL,QUAD,IERR,QQ) if ( NUMXER(NERR) /= 2 ) then ipass = 0 FATAL = .TRUE. end if call xerclr end if if ( I /= 3 .and. I /= 4 ) then call BSPPP (T,BC,N,K,LDC,C,XI,LXI,QQ) if ( NUMXER(NERR) /= 2 ) then ipass = 0 FATAL = .TRUE. end if call xerclr end if if ( I <= 3 ) then call BSPDR (T,BC,N,K,ID,ADIF) if ( NUMXER(NERR) /= 2 ) then ipass = 0 FATAL = .TRUE. end if call xerclr end if if ( I /= 3 .and. I /= 5 ) then call BSQAD (T,BC,N,K,XX,X2,BQUAD,QQ) if ( NUMXER(NERR) /= 2 ) then ipass = 0 FATAL = .TRUE. end if call xerclr end if if ( I > 1 ) then call BSPVD (T,K,ID,XX,ILEFT,LDC,C,QQ) if ( NUMXER(NERR) /= 2 ) then ipass = 0 FATAL = .TRUE. end if call xerclr end if if ( I <= 2 ) then call BINTK (X,Y,T,N,K,BC,QQ,ADIF) if ( NUMXER(NERR) /= 2 ) then ipass = 0 FATAL = .TRUE. end if call xerclr end if if ( I /= 4 ) then KNTOPT = LDC - 2 IBCL = K - 2 call BINT4 (X,Y,N,IBCL,ID,FBCL,FBCR,KNTOPT,T,BC,NN,KK,QQ) if ( NUMXER(NERR) /= 2 ) then ipass = 0 FATAL = .TRUE. end if call xerclr end if W(I) = -W(I) 320 continue KNTOPT = 1 X(1) = 1.0E0 call BINT4 (X,Y,N,IBCL,IBCR,FBCL,FBCR,KNTOPT,T,BC,N,K,QQ) if ( NUMXER(NERR) /= 2 ) then ipass = 0 FATAL = .TRUE. end if call xerclr call BINTK (X,Y,T,N,K,BC,QQ,ADIF) if ( NUMXER(NERR) /= 2 ) then ipass = 0 FATAL = .TRUE. end if call xerclr X(1) = 0.0E0 ATOL = 1.0E0 KNTOPT = 3 DO 330 I = 1,3 QQ(I) = -0.30E0 + 0.10E0*(I-1) QQ(I+3) = 1.1E0 + 0.10E0*(I-1) 330 continue QQ(1) = 1.0E0 call BINT4 (X,Y,NDATA,1,1,FBCL,FBCR,3,T,BC,N,K,QQ) if ( NUMXER(NERR) /= 2 ) then ipass = 0 FATAL = .TRUE. end if call xerclr call BFQAD (FB,T,BC,N,K,ID,X1,X2,ATOL,QUAD,IERR,QQ) if ( NUMXER(NERR) /= 2 ) then ipass = 0 FATAL = .TRUE. end if call xerclr INPPV = 1 DO 350 I = 1,5 W(I) = -W(I) LXI = W(1) K = W(2) ID = W(3) XX = W(4) LDC = W(5) SPV = PPVAL (LDC,C,XI,LXI,K,ID,XX,INPPV) if ( (I /= 4 .and. NUMXER(NERR) /= 2) .OR. & (I == 4 .and. NUMXER(NERR) /= 0) ) then ipass = 0 FATAL = .TRUE. end if call xerclr call PFQAD (FB,LDC,C,XI,LXI,K,ID,XX,X2,TOL,QUAD,IERR) if ( (I /= 4 .and. NUMXER(NERR) /= 2) .OR. & (I == 4 .and. NUMXER(NERR) /= 0) ) then ipass = 0 FATAL = .TRUE. end if call xerclr if ( I /= 3 ) then call PPQAD (LDC,C,XI,LXI,K,XX,X2,PQUAD) if ( (I /= 4 .and. NUMXER(NERR) /= 2) .OR. & (I == 4 .and. NUMXER(NERR) /= 0) ) then ipass = 0 FATAL = .TRUE. end if call xerclr end if W(I) = -W(I) 350 continue LDC = W(5) call PFQAD (FB,LDC,C,XI,LXI,K,ID,X1,X2,ATOL,QUAD,IERR) if ( NUMXER(NERR) /= 2 ) then ipass = 0 FATAL = .TRUE. end if ! ! Restore KONTRL and check to see if the tests of error detection ! passed. ! call xerclr call XSETF (KONTRL) if ( FATAL ) then if ( kprint >= 2 ) then write (LUN, 9110) end if else if ( kprint >= 3 ) then write (LUN, 9120) end if ! ! Print PASS/FAIL message. ! end if if ( ipass == 1 .and. KPRINT >= 2) write (LUN, 9200) if ( ipass == 0 .and. KPRINT >= 1) write (LUN, 9210) return 9000 FORMAT ('1 QUICK CHECK FOR SPLINE ROUTINES',//) 9010 FORMAT (' ERROR TEST FOR INTERPOLATION BY BINT4 NOT SATISFIED') 9020 FORMAT (' ERROR TEST FOR INTERPOLATION BY BINT4 NOT SATISFIED ', & 'BY FIRST DERIVATIVE') 9030 FORMAT (' ERROR TEST FOR INTERPOLATION BY BINT4 NOT SATISFIED ', & 'BY SECOND DERIVATIVE') 9040 FORMAT (' ERROR IN QUADRATURE CHECKS') 9050 FORMAT (/' TRIGGER 52 ERROR CONDITIONS',/) 9060 FORMAT (' ERROR IN QUADRATURE CHECK USING TWO SETS OF KNOTS') 9070 FORMAT (' COMPARISONS FROM BSPEV AND BVALU DO NOT AGREE') 9080 FORMAT (' COMPARISONS FROM BSPEV AND PPVAL DO NOT AGREE') 9090 FORMAT (' COMPARISONS FROM BSPEV AND BSPVD DO NOT AGREE') 9100 FORMAT (' ERROR TEST FOR INTERPOLATION BY BINTK NOT SATISFIED') 9110 FORMAT (/ ' AT LEAST ONE INCORRECT ARGUMENT TEST FAILED') 9120 FORMAT (/ ' ALL INCORRECT ARGUMENT TESTS PASSED') 9200 FORMAT (/' **********B-SPLINE PACKAGE PASSED ALL TESTS**********') 9210 FORMAT (/' *********B-SPLINE PACKAGE FAILED SOME TESTS**********') end COMPLEX FUNCTION CBEG (RESET) !*****************************************************************************80 ! !! CBEG generates uniform random values in [-0.5,0.5]. ! !***SUBSIDIARY !***PURPOSE Generate random numbers. !***LIBRARY SLATEC (BLAS) !***AUTHOR Du Croz, J. (NAG) ! Hanson, R. J. (SNLA) !***DESCRIPTION ! ! Generates random numbers uniformly distributed between -0.5 and 0.5. ! ! Auxiliary routine for test program for Level 2 Blas. !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 870810 DATE WRITTEN ! 910619 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE CBEG ! .. Scalar Arguments .. ! .. Local Scalars .. LOGICAL RESET ! .. Save statement .. integer I, IC, J, MI, MJ ! .. Intrinsic Functions .. SAVE I, IC, J, MI, MJ !***FIRST EXECUTABLE STATEMENT CBEG INTRINSIC CMPLX ! ! Initialize local variables. ! if ( RESET ) then MI = 891 MJ = 457 I = 7 J = 7 IC = 0 RESET = .FALSE. ! ! The sequence of values of I or J is bounded between 1 and 999. ! If initial I or J = 1,2,3,6,7 or 9, the period will be 50. ! If initial I or J = 4 or 8, the period will be 25. ! If initial I or J = 5, the period will be 10. ! IC is used to break up the period by skipping 1 value of I or J ! in 6. ! end if IC = IC + 1 10 I = I*MI J = J*MJ I = I - 1000*( I/1000 ) J = J - 1000*( J/1000 ) if ( IC >= 5 ) then IC = 0 GO TO 10 end if CBEG = CMPLX( ( I - 500 )/1001.0, ( J - 500 )/1001.0 ) return end subroutine CBLAT2 (NOUT, KPRINT, IPASS) !*****************************************************************************80 ! !! CBLAT2 is the driver for testing Level 2 BLAS complex subroutines. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY A4 !***TYPE COMPLEX (SBLAT2-S, DBLAT2-D, CBLAT2-C) !***KEYWORDS BLAS, QUICK CHECK DRIVER !***AUTHOR Du Croz, J. J., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! Test program for the COMPLEX Level 2 Blas. ! !***REFERENCES Dongarra, J. J., Du Croz, J. J., Hammarling, S. and ! Hanson, R. J. An extended set of Fortran Basic ! Linear Algebra Subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED CCHK12, CCHK22, CCHK32, CCHK42, CCHK52, CCHK62, ! CCHKE2, CMVCH, LCE, R1MACH, XERCLR !***REVISION HISTORY (YYMMDD) ! 870810 DATE WRITTEN ! 910619 Modified to meet SLATEC code and prologue standards. (BKS) ! 930315 Removed unused variables. (WRB) ! 930618 Code modified to improve PASS/FAIL reporting. (BKS, WRB) !***END PROLOGUE CBLAT2 ! .. Parameters .. integer NSUBS PARAMETER ( NSUBS = 17) COMPLEX ZERO, ONE PARAMETER ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) ) REAL RZERO PARAMETER ( RZERO = 0.0 ) integer NMAX, INCMAX ! .. Scalar Arguments .. PARAMETER ( NMAX = 65, INCMAX = 2 ) ! .. Local Scalars .. integer IPASS, KPRINT REAL EPS, ERR, THRESH integer I, ISNUM, J, N, NALF, NBET, NIDIM, NINC, & NKB, NOUT PARAMETER (NIDIM=6, NKB=4, NINC=4, NALF=3, NBET=3) LOGICAL SAME, TSTERR, FTL, FTL1, FTL2 ! .. Local Arrays .. CHARACTER*1 TRANS COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), & ALF( NALF ), AS( NMAX*NMAX ), BET( NBET ), & X( NMAX ), XS( NMAX*INCMAX ), & XX( NMAX*INCMAX ), Y( NMAX ), & YS( NMAX*INCMAX ), YT( NMAX ), & YY( NMAX*INCMAX ), Z( 2*NMAX ) REAL G( NMAX ) integer IDIM( NIDIM ), INC( NINC ), KB( NKB ) LOGICAL LTEST( NSUBS ) ! .. External Functions .. CHARACTER*6 SNAMES( NSUBS ) REAL R1MACH LOGICAL LCE ! .. External Subroutines .. EXTERNAL LCE, R1MACH EXTERNAL CCHK12, CCHK22, CCHK32, CCHK42, CCHK52, CCHK62, & ! .. Intrinsic Functions .. CCHKE2, CMVCH ! .. Data statements .. INTRINSIC ABS, MAX, MIN DATA SNAMES/'CGEMV ', 'CGBMV ', 'CHEMV ', 'CHBMV ', & 'CHPMV ', 'CTRMV ', 'CTBMV ', 'CTPMV ', & 'CTRSV ', 'CTBSV ', 'CTPSV ', 'CGERC ', & 'CGERU ', 'CHER ', 'CHPR ', 'CHER2 ', & 'CHPR2 '/ DATA IDIM/0,1,2,3,5,9/ DATA KB/0,1,2,4/ DATA INC/1,2,-1,-2/ DATA ALF/(0.0,0.0),(1.0,0.0),(0.7,-0.9)/ !***FIRST EXECUTABLE STATEMENT CBLAT2 ! ! Set the flag that indicates whether error exits are to be tested. DATA BET/(0.0,0.0),(1.0,0.0),(1.3,-1.1)/ ! Set the threshold value of the test ratio TSTERR = .TRUE. ! ! Set ipass = 1 assuming all tests will pass. ! THRESH = 16.0 ! ! Report values of parameters. ! ipass = 1 if ( kprint >= 3 ) then write ( NOUT, FMT = 9993 ) write ( NOUT, FMT = 9992 )( IDIM( I ), I = 1, NIDIM ) write ( NOUT, FMT = 9991 )( KB( I ), I = 1, NKB ) write ( NOUT, FMT = 9990 )( INC( I ), I = 1, NINC ) write ( NOUT, FMT = 9989 )( ALF( I ), I = 1, NALF ) write ( NOUT, FMT = 9988 )( BET( I ), I = 1, NBET ) if ( .NOT.TSTERR ) then write ( NOUT, FMT = 9980 ) end if write ( NOUT, FMT = 9999 )THRESH ! ! Set names of subroutines and flags which indicate ! whether they are to be tested. ! end if ! ! Set EPS (the machine precision). ! LTEST(1:nsubs) = .TRUE. ! ! Check the reliability of CMVCH using exact data. ! EPS = R1MACH (4) N = min ( 32, NMAX ) DO J = 1, N DO I = 1, N A( I, J ) = max ( I - J + 1, 0 ) end do X( J ) = J Y( J ) = ZERO end do DO 130 J = 1, N YY( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3 ! YY holds the exact result. On exit from CMVCH YT holds ! the result computed by CMVCH. 130 continue TRANS = 'N' FTL = .FALSE. call CMVCH( TRANS, N, N, ONE, A, NMAX, X, 1, ZERO, Y, 1, YT, G, & YY, EPS, ERR, FTL, NOUT, .TRUE., kprint ) SAME = LCE( YY, YT, N ) if ( .NOT.SAME.OR.ERR /= RZERO ) then ipass = 0 if ( kprint >= 2 ) then write ( NOUT, FMT = 9985 )TRANS, SAME, ERR end if end if TRANS = 'T' FTL = .FALSE. call CMVCH( TRANS, N, N, ONE, A, NMAX, X, -1, ZERO, Y, -1, YT, G, & YY, EPS, ERR, FTL, NOUT, .TRUE., kprint ) SAME = LCE( YY, YT, N ) if ( .NOT.SAME.OR.ERR /= RZERO ) then ipass = 0 if ( kprint >= 2 ) then write ( NOUT, FMT = 9985 )TRANS, SAME, ERR end if ! ! Test each subroutine in turn. ! end if DO 210 ISNUM = 1, NSUBS ! Subprogram is not to be tested. if ( .NOT.LTEST( ISNUM ) ) then write ( NOUT, FMT = 9983 )SNAMES( ISNUM ) ! Test error exits. else FTL1 = .FALSE. if ( TSTERR ) then call CCHKE2(ISNUM, SNAMES( ISNUM ), NOUT, KPRINT, FTL1) ! Test computations. end if FTL2 = .FALSE. call xerclr GO TO ( 140, 140, 150, 150, 150, 160, 160, & 160, 160, 160, 160, 170, 170, 180, & ! Test CGEMV, 01, and CGBMV, 02. 180, 190, 190 )ISNUM 140 call CCHK12( SNAMES( ISNUM ), EPS, THRESH, NOUT, KPRINT, & FTL2, NIDIM, IDIM, NKB, KB, NALF, ALF, & NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS, & X, XX, XS, Y, YY, YS, YT, G ) ! Test CHEMV, 03, CHBMV, 04, and CHPMV, 05. GO TO 200 150 call CCHK22( SNAMES( ISNUM ), EPS, THRESH, NOUT, KPRINT, & FTL2, NIDIM, IDIM, NKB, KB, NALF, ALF, & NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS, & X, XX, XS, Y, YY, YS, YT, G ) ! Test CTRMV, 06, CTBMV, 07, CTPMV, 08, ! CTRSV, 09, CTBSV, 10, and CTPSV, 11. GO TO 200 160 call CCHK32( SNAMES( ISNUM ), EPS, THRESH, NOUT, KPRINT, & FTL2, NIDIM, IDIM, NKB, KB, NINC, INC, & NMAX, INCMAX, A, AA, AS, Y, YY, YS, YT, G, Z ) ! Test CGERC, 12, CGERU, 13. GO TO 200 170 call CCHK42( SNAMES( ISNUM ), EPS, THRESH, NOUT, KPRINT, & FTL2, NIDIM, IDIM, NALF, ALF, NINC, INC, & NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, & YT, G, Z ) ! Test CHER, 14, and CHPR, 15. GO TO 200 180 call CCHK52( SNAMES( ISNUM ), EPS, THRESH, NOUT, KPRINT, & FTL2, NIDIM, IDIM, NALF, ALF, NINC, INC, & NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, & YT, G, Z ) ! Test CHER2, 16, and CHPR2, 17. GO TO 200 190 call CCHK62( SNAMES( ISNUM ), EPS, THRESH, NOUT, KPRINT, & FTL2, NIDIM, IDIM, NALF, ALF, NINC, INC, & NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, & ! YT, G, Z ) 200 if ( FTL1 .OR. FTL2 ) then ipass = 0 end if end if 210 continue ! return 9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES', & 'S THAN', F8.2 ) 9993 FORMAT( ' TESTS OF THE COMPLEX LEVEL 2 BLAS', //' THE F', & 'OLLOWING PARAMETER VALUES WILL BE USED:' ) 9992 FORMAT( ' FOR N ', 9I6 ) 9991 FORMAT( ' FOR K ', 7I6 ) 9990 FORMAT( ' FOR INCX AND INCY ', 7I6 ) 9989 FORMAT( ' FOR ALPHA ', & 7( '(', F4.1, ',', F4.1, ') ', : ) ) 9988 FORMAT( ' FOR BETA ', & 7( '(', F4.1, ',', F4.1, ') ', : ) ) 9985 FORMAT( ' ERROR IN CMVCH - IN-LINE DOT PRODUCTS ARE BEING EVALU', & 'ATED WRONGLY.', /' CMVCH WAS CALLED WITH TRANS = ', A1, & ' AND RETURNED SAME = ', L1, ' AND ERR = ', F12.3, '. ', / & 'THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.') 9983 FORMAT( 1X, A6, ' WAS NOT TESTED' ) ! ! End of CBLAT2. ! 9980 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) end subroutine CBLAT3 (NOUT, KPRINT, IPASS) !*****************************************************************************80 ! !! CBLAT3 is the driver for testing Level 3 BLAS complex subroutines. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY A4 !***TYPE COMPLEX (SBLAT3-S, DBLAT3-D, CBLAT3-C) !***KEYWORDS BLAS, QUICK CHECK DRIVER !***AUTHOR Dongarra, J. J., (ANL) ! Duff, I., (AERE) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) !***DESCRIPTION ! ! Test program for the COMPLEX Level 3 Blas. ! !***REFERENCES Dongarra, J., Du Croz, J., Duff, I., and Hammarling, S. ! A set of level 3 basic linear algebra subprograms. ! ACM TOMS, Vol. 16, No. 1, pp. 1-17, March 1990. !***ROUTINES CALLED CCHK13, CCHK23, CCHK33, CCHK43, CCHK53, CCHKE3, ! CMMCH, LCE, R1MACH, XERCLR !***REVISION HISTORY (YYMMDD) ! 890208 DATE WRITTEN ! 910619 Modified to meet SLATEC code and prologue standards. (BKS) ! 930315 Removed unused variables. (WRB) ! 930618 Code modified to improve PASS/FAIL reporting. (BKS, WRB) !***END PROLOGUE CBLAT3 ! .. Parameters .. ! integer NSUBS PARAMETER ( NSUBS = 9) COMPLEX ZERO, ONE PARAMETER ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) ) REAL RZERO PARAMETER ( RZERO = 0.0 ) integer NMAX ! .. Scalar Arguments .. PARAMETER ( NMAX = 65) ! .. Local Scalars .. integer IPASS, KPRINT REAL EPS, ERR, THRESH integer I, ISNUM, J, N, NALF, NBET, NIDIM, NOUT PARAMETER (NIDIM=6, NALF=3, NBET=3) LOGICAL SAME, TSTERR, FTL, FTL1, FTL2 ! .. Local Arrays .. CHARACTER*1 TRANSA, TRANSB COMPLEX AA( NMAX*NMAX ), AB( NMAX, 2*NMAX ), & ALF( NALF ), AS( NMAX*NMAX ), & BB( NMAX*NMAX ), BET( NBET ), & BS( NMAX*NMAX ), C( NMAX, NMAX ), & CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ), & W( 2*NMAX ) REAL G( NMAX ) integer IDIM( NIDIM ) LOGICAL LTEST( NSUBS ) ! .. External Functions .. CHARACTER*6 SNAMES( NSUBS ) REAL R1MACH LOGICAL LCE ! .. External Subroutines .. EXTERNAL LCE, R1MACH EXTERNAL CCHK13, CCHK23, CCHK33, CCHK43, CCHK53, & ! .. Intrinsic Functions .. CCHKE3, CMMCH ! .. Data statements .. INTRINSIC ABS, MAX, MIN DATA SNAMES/'CGEMM ', 'CHEMM ', 'CSYMM ', 'CTRMM ', & 'CTRSM ', 'CHERK ', 'CSYRK ', 'CHER2K', & 'CSYR2K'/ DATA IDIM/0,1,2,3,5,9/ DATA ALF/(0.0,0.0),(1.0,0.0),(0.7,-0.9)/ !***FIRST EXECUTABLE STATEMENT CBLAT3 ! ! Set the flag that indicates whether error exits are to be tested. DATA BET/(0.0,0.0),(1.0,0.0),(1.3,-1.1)/ ! Set the threshold value of the test ratio TSTERR = .TRUE. ! ! Set ipass = 1 assuming all tests will pass. ! THRESH = 16.0 ! ! Report values of parameters. ! ipass = 1 if ( kprint >= 3 ) then write ( NOUT, FMT = 9995 ) write ( NOUT, FMT = 9994 )( IDIM( I ), I = 1, NIDIM ) write ( NOUT, FMT = 9993 )( ALF( I ), I = 1, NALF ) write ( NOUT, FMT = 9992 )( BET( I ), I = 1, NBET ) if ( .NOT.TSTERR ) then write ( NOUT, FMT = 9984 ) end if write ( NOUT, FMT = 9999 )THRESH ! ! Set names of subroutines and flags which indicate ! whether they are to be tested. ! end if DO 40 I = 1, NSUBS LTEST( I ) = .TRUE. ! ! Set EPS (the machine precision). ! 40 continue ! ! Check the reliability of CMMCH using exact data. ! EPS = R1MACH (4) N = min ( 32, NMAX ) DO J = 1, N DO I = 1, N AB( I, J ) = max ( I - J + 1, 0 ) end do AB( J, NMAX + 1 ) = J AB( 1, NMAX + J ) = J C( J, 1 ) = ZERO end do DO 110 J = 1, N CC( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3 ! CC holds the exact result. On exit from CMMCH CT holds ! the result computed by CMMCH. 110 continue TRANSA = 'N' TRANSB = 'N' FTL = .FALSE. call CMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, & AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, & NMAX, EPS, ERR, FTL, NOUT, .TRUE., kprint ) SAME = LCE( CC, CT, N ) if ( .NOT.SAME.OR.ERR /= RZERO ) then ipass = 0 if ( kprint >= 2 ) then write ( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR end if end if TRANSB = 'C' FTL = .FALSE. call CMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, & AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, & NMAX, EPS, ERR, FTL, NOUT, .TRUE., kprint ) SAME = LCE( CC, CT, N ) if ( .NOT.SAME.OR.ERR /= RZERO ) then ipass = 0 if ( kprint >= 2 ) then write ( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR end if end if DO 120 J = 1, N AB( J, NMAX + 1 ) = N - J + 1 AB( 1, NMAX + J ) = N - J + 1 120 continue DO 130 J = 1, N CC( N - J + 1 ) = J*( ( J + 1 )*J )/2 - & ( ( J + 1 )*J*( J - 1 ) )/3 130 continue TRANSA = 'C' TRANSB = 'N' FTL = .FALSE. call CMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, & AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, & NMAX, EPS, ERR, FTL, NOUT, .TRUE., kprint ) SAME = LCE( CC, CT, N ) if ( .NOT.SAME.OR.ERR /= RZERO ) then ipass = 0 if ( kprint >= 2 ) then write ( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR end if end if TRANSB = 'C' FTL = .FALSE. call CMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, & AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, & NMAX, EPS, ERR, FTL, NOUT, .TRUE., kprint ) SAME = LCE( CC, CT, N ) if ( .NOT.SAME.OR.ERR /= RZERO ) then ipass = 0 if ( kprint >= 2 ) then write ( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR end if ! ! Test each subroutine in turn. ! end if DO 200 ISNUM = 1, NSUBS ! Subprogram is not to be tested. if ( .NOT.LTEST( ISNUM ) ) then write ( NOUT, FMT = 9987 )SNAMES( ISNUM ) ! Test error exits. else FTL1 = .FALSE. if ( TSTERR ) then call CCHKE3(ISNUM, SNAMES( ISNUM ), NOUT, KPRINT, FTL1) ! Test computations. end if FTL2 = .FALSE. call xerclr GO TO ( 140, 150, 150, 160, 160, 170, 170, & ! Test CGEMM, 01. 180, 180 )ISNUM 140 call CCHK13( SNAMES( ISNUM ), EPS, THRESH, NOUT, KPRINT, & FTL2, NIDIM, IDIM, NALF, ALF, NBET, BET, & NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, & CC, CS, CT, G ) ! Test CHEMM, 02, CSYMM, 03. GO TO 190 150 call CCHK23( SNAMES( ISNUM ), EPS, THRESH, NOUT, KPRINT, & FTL2, NIDIM, IDIM, NALF, ALF, NBET, BET, & NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, & CC, CS, CT, G ) ! Test CTRMM, 04, CTRSM, 05. GO TO 190 160 call CCHK33( SNAMES( ISNUM ), EPS, THRESH, NOUT, KPRINT, & FTL2, NIDIM, IDIM, NALF, ALF, NMAX, AB, & AA, AS, AB( 1, NMAX + 1 ), BB, BS, CT, G, C ) ! Test CHERK, 06, CSYRK, 07. GO TO 190 170 call CCHK43( SNAMES( ISNUM ), EPS, THRESH, NOUT, KPRINT, & FTL2, NIDIM, IDIM, NALF, ALF, NBET, BET, & NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, & CC, CS, CT, G ) ! Test CHER2K, 08, CSYR2K, 09. GO TO 190 180 call CCHK53( SNAMES( ISNUM ), EPS, THRESH, NOUT, KPRINT, & FTL2, NIDIM, IDIM, NALF, ALF, NBET, BET, & NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W ) ! GO TO 190 190 if ( FTL1 .OR. FTL2 ) then ipass = 0 end if end if 200 continue ! return 9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES', & 'S THAN', F8.2 ) 9995 FORMAT( ' TESTS OF THE COMPLEX LEVEL 3 BLAS', //' THE F', & 'OLLOWING PARAMETER VALUES WILL BE USED:' ) 9994 FORMAT( ' FOR N ', 9I6 ) 9993 FORMAT( ' FOR ALPHA ', & 7( '(', F4.1, ',', F4.1, ') ', : ) ) 9992 FORMAT( ' FOR BETA ', & 7( '(', F4.1, ',', F4.1, ') ', : ) ) 9989 FORMAT( ' ERROR IN CMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALU', & 'ATED WRONGLY.', /' CMMCH WAS CALLED WITH TRANSA = ', A1, & ' AND TRANSB = ', A1, /' AND RETURNED SAME = ', L1, ' AND ', & 'ERR = ', F12.3, '.', /' THIS MAY BE DUE TO FAULTS IN THE ', & 'ARITHMETIC OR THE COMPILER.') 9987 FORMAT( 1X, A6, ' WAS NOT TESTED' ) ! ! End of CBLAT3. ! 9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) end subroutine CCHK12 (SNAME, EPS, THRESH, NOUT, KPRINT, FATAL, NIDIM, & IDIM, NKB, KB, NALF, ALF, NBET, BET, NINC, INC, NMAX, INCMAX, & !*****************************************************************************80 ! !! CCHK12 is a quick check for CGEMV and CGBMV. ! !***LIBRARY SLATEC (BLAS) !***KEYWORDS BLAS, QUICK CHECK SERVICE ROUTINE !***AUTHOR Du Croz, J. (NAG) ! Hanson, R. J. (SNLA) !***DESCRIPTION ! ! Quick check for CGEMV and CGBMV. ! ! Auxiliary routine for test program for Level 2 Blas. !***REFERENCES (NONE) !***ROUTINES CALLED CGBMV, CGEMV, CMAKE2, CMVCH, LCE, LCERES, NUMXER !***REVISION HISTORY (YYMMDD) ! 870810 DATE WRITTEN ! 910619 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE CCHK12 ! .. Parameters .. A, AA, AS, X, XX, XS, Y, YY, YS, YT, G) COMPLEX ZERO, HALF PARAMETER ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ) ) REAL RZERO ! .. Scalar Arguments .. PARAMETER ( RZERO = 0.0 ) LOGICAL FATAL REAL EPS, THRESH integer INCMAX, KPRINT, NALF, NBET, NIDIM, NINC, NKB, & NMAX, NOUT ! .. Array Arguments .. CHARACTER*6 SNAME COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), & AS( NMAX*NMAX ), BET( NBET ), X( NMAX ), & XS( NMAX*INCMAX ), XX( NMAX*INCMAX ), & Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ), & YY( NMAX*INCMAX ) REAL G( NMAX ) ! .. Local Scalars .. integer IDIM( NIDIM ), INC( NINC ), KB( NKB ) COMPLEX ALPHA, ALS, BETA, BLS, TRANSL REAL ERR, ERRMAX integer I, IA, IB, IC, IKU, IM, IN, INCX, INCXS, INCY, & INCYS, IX, IY, KL, KLS, KU, KUS, LAA, LDA, & LDAS, LX, LY, M, ML, MS, N, NARGS, NC, ND, NK, & NERR, NL, NS LOGICAL BANDED, FTL, FULL, NULL, RESET, TRAN CHARACTER*1 TRANS, TRANSS ! .. Local Arrays .. CHARACTER*3 ICH ! .. External Functions .. LOGICAL ISAME( 13 ) integer NUMXER LOGICAL LCE, LCERES ! .. External Subroutines .. EXTERNAL LCE, LCERES, NUMXER ! .. Intrinsic Functions .. EXTERNAL CGBMV, CGEMV, CMAKE2, CMVCH ! .. Data statements .. INTRINSIC ABS, MAX, MIN !***FIRST EXECUTABLE STATEMENT CCHK12 DATA ICH/'NTC'/ FULL = SNAME( 3: 3 ) == 'E' ! Define the number of arguments. BANDED = SNAME( 3: 3 ) == 'B' if ( FULL ) then NARGS = 11 else if ( BANDED ) then NARGS = 13 ! end if NC = 0 RESET = .TRUE. ! ERRMAX = RZERO DO 120 IN = 1, NIDIM N = IDIM( IN ) ! ND = N/2 + 1 DO 110 IM = 1, 2 if ( IM == 1 ) & M = max ( N - ND, 0 ) if ( IM == 2 ) & ! M = min ( N + ND, NMAX ) if ( BANDED ) then NK = NKB else NK = 1 end if DO 100 IKU = 1, NK if ( BANDED ) then KU = KB( IKU ) KL = max ( KU - 1, 0 ) else KU = N - 1 KL = M - 1 ! Set LDA to 1 more than minimum value if room. end if if ( BANDED ) then LDA = KL + KU + 1 else LDA = M end if if ( LDA < NMAX ) & ! Skip tests if not enough room. LDA = LDA + 1 if ( LDA > NMAX ) & GO TO 100 LAA = LDA*N ! ! Generate the matrix A. ! NULL = N <= 0.OR.M <= 0 TRANSL = ZERO call CMAKE2( SNAME( 2: 3 ), ' ', ' ', M, N, A, NMAX, AA, & LDA, KL, KU, RESET, TRANSL ) DO 90 IC = 1, 3 TRANS = ICH( IC: IC ) ! TRAN = TRANS == 'T'.OR.TRANS == 'C' if ( TRAN ) then ML = N NL = M else ML = M NL = N ! end if DO 80 IX = 1, NINC INCX = INC( IX ) ! ! Generate the vector X. ! LX = ABS( INCX )*NL TRANSL = HALF call CMAKE2( 'GE', ' ', ' ', 1, NL, X, 1, XX, & ABS( INCX ), 0, NL - 1, RESET, TRANSL ) if ( NL > 1 ) then X( NL/2 ) = ZERO XX( 1 + ABS( INCX )*( NL/2 - 1 ) ) = ZERO ! end if DO 70 IY = 1, NINC INCY = INC( IY ) ! LY = ABS( INCY )*ML DO 60 IA = 1, NALF ! ALPHA = ALF( IA ) DO 50 IB = 1, NBET ! ! Generate the vector Y. ! BETA = BET( IB ) TRANSL = ZERO call CMAKE2( 'GE', ' ', ' ', 1, ML, Y, 1, & YY, ABS( INCY ), 0, ML - 1, & ! RESET, TRANSL ) ! ! Save every datum before calling the ! subroutine. ! NC = NC + 1 TRANSS = TRANS MS = M NS = N KLS = KL KUS = KU ALS = ALPHA DO I = 1, LAA AS( I ) = AA( I ) end do LDAS = LDA DO I = 1, LX XS( I ) = XX( I ) end do INCXS = INCX BLS = BETA DO I = 1, LY YS( I ) = YY( I ) end do ! ! Call the subroutine. ! INCYS = INCY if ( FULL ) then call CGEMV( TRANS, M, N, ALPHA, AA, & LDA, XX, INCX, BETA, YY, & INCY ) else if ( BANDED ) then call CGBMV( TRANS, M, N, KL, KU, ALPHA, & AA, LDA, XX, INCX, BETA, & YY, INCY ) ! ! Check if error-exit was taken incorrectly. ! end if if ( NUMXER(NERR) /= 0 ) then if ( kprint >= 2 ) then write ( NOUT, FMT = 9993 ) end if FATAL = .TRUE. ! ! See what data changed inside subroutines. ! end if ISAME( 1 ) = TRANS == TRANSS ISAME( 2 ) = MS == M ISAME( 3 ) = NS == N if ( FULL ) then ISAME( 4 ) = ALS == ALPHA ISAME( 5 ) = LCE( AS, AA, LAA ) ISAME( 6 ) = LDAS == LDA ISAME( 7 ) = LCE( XS, XX, LX ) ISAME( 8 ) = INCXS == INCX ISAME( 9 ) = BLS == BETA if ( NULL ) then ISAME( 10 ) = LCE( YS, YY, LY ) else ISAME( 10 ) = LCERES( 'GE', ' ', 1, & ML, YS, YY, & ABS( INCY ) ) end if ISAME( 11 ) = INCYS == INCY else if ( BANDED ) then ISAME( 4 ) = KLS == KL ISAME( 5 ) = KUS == KU ISAME( 6 ) = ALS == ALPHA ISAME( 7 ) = LCE( AS, AA, LAA ) ISAME( 8 ) = LDAS == LDA ISAME( 9 ) = LCE( XS, XX, LX ) ISAME( 10 ) = INCXS == INCX ISAME( 11 ) = BLS == BETA if ( NULL ) then ISAME( 12 ) = LCE( YS, YY, LY ) else ISAME( 12 ) = LCERES( 'GE', ' ', 1, & ML, YS, YY, & ABS( INCY ) ) end if ISAME( 13 ) = INCYS == INCY ! ! If data was incorrectly changed, report ! and return. ! end if DO 40 I = 1, NARGS if ( .NOT. ISAME( I ) ) then FATAL = .TRUE. if ( kprint >= 2 ) then write ( NOUT, FMT = 9998 )I end if end if ! 40 continue FTL = .FALSE. ! ! Check the result. ! if ( .NOT.NULL ) then call CMVCH( TRANS, M, N, ALPHA, A, & NMAX, X, INCX, BETA, Y, & INCY, YT, G, YY, EPS, ERR, & FTL, NOUT, .TRUE.,KPRINT) ERRMAX = max ( ERRMAX, ERR ) end if if ( FTL ) then FATAL = .TRUE. if ( kprint >= 3 ) then write (NOUT, FMT = 9996) SNAME if ( FULL ) then write ( NOUT, FMT = 9994 )NC, SNAME, & TRANS, M, N, ALPHA, LDA, & INCX, BETA, INCY else if ( BANDED ) then write ( NOUT, FMT = 9995 )NC, SNAME, & TRANS, M, N, KL, KU, & ALPHA, LDA, INCX, BETA, INCY end if end if ! end if ! 50 continue ! 60 continue ! 70 continue ! 80 continue ! 90 continue ! 100 continue ! 110 continue ! ! Report result. ! 120 continue if ( .NOT. FATAL ) then if ( kprint >= 3 ) then if ( ERRMAX < THRESH ) then write ( NOUT, FMT = 9999 )SNAME, NC else write ( NOUT, FMT = 9997 )SNAME, NC, ERRMAX end if end if end if ! return 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', & 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', & 'ANGED INCORRECTLY *******' ) 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', & 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, & ' - SUSPECT *******' ) 9996 FORMAT( ' ******* ', A6, ' FAILED ON call NUMBER:' ) 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 4( I3, ',' ), '(', & F4.1, ',', F4.1, '), A,', I3, ', X,', I2, ',(', F4.1, ',', & F4.1, '), Y,', I2, ') .' ) 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), '(', & F4.1, ',', F4.1, '), A,', I3, ', X,', I2, ',(', F4.1, ',', & F4.1, '), Y,', I2, ') .' ) 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID call *', & ! ! End of CCHK12. ! '******' ) end subroutine CCHK13 (SNAME, EPS, THRESH, NOUT, KPRINT, FATAL, NIDIM, & IDIM, NALF, ALF, NBET, BET, NMAX, A, AA, AS, B, BB, BS, C, CC, & !*****************************************************************************80 ! !! CCHK13 is a quick check for CGEMM. ! !***LIBRARY SLATEC (BLAS) !***KEYWORDS BLAS, QUICK CHECK SERVICE ROUTINE !***AUTHOR Dongarra, J. J., (ANL) ! Duff, I., (AERE) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) !***DESCRIPTION ! ! Quick check for CGEMM. ! ! Auxiliary routine for test program for Level 3 Blas. !***REFERENCES (NONE) !***ROUTINES CALLED CGEMM, CMAKE3, CMMCH, LCE, LCERES, NUMXER !***REVISION HISTORY (YYMMDD) ! 890208 DATE WRITTEN ! 910619 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE CCHK13 ! .. Parameters .. CS, CT, G) COMPLEX ZERO PARAMETER ( ZERO = ( 0.0, 0.0 ) ) REAL RZERO ! .. Scalar Arguments .. PARAMETER ( RZERO = 0.0 ) LOGICAL FATAL REAL EPS, THRESH integer KPRINT, NALF, NBET, NIDIM, NMAX, NOUT ! .. Array Arguments .. CHARACTER*6 SNAME COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), & AS( NMAX*NMAX ), B( NMAX, NMAX ), & BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), & C( NMAX, NMAX ), CC( NMAX*NMAX ), & CS( NMAX*NMAX ), CT( NMAX ) REAL G( NMAX ) ! .. Local Scalars .. integer IDIM( NIDIM ) COMPLEX ALPHA, ALS, BETA, BLS REAL ERR, ERRMAX integer I, IA, IB, ICA, ICB, IK, IM, IN, K, KS, LAA, & LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS, M, & MA, MB, MS, N, NA, NARGS, NB, NC, NERR, NS LOGICAL FTL, NULL, RESET, TRANA, TRANB CHARACTER*1 TRANAS, TRANBS, TRANSA, TRANSB ! .. Local Arrays .. CHARACTER*3 ICH ! .. External Functions .. LOGICAL ISAME( 13 ) integer NUMXER LOGICAL LCE, LCERES ! .. External Subroutines .. EXTERNAL LCE, LCERES, NUMXER ! .. Intrinsic Functions .. EXTERNAL CGEMM, CMAKE3, CMMCH ! .. Data statements .. INTRINSIC ABS, MAX, MIN !***FIRST EXECUTABLE STATEMENT CCHK13 DATA ICH/'NTC'/ NARGS = 13 NC = 0 RESET = .TRUE. ! ERRMAX = RZERO DO 110 IM = 1, NIDIM ! M = IDIM( IM ) DO 100 IN = 1, NIDIM ! Set LDC to 1 more than minimum value if room. N = IDIM( IN ) LDC = M if ( LDC < NMAX ) & ! ! Skip tests if not enough room. ! LDC = LDC + 1 if ( LDC > NMAX ) & GO TO 100 LCC = LDC*N NULL = N <= 0.OR.M <= 0 DO 90 IK = 1, NIDIM K = IDIM( IK ) DO 80 ICA = 1, 3 TRANSA = ICH( ICA: ICA ) TRANA = TRANSA == 'T'.OR.TRANSA == 'C' if ( TRANA ) then MA = K NA = M else MA = M NA = K ! ! Set LDA to 1 more than minimum value if room. ! end if LDA = MA if ( LDA < NMAX ) & ! Skip tests if not enough room. LDA = LDA + 1 if ( LDA > NMAX ) & GO TO 80 ! ! Generate the matrix A. ! LAA = LDA*NA call CMAKE3( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA, & ! RESET, ZERO ) DO 70 ICB = 1, 3 TRANSB = ICH( ICB: ICB ) ! TRANB = TRANSB == 'T'.OR.TRANSB == 'C' if ( TRANB ) then MB = N NB = K else MB = K NB = N ! Set LDB to 1 more than minimum value if room. end if LDB = MB if ( LDB < NMAX ) & ! Skip tests if not enough room. LDB = LDB + 1 if ( LDB > NMAX ) & GO TO 70 ! ! Generate the matrix B. ! LBB = LDB*NB call CMAKE3( 'GE', ' ', ' ', MB, NB, B, NMAX, BB, & ! LDB, RESET, ZERO ) DO 60 IA = 1, NALF ! ALPHA = ALF( IA ) DO 50 IB = 1, NBET ! ! Generate the matrix C. ! BETA = BET( IB ) call CMAKE3( 'GE', ' ', ' ', M, N, C, NMAX, & ! CC, LDC, RESET, ZERO ) ! ! Save every datum before calling the subroutine. ! NC = NC + 1 TRANAS = TRANSA TRANBS = TRANSB MS = M NS = N KS = K ALS = ALPHA AS(1:laa) = AA(1:laa) LDAS = LDA DO 20 I = 1, LBB BS( I ) = BB( I ) 20 continue LDBS = LDB BLS = BETA DO 30 I = 1, LCC CS( I ) = CC( I ) 30 continue ! ! Call the subroutine. ! LDCS = LDC call CGEMM( TRANSA, TRANSB, M, N, K, ALPHA, & ! ! Check if error-exit was taken incorrectly. ! AA, LDA, BB, LDB, BETA, CC, LDC ) if ( NUMXER(NERR) /= 0 ) then if ( kprint >= 2 ) then write ( NOUT, FMT = 9994 ) end if FATAL = .TRUE. ! ! See what data changed inside subroutines. ! end if ISAME( 1 ) = TRANSA == TRANAS ISAME( 2 ) = TRANSB == TRANBS ISAME( 3 ) = MS == M ISAME( 4 ) = NS == N ISAME( 5 ) = KS == K ISAME( 6 ) = ALS == ALPHA ISAME( 7 ) = LCE( AS, AA, LAA ) ISAME( 8 ) = LDAS == LDA ISAME( 9 ) = LCE( BS, BB, LBB ) ISAME( 10 ) = LDBS == LDB ISAME( 11 ) = BLS == BETA if ( NULL ) then ISAME( 12 ) = LCE( CS, CC, LCC ) else ISAME( 12 ) = LCERES( 'GE', ' ', M, N, CS, & CC, LDC ) end if ! ! If data was incorrectly changed, report ! ISAME( 13 ) = LDCS == LDC DO 40 I = 1, NARGS if ( .NOT. ISAME( I ) ) then FATAL = .TRUE. if ( kprint >= 2 ) then write ( NOUT, FMT = 9998 )I end if end if 40 continue FTL = .FALSE. ! ! Check the result. ! if ( .NOT.NULL ) then call CMMCH( TRANSA, TRANSB, M, N, K, & ALPHA, A, NMAX, B, NMAX, BETA, & C, NMAX, CT, G, CC, LDC, EPS, & ERR, FTL, NOUT, .TRUE., & kprint ) ERRMAX = max ( ERRMAX, ERR ) end if if ( FTL ) then FATAL = .TRUE. if ( kprint >= 3 ) then write ( NOUT, FMT = 9996 )SNAME write ( NOUT, FMT = 9995 )NC, SNAME, TRANSA, & TRANSB, M, N, K, ALPHA, LDA, LDB, BETA, & LDC end if end if 50